{-# LANGUAGE OverloadedStrings #-}

-- | Megaparsec-based parser for 'Value's in the textual value format.
-- The difference between this and the reader defined in
-- "Futhark.Data.Reader" is that we don't try to handle both the
-- textual and binary format - only the former.  On the other hand,
-- this parser has (much) better error messages and can be easily used
-- by other parsers (like the ones for FutharkScript or test blocks).
module Futhark.Data.Parser
  ( parsePrimType,
    parseType,
    parsePrimValue,
    parseValue,
  )
where

import Control.Monad (unless)
import Data.Char (digitToInt, isDigit, isHexDigit)
import Data.Functor
import qualified Data.Scientific as Sci
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Vector.Storable as SVec
import Data.Void
import Futhark.Data
import Text.Megaparsec
import Text.Megaparsec.Char (char)
import Text.Megaparsec.Char.Lexer (charLiteral, signed)
import Prelude hiding (exponent)

-- | Parse the name of a primitive type.  Does *not* consume any
-- trailing whitespace, nor does it permit any internal whitespace.
parsePrimType :: Parsec Void T.Text PrimType
parsePrimType :: Parsec Void Text PrimType
parsePrimType =
  [Parsec Void Text PrimType] -> Parsec Void Text PrimType
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ ParsecT Void Text Identity Text
"i8" ParsecT Void Text Identity Text
-> PrimType -> Parsec Void Text PrimType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> PrimType
I8,
      ParsecT Void Text Identity Text
"i16" ParsecT Void Text Identity Text
-> PrimType -> Parsec Void Text PrimType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> PrimType
I16,
      ParsecT Void Text Identity Text
"i32" ParsecT Void Text Identity Text
-> PrimType -> Parsec Void Text PrimType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> PrimType
I32,
      ParsecT Void Text Identity Text
"i64" ParsecT Void Text Identity Text
-> PrimType -> Parsec Void Text PrimType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> PrimType
I64,
      ParsecT Void Text Identity Text
"u8" ParsecT Void Text Identity Text
-> PrimType -> Parsec Void Text PrimType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> PrimType
U8,
      ParsecT Void Text Identity Text
"u16" ParsecT Void Text Identity Text
-> PrimType -> Parsec Void Text PrimType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> PrimType
U16,
      ParsecT Void Text Identity Text
"u32" ParsecT Void Text Identity Text
-> PrimType -> Parsec Void Text PrimType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> PrimType
U32,
      ParsecT Void Text Identity Text
"u64" ParsecT Void Text Identity Text
-> PrimType -> Parsec Void Text PrimType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> PrimType
U64,
      ParsecT Void Text Identity Text
"f16" ParsecT Void Text Identity Text
-> PrimType -> Parsec Void Text PrimType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> PrimType
F16,
      ParsecT Void Text Identity Text
"f32" ParsecT Void Text Identity Text
-> PrimType -> Parsec Void Text PrimType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> PrimType
F32,
      ParsecT Void Text Identity Text
"f64" ParsecT Void Text Identity Text
-> PrimType -> Parsec Void Text PrimType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> PrimType
F64,
      ParsecT Void Text Identity Text
"bool" ParsecT Void Text Identity Text
-> PrimType -> Parsec Void Text PrimType
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> PrimType
Bool
    ]

allowUnderscores :: String -> (Char -> Bool) -> Parsec Void T.Text T.Text
allowUnderscores :: String -> (Char -> Bool) -> ParsecT Void Text Identity Text
allowUnderscores String
desc Char -> Bool
p =
  (Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_')
    (Text -> Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ( Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>)
            (Text -> Text -> Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Text -> Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
desc) Char -> Bool
Token Text -> Bool
p
            ParsecT Void Text Identity (Text -> Text)
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe String
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP (String -> Maybe String
forall a. a -> Maybe a
Just String
descOrUnderscore) Char -> Bool
Token Text -> Bool
pOrUnderscore
        )
  where
    descOrUnderscore :: String
descOrUnderscore = String
desc String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" or underscore"
    pOrUnderscore :: Char -> Bool
pOrUnderscore Char
c = Char -> Bool
p Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'

-- Adapted from megaparsec.
decimal :: (Num a) => Parsec Void T.Text a
decimal :: forall a. Num a => Parsec Void Text a
decimal =
  Text -> a
mkNum (Text -> a)
-> ParsecT Void Text Identity Text -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> (Char -> Bool) -> ParsecT Void Text Identity Text
allowUnderscores String
"digit" Char -> Bool
isDigit
  where
    mkNum :: Text -> a
mkNum = (a -> Char -> a) -> a -> Text -> a
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' a -> Char -> a
forall {a}. Num a => a -> Char -> a
step a
0
    step :: a -> Char -> a
step a
a Char
c = a
a a -> a -> a
forall a. Num a => a -> a -> a
* a
10 a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
c)

-- Adapted from megaparsec.
binary :: (Num a) => Parsec Void T.Text a
binary :: forall a. Num a => Parsec Void Text a
binary =
  Text -> a
mkNum (Text -> a)
-> ParsecT Void Text Identity Text -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> (Char -> Bool) -> ParsecT Void Text Identity Text
allowUnderscores String
"binary digit" Char -> Bool
isBinDigit
  where
    mkNum :: Text -> a
mkNum = (a -> Char -> a) -> a -> Text -> a
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' a -> Char -> a
forall {a}. Num a => a -> Char -> a
step a
0
    step :: a -> Char -> a
step a
a Char
c = a
a a -> a -> a
forall a. Num a => a -> a -> a
* a
2 a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
c)
    isBinDigit :: Char -> Bool
isBinDigit Char
x = Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'0' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'1'

-- Adapted from megaparsec.
hexadecimal :: (Num a) => Parsec Void T.Text a
hexadecimal :: forall a. Num a => Parsec Void Text a
hexadecimal =
  Text -> a
mkNum (Text -> a)
-> ParsecT Void Text Identity Text -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> (Char -> Bool) -> ParsecT Void Text Identity Text
allowUnderscores String
"hexadecimal digit" Char -> Bool
isHexDigit
  where
    mkNum :: Text -> a
mkNum = (a -> Char -> a) -> a -> Text -> a
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' a -> Char -> a
forall {a}. Num a => a -> Char -> a
step a
0
    step :: a -> Char -> a
step a
a Char
c = a
a a -> a -> a
forall a. Num a => a -> a -> a
* a
16 a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
c)

parseInteger :: Parsec Void T.Text Integer
parseInteger :: Parsec Void Text Integer
parseInteger =
  ParsecT Void Text Identity ()
-> Parsec Void Text Integer -> Parsec Void Text Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m () -> m a -> m a
signed (() -> ParsecT Void Text Identity ()
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (Parsec Void Text Integer -> Parsec Void Text Integer)
-> Parsec Void Text Integer -> Parsec Void Text Integer
forall a b. (a -> b) -> a -> b
$
    [Parsec Void Text Integer] -> Parsec Void Text Integer
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
      [ ParsecT Void Text Identity Text
"0b" ParsecT Void Text Identity Text
-> Parsec Void Text Integer -> Parsec Void Text Integer
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Integer
forall a. Num a => Parsec Void Text a
binary,
        ParsecT Void Text Identity Text
"0x" ParsecT Void Text Identity Text
-> Parsec Void Text Integer -> Parsec Void Text Integer
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Integer
forall a. Num a => Parsec Void Text a
hexadecimal,
        Parsec Void Text Integer
forall a. Num a => Parsec Void Text a
decimal
      ]

scalar :: (SVec.Storable a) => (Vector Int -> Vector a -> Value) -> a -> Value
scalar :: forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector a -> Value
f a
x = Vector Int -> Vector a -> Value
f Vector Int
forall a. Monoid a => a
mempty (a -> Vector a
forall a. Storable a => a -> Vector a
SVec.singleton a
x)

parseIntConst :: (Integer -> Value) -> Parsec Void T.Text Value
parseIntConst :: (Integer -> Value) -> Parsec Void Text Value
parseIntConst Integer -> Value
def = do
  x <- Parsec Void Text Integer
parseInteger
  notFollowedBy $ choice ["f16", "f32", "f64", ".", "e"]
  choice
    [ intV I8Value x "i8",
      intV I16Value x "i16",
      intV I32Value x "i32",
      intV I64Value x "i64",
      intV U8Value x "u8",
      intV U16Value x "u16",
      intV U32Value x "u32",
      intV U64Value x "u64",
      pure $ def x
    ]
  where
    intV :: (Vector Int -> Vector a -> Value) -> Integer -> f a -> f Value
intV Vector Int -> Vector a -> Value
mk Integer
x f a
suffix =
      f a
suffix f a -> Value -> f Value
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Vector Int -> Vector a -> Value) -> a -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector a -> Value
mk (Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
x)

-- Adapted from megaparsec.
float :: (RealFloat a) => Parsec Void T.Text a
float :: forall a. RealFloat a => Parsec Void Text a
float = do
  c' <- Parsec Void Text Integer
forall a. Num a => Parsec Void Text a
decimal
  Sci.toRealFloat
    <$> ( ( do
              (c, e') <- dotDecimal c'
              e <- option e' $ try $ exponent e'
              pure $ Sci.scientific c e
          )
            <|> (Sci.scientific c' <$> exponent 0)
        )
  where
    exponent :: b -> ParsecT Void Text Identity b
exponent b
e' = do
      ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> ParsecT Void Text Identity ())
-> ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall a b. (a -> b) -> a -> b
$ [ParsecT Void Text Identity Text]
-> ParsecT Void Text Identity Text
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [ParsecT Void Text Identity Text
"e", ParsecT Void Text Identity Text
"E"]
      (b -> b -> b
forall a. Num a => a -> a -> a
+ b
e') (b -> b)
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity ()
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m () -> m a -> m a
signed (() -> ParsecT Void Text Identity ()
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ParsecT Void Text Identity b
forall a. Num a => Parsec Void Text a
decimal
    dotDecimal :: p -> ParsecT Void Text Identity (p, b)
dotDecimal p
c' = do
      ParsecT Void Text Identity Text -> ParsecT Void Text Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT Void Text Identity Text
"."
      Text -> (p, b)
mkNum (Text -> (p, b))
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (p, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> (Char -> Bool) -> ParsecT Void Text Identity Text
allowUnderscores String
"digit" Char -> Bool
isDigit
      where
        mkNum :: Text -> (p, b)
mkNum = ((p, b) -> Char -> (p, b)) -> (p, b) -> Text -> (p, b)
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' (p, b) -> Char -> (p, b)
forall {a} {b}. (Num a, Num b) => (a, b) -> Char -> (a, b)
step (p
c', b
0)
        step :: (a, b) -> Char -> (a, b)
step (a
a, b
e') Char
c =
          (a
a a -> a -> a
forall a. Num a => a -> a -> a
* a
10 a -> a -> a
forall a. Num a => a -> a -> a
+ Int -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
digitToInt Char
c), b
e' b -> b -> b
forall a. Num a => a -> a -> a
- b
1)

parseFloatConst :: Parsec Void T.Text Value
parseFloatConst :: Parsec Void Text Value
parseFloatConst =
  [Parsec Void Text Value] -> Parsec Void Text Value
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ ParsecT Void Text Identity Text
"f16.nan" ParsecT Void Text Identity Text -> Value -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Vector Int -> Vector Half -> Value) -> Half -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector Half -> Value
F16Value (Half
0 Half -> Half -> Half
forall a. Fractional a => a -> a -> a
/ Half
0),
      ParsecT Void Text Identity Text
"f32.nan" ParsecT Void Text Identity Text -> Value -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Vector Int -> Vector Float -> Value) -> Float -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector Float -> Value
F32Value (Float
0 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
0),
      ParsecT Void Text Identity Text
"f64.nan" ParsecT Void Text Identity Text -> Value -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Vector Int -> Vector Double -> Value) -> Double -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector Double -> Value
F64Value (Double
0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0),
      --
      ParsecT Void Text Identity Text
"f16.inf" ParsecT Void Text Identity Text -> Value -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Vector Int -> Vector Half -> Value) -> Half -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector Half -> Value
F16Value (Half
1 Half -> Half -> Half
forall a. Fractional a => a -> a -> a
/ Half
0),
      ParsecT Void Text Identity Text
"f32.inf" ParsecT Void Text Identity Text -> Value -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Vector Int -> Vector Float -> Value) -> Float -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector Float -> Value
F32Value (Float
1 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
0),
      ParsecT Void Text Identity Text
"f64.inf" ParsecT Void Text Identity Text -> Value -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Vector Int -> Vector Double -> Value) -> Double -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector Double -> Value
F64Value (Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0),
      --
      ParsecT Void Text Identity Text
"-f16.inf" ParsecT Void Text Identity Text -> Value -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Vector Int -> Vector Half -> Value) -> Half -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector Half -> Value
F16Value (-Half
1 Half -> Half -> Half
forall a. Fractional a => a -> a -> a
/ Half
0),
      ParsecT Void Text Identity Text
"-f32.inf" ParsecT Void Text Identity Text -> Value -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Vector Int -> Vector Float -> Value) -> Float -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector Float -> Value
F32Value (-Float
1 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
0),
      ParsecT Void Text Identity Text
"-f64.inf" ParsecT Void Text Identity Text -> Value -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Vector Int -> Vector Double -> Value) -> Double -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector Double -> Value
F64Value (-Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0),
      Parsec Void Text Value
numeric
    ]
  where
    numeric :: Parsec Void Text Value
numeric = do
      x <-
        ParsecT Void Text Identity ()
-> ParsecT Void Text Identity Double
-> ParsecT Void Text Identity Double
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m () -> m a -> m a
signed (() -> ParsecT Void Text Identity ()
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (ParsecT Void Text Identity Double
 -> ParsecT Void Text Identity Double)
-> ParsecT Void Text Identity Double
-> ParsecT Void Text Identity Double
forall a b. (a -> b) -> a -> b
$ [ParsecT Void Text Identity Double]
-> ParsecT Void Text Identity Double
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [ParsecT Void Text Identity Double
-> ParsecT Void Text Identity Double
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT Void Text Identity Double
forall a. RealFloat a => Parsec Void Text a
float, Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Integer -> Double)
-> Parsec Void Text Integer -> ParsecT Void Text Identity Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text Integer
forall a. Num a => Parsec Void Text a
decimal]
      choice
        [ floatV F16Value x "f16",
          floatV F32Value x "f32",
          floatV F64Value x "f64",
          floatV F64Value x ""
        ]

    floatV :: (Vector Int -> Vector a -> Value) -> Double -> f a -> f Value
floatV Vector Int -> Vector a -> Value
mk Double
x f a
suffix =
      f a
suffix f a -> Value -> f Value
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Vector Int -> Vector a -> Value) -> a -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector a -> Value
mk (Double -> a
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Double
x :: Double))

pBool :: Parsec Void T.Text Bool
pBool :: Parsec Void Text Bool
pBool = [Parsec Void Text Bool] -> Parsec Void Text Bool
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [ParsecT Void Text Identity Text
"true" ParsecT Void Text Identity Text -> Bool -> Parsec Void Text Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True, ParsecT Void Text Identity Text
"false" ParsecT Void Text Identity Text -> Bool -> Parsec Void Text Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False]

-- | Parse a primitive value.  Does *not* consume any trailing
-- whitespace, nor does it permit any internal whitespace.
parsePrimValue :: Parsec Void T.Text Value
parsePrimValue :: Parsec Void Text Value
parsePrimValue =
  [Parsec Void Text Value] -> Parsec Void Text Value
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Parsec Void Text Value -> Parsec Void Text Value
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ((Integer -> Value) -> Parsec Void Text Value
parseIntConst ((Integer -> Value) -> Parsec Void Text Value)
-> (Integer -> Value) -> Parsec Void Text Value
forall a b. (a -> b) -> a -> b
$ Vector Int -> Vector Int32 -> Value
I32Value Vector Int
forall a. Monoid a => a
mempty (Vector Int32 -> Value)
-> (Integer -> Vector Int32) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Vector Int32
forall a. Storable a => a -> Vector a
SVec.singleton (Int32 -> Vector Int32)
-> (Integer -> Int32) -> Integer -> Vector Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int32
forall a. Num a => Integer -> a
fromInteger),
      Parsec Void Text Value
parseFloatConst,
      (Vector Int -> Vector Bool -> Value) -> Bool -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector Bool -> Value
BoolValue (Bool -> Value) -> Parsec Void Text Bool -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text Bool
pBool
    ]

parseStringConst :: Parsec Void T.Text Value
parseStringConst :: Parsec Void Text Value
parseStringConst =
  Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'"' ParsecT Void Text Identity Char
-> Parsec Void Text Value -> Parsec Void Text Value
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Text -> Value
forall t. PutValue1 t => t -> Value
putValue1 (Text -> Value) -> (String -> Text) -> String -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Value)
-> ParsecT Void Text Identity String -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Char
charLiteral (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'"'))

-- | Parse float that is a specific type.
pFloat ::
  (SVec.Storable a, Fractional a) =>
  (Vector Int -> Vector a -> Value) ->
  T.Text ->
  Parsec Void T.Text Value
pFloat :: forall a.
(Storable a, Fractional a) =>
(Vector Int -> Vector a -> Value) -> Text -> Parsec Void Text Value
pFloat Vector Int -> Vector a -> Value
mk Text
suffix =
  [Parsec Void Text Value] -> Parsec Void Text Value
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
Text
nan ParsecT Void Text Identity (Tokens Text)
-> Value -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Vector Int -> Vector a -> Value) -> a -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector a -> Value
mk (a
0 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
0),
      Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
Text
inf ParsecT Void Text Identity (Tokens Text)
-> Value -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Vector Int -> Vector a -> Value) -> a -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector a -> Value
mk (a
1 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
0),
      Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Tokens Text
Text
neginf ParsecT Void Text Identity (Tokens Text)
-> Value -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> (Vector Int -> Vector a -> Value) -> a -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector a -> Value
mk (-a
1 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
0),
      Parsec Void Text Value
numeric
    ]
  where
    nan :: Text
nan = Text
suffix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".nan"
    inf :: Text
inf = Text
suffix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".inf"
    neginf :: Text
neginf = Text
"-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
inf
    numeric :: Parsec Void Text Value
numeric = do
      x <- ParsecT Void Text Identity ()
-> ParsecT Void Text Identity Double
-> ParsecT Void Text Identity Double
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m () -> m a -> m a
signed (() -> ParsecT Void Text Identity ()
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) (ParsecT Void Text Identity Double
 -> ParsecT Void Text Identity Double)
-> ParsecT Void Text Identity Double
-> ParsecT Void Text Identity Double
forall a b. (a -> b) -> a -> b
$ [ParsecT Void Text Identity Double]
-> ParsecT Void Text Identity Double
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [ParsecT Void Text Identity Double
-> ParsecT Void Text Identity Double
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT Void Text Identity Double
forall a. RealFloat a => Parsec Void Text a
float, Integer -> Double
forall a. Num a => Integer -> a
fromInteger (Integer -> Double)
-> Parsec Void Text Integer -> ParsecT Void Text Identity Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text Integer
forall a. Num a => Parsec Void Text a
decimal]
      void $ optional $ chunk suffix
      pure $ scalar mk $ realToFrac (x :: Double)

pPrimOfType :: PrimType -> Parsec Void T.Text Value
pPrimOfType :: PrimType -> Parsec Void Text Value
pPrimOfType PrimType
Bool = (Vector Int -> Vector Bool -> Value) -> Bool -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector Bool -> Value
BoolValue (Bool -> Value) -> Parsec Void Text Bool -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text Bool
pBool
pPrimOfType PrimType
F16 = (Vector Int -> Vector Half -> Value)
-> Text -> Parsec Void Text Value
forall a.
(Storable a, Fractional a) =>
(Vector Int -> Vector a -> Value) -> Text -> Parsec Void Text Value
pFloat Vector Int -> Vector Half -> Value
F16Value Text
"f16"
pPrimOfType PrimType
F32 = (Vector Int -> Vector Float -> Value)
-> Text -> Parsec Void Text Value
forall a.
(Storable a, Fractional a) =>
(Vector Int -> Vector a -> Value) -> Text -> Parsec Void Text Value
pFloat Vector Int -> Vector Float -> Value
F32Value Text
"f32"
pPrimOfType PrimType
F64 = (Vector Int -> Vector Double -> Value)
-> Text -> Parsec Void Text Value
forall a.
(Storable a, Fractional a) =>
(Vector Int -> Vector a -> Value) -> Text -> Parsec Void Text Value
pFloat Vector Int -> Vector Double -> Value
F64Value Text
"f64"
pPrimOfType PrimType
I8 = (Vector Int -> Vector Int8 -> Value) -> Int8 -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector Int8 -> Value
I8Value (Int8 -> Value) -> (Integer -> Int8) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int8
forall a. Num a => Integer -> a
fromInteger (Integer -> Value)
-> Parsec Void Text Integer -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text Integer
parseInteger Parsec Void Text Value
-> ParsecT Void Text Identity (Maybe Text)
-> Parsec Void Text Value
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void Text Identity Text
"i8"
pPrimOfType PrimType
I16 = (Vector Int -> Vector Int16 -> Value) -> Int16 -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector Int16 -> Value
I16Value (Int16 -> Value) -> (Integer -> Int16) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int16
forall a. Num a => Integer -> a
fromInteger (Integer -> Value)
-> Parsec Void Text Integer -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text Integer
parseInteger Parsec Void Text Value
-> ParsecT Void Text Identity (Maybe Text)
-> Parsec Void Text Value
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void Text Identity Text
"i16"
pPrimOfType PrimType
I32 = (Vector Int -> Vector Int32 -> Value) -> Int32 -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector Int32 -> Value
I32Value (Int32 -> Value) -> (Integer -> Int32) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int32
forall a. Num a => Integer -> a
fromInteger (Integer -> Value)
-> Parsec Void Text Integer -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text Integer
parseInteger Parsec Void Text Value
-> ParsecT Void Text Identity (Maybe Text)
-> Parsec Void Text Value
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void Text Identity Text
"i32"
pPrimOfType PrimType
I64 = (Vector Int -> Vector Int64 -> Value) -> Int64 -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector Int64 -> Value
I64Value (Int64 -> Value) -> (Integer -> Int64) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Int64
forall a. Num a => Integer -> a
fromInteger (Integer -> Value)
-> Parsec Void Text Integer -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text Integer
parseInteger Parsec Void Text Value
-> ParsecT Void Text Identity (Maybe Text)
-> Parsec Void Text Value
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void Text Identity Text
"i64"
pPrimOfType PrimType
U8 = (Vector Int -> Vector Word8 -> Value) -> Word8 -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector Word8 -> Value
U8Value (Word8 -> Value) -> (Integer -> Word8) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Word8
forall a. Num a => Integer -> a
fromInteger (Integer -> Value)
-> Parsec Void Text Integer -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text Integer
parseInteger Parsec Void Text Value
-> ParsecT Void Text Identity (Maybe Text)
-> Parsec Void Text Value
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void Text Identity Text
"u8"
pPrimOfType PrimType
U16 = (Vector Int -> Vector Word16 -> Value) -> Word16 -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector Word16 -> Value
U16Value (Word16 -> Value) -> (Integer -> Word16) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Word16
forall a. Num a => Integer -> a
fromInteger (Integer -> Value)
-> Parsec Void Text Integer -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text Integer
parseInteger Parsec Void Text Value
-> ParsecT Void Text Identity (Maybe Text)
-> Parsec Void Text Value
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void Text Identity Text
"u16"
pPrimOfType PrimType
U32 = (Vector Int -> Vector Word32 -> Value) -> Word32 -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector Word32 -> Value
U32Value (Word32 -> Value) -> (Integer -> Word32) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Word32
forall a. Num a => Integer -> a
fromInteger (Integer -> Value)
-> Parsec Void Text Integer -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text Integer
parseInteger Parsec Void Text Value
-> ParsecT Void Text Identity (Maybe Text)
-> Parsec Void Text Value
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void Text Identity Text
"u32"
pPrimOfType PrimType
U64 = (Vector Int -> Vector Word64 -> Value) -> Word64 -> Value
forall a.
Storable a =>
(Vector Int -> Vector a -> Value) -> a -> Value
scalar Vector Int -> Vector Word64 -> Value
U64Value (Word64 -> Value) -> (Integer -> Word64) -> Integer -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Word64
forall a. Num a => Integer -> a
fromInteger (Integer -> Value)
-> Parsec Void Text Integer -> Parsec Void Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text Integer
parseInteger Parsec Void Text Value
-> ParsecT Void Text Identity (Maybe Text)
-> Parsec Void Text Value
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void Text Identity Text
"u64"

lexeme :: Parsec Void T.Text () -> Parsec Void T.Text a -> Parsec Void T.Text a
lexeme :: forall a.
ParsecT Void Text Identity ()
-> Parsec Void Text a -> Parsec Void Text a
lexeme ParsecT Void Text Identity ()
sep Parsec Void Text a
p = Parsec Void Text a
p Parsec Void Text a
-> ParsecT Void Text Identity () -> Parsec Void Text a
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
sep

inBrackets :: Parsec Void T.Text () -> Parsec Void T.Text a -> Parsec Void T.Text a
inBrackets :: forall a.
ParsecT Void Text Identity ()
-> Parsec Void Text a -> Parsec Void Text a
inBrackets ParsecT Void Text Identity ()
sep = ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity a
-> ParsecT Void Text Identity a
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (ParsecT Void Text Identity ()
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a.
ParsecT Void Text Identity ()
-> Parsec Void Text a -> Parsec Void Text a
lexeme ParsecT Void Text Identity ()
sep ParsecT Void Text Identity Text
"[") (ParsecT Void Text Identity ()
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a.
ParsecT Void Text Identity ()
-> Parsec Void Text a -> Parsec Void Text a
lexeme ParsecT Void Text Identity ()
sep ParsecT Void Text Identity Text
"]")

-- | Parse a type.  Does *not* consume any trailing whitespace, nor
-- does it permit any internal whitespace.
parseType :: Parsec Void T.Text ValueType
parseType :: Parsec Void Text ValueType
parseType = [Int] -> PrimType -> ValueType
ValueType ([Int] -> PrimType -> ValueType)
-> ParsecT Void Text Identity [Int]
-> ParsecT Void Text Identity (PrimType -> ValueType)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Int -> ParsecT Void Text Identity [Int]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void Text Identity Int
parseDim ParsecT Void Text Identity (PrimType -> ValueType)
-> Parsec Void Text PrimType -> Parsec Void Text ValueType
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parsec Void Text PrimType
parsePrimType
  where
    parseDim :: ParsecT Void Text Identity Int
parseDim = Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer -> Int)
-> Parsec Void Text Integer -> ParsecT Void Text Identity Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT Void Text Identity Text
"[" ParsecT Void Text Identity Text
-> Parsec Void Text Integer -> Parsec Void Text Integer
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Integer
parseInteger Parsec Void Text Integer
-> ParsecT Void Text Identity Text -> Parsec Void Text Integer
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Text
"]")

parseEmpty :: Parsec Void T.Text Value
parseEmpty :: Parsec Void Text Value
parseEmpty = do
  ValueType dims t <- Parsec Void Text ValueType
parseType
  unless (product dims == 0) $ fail "Expected at least one empty dimension"
  pure $ case t of
    PrimType
I8 -> Vector Int -> Vector Int8 -> Value
I8Value ([Int] -> Vector Int
forall a. Storable a => [a] -> Vector a
SVec.fromList [Int]
dims) Vector Int8
forall a. Monoid a => a
mempty
    PrimType
I16 -> Vector Int -> Vector Int16 -> Value
I16Value ([Int] -> Vector Int
forall a. Storable a => [a] -> Vector a
SVec.fromList [Int]
dims) Vector Int16
forall a. Monoid a => a
mempty
    PrimType
I32 -> Vector Int -> Vector Int32 -> Value
I32Value ([Int] -> Vector Int
forall a. Storable a => [a] -> Vector a
SVec.fromList [Int]
dims) Vector Int32
forall a. Monoid a => a
mempty
    PrimType
I64 -> Vector Int -> Vector Int64 -> Value
I64Value ([Int] -> Vector Int
forall a. Storable a => [a] -> Vector a
SVec.fromList [Int]
dims) Vector Int64
forall a. Monoid a => a
mempty
    PrimType
U8 -> Vector Int -> Vector Word8 -> Value
U8Value ([Int] -> Vector Int
forall a. Storable a => [a] -> Vector a
SVec.fromList [Int]
dims) Vector Word8
forall a. Monoid a => a
mempty
    PrimType
U16 -> Vector Int -> Vector Word16 -> Value
U16Value ([Int] -> Vector Int
forall a. Storable a => [a] -> Vector a
SVec.fromList [Int]
dims) Vector Word16
forall a. Monoid a => a
mempty
    PrimType
U32 -> Vector Int -> Vector Word32 -> Value
U32Value ([Int] -> Vector Int
forall a. Storable a => [a] -> Vector a
SVec.fromList [Int]
dims) Vector Word32
forall a. Monoid a => a
mempty
    PrimType
U64 -> Vector Int -> Vector Word64 -> Value
U64Value ([Int] -> Vector Int
forall a. Storable a => [a] -> Vector a
SVec.fromList [Int]
dims) Vector Word64
forall a. Monoid a => a
mempty
    PrimType
F16 -> Vector Int -> Vector Half -> Value
F16Value ([Int] -> Vector Int
forall a. Storable a => [a] -> Vector a
SVec.fromList [Int]
dims) Vector Half
forall a. Monoid a => a
mempty
    PrimType
F32 -> Vector Int -> Vector Float -> Value
F32Value ([Int] -> Vector Int
forall a. Storable a => [a] -> Vector a
SVec.fromList [Int]
dims) Vector Float
forall a. Monoid a => a
mempty
    PrimType
F64 -> Vector Int -> Vector Double -> Value
F64Value ([Int] -> Vector Int
forall a. Storable a => [a] -> Vector a
SVec.fromList [Int]
dims) Vector Double
forall a. Monoid a => a
mempty
    PrimType
Bool -> Vector Int -> Vector Bool -> Value
BoolValue ([Int] -> Vector Int
forall a. Storable a => [a] -> Vector a
SVec.fromList [Int]
dims) Vector Bool
forall a. Monoid a => a
mempty

-- | Parse a value, given a post-lexeme parser for whitespace and a parser for primitive values..
parseValueWith :: Parsec Void T.Text () -> Parsec Void T.Text Value -> Parsec Void T.Text Value
parseValueWith :: ParsecT Void Text Identity ()
-> Parsec Void Text Value -> Parsec Void Text Value
parseValueWith ParsecT Void Text Identity ()
sep Parsec Void Text Value
pPrim =
  [Parsec Void Text Value] -> Parsec Void Text Value
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ ParsecT Void Text Identity ()
-> Parsec Void Text Value -> Parsec Void Text Value
forall a.
ParsecT Void Text Identity ()
-> Parsec Void Text a -> Parsec Void Text a
lexeme ParsecT Void Text Identity ()
sep Parsec Void Text Value
pPrim,
      ParsecT Void Text Identity ()
-> Parsec Void Text Value -> Parsec Void Text Value
forall a.
ParsecT Void Text Identity ()
-> Parsec Void Text a -> Parsec Void Text a
lexeme ParsecT Void Text Identity ()
sep Parsec Void Text Value
parseStringConst,
      Parsec Void Text [Value] -> Parsec Void Text Value
forall v.
PutValue v =>
Parsec Void Text v -> Parsec Void Text Value
putValue' (Parsec Void Text [Value] -> Parsec Void Text Value)
-> (Parsec Void Text [Value] -> Parsec Void Text [Value])
-> Parsec Void Text [Value]
-> Parsec Void Text Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsecT Void Text Identity ()
-> Parsec Void Text [Value] -> Parsec Void Text [Value]
forall a.
ParsecT Void Text Identity ()
-> Parsec Void Text a -> Parsec Void Text a
inBrackets ParsecT Void Text Identity ()
sep (Parsec Void Text [Value] -> Parsec Void Text Value)
-> Parsec Void Text [Value] -> Parsec Void Text Value
forall a b. (a -> b) -> a -> b
$ do
        v <- ParsecT Void Text Identity () -> Parsec Void Text Value
parseValue ParsecT Void Text Identity ()
sep
        (v :)
          <$> choice
            [ pComma *> parseValueWith sep (pPrimOfType (valueElemType v)) `sepEndBy` pComma,
              pure []
            ],
      ParsecT Void Text Identity ()
-> Parsec Void Text Value -> Parsec Void Text Value
forall a.
ParsecT Void Text Identity ()
-> Parsec Void Text a -> Parsec Void Text a
lexeme ParsecT Void Text Identity ()
sep (Parsec Void Text Value -> Parsec Void Text Value)
-> Parsec Void Text Value -> Parsec Void Text Value
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Text
"empty(" ParsecT Void Text Identity Text
-> Parsec Void Text Value -> Parsec Void Text Value
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parsec Void Text Value
parseEmpty Parsec Void Text Value
-> ParsecT Void Text Identity Text -> Parsec Void Text Value
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity Text
")"
    ]
  where
    pComma :: ParsecT Void Text Identity Text
pComma = ParsecT Void Text Identity ()
-> ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Text
forall a.
ParsecT Void Text Identity ()
-> Parsec Void Text a -> Parsec Void Text a
lexeme ParsecT Void Text Identity ()
sep ParsecT Void Text Identity Text
","

    putValue' :: (PutValue v) => Parsec Void T.Text v -> Parsec Void T.Text Value
    putValue' :: forall v.
PutValue v =>
Parsec Void Text v -> Parsec Void Text Value
putValue' Parsec Void Text v
p = do
      o <- ParsecT Void Text Identity Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
      x <- p
      case putValue x of
        Maybe Value
Nothing ->
          ParseError Text Void -> Parsec Void Text Value
forall a. ParseError Text Void -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a.
MonadParsec e s m =>
ParseError s e -> m a
parseError (ParseError Text Void -> Parsec Void Text Value)
-> (ErrorFancy Void -> ParseError Text Void)
-> ErrorFancy Void
-> Parsec Void Text Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Set (ErrorFancy Void) -> ParseError Text Void
forall s e. Int -> Set (ErrorFancy e) -> ParseError s e
FancyError Int
o (Set (ErrorFancy Void) -> ParseError Text Void)
-> (ErrorFancy Void -> Set (ErrorFancy Void))
-> ErrorFancy Void
-> ParseError Text Void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorFancy Void -> Set (ErrorFancy Void)
forall a. a -> Set a
S.singleton (ErrorFancy Void -> Parsec Void Text Value)
-> ErrorFancy Void -> Parsec Void Text Value
forall a b. (a -> b) -> a -> b
$
            String -> ErrorFancy Void
forall e. String -> ErrorFancy e
ErrorFail String
"array is irregular or has elements of multiple types."
        Just Value
v ->
          Value -> Parsec Void Text Value
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v

-- | Parse a value, given a post-lexeme parser for whitespace.
parseValue :: Parsec Void T.Text () -> Parsec Void T.Text Value
parseValue :: ParsecT Void Text Identity () -> Parsec Void Text Value
parseValue ParsecT Void Text Identity ()
sep = ParsecT Void Text Identity ()
-> Parsec Void Text Value -> Parsec Void Text Value
parseValueWith ParsecT Void Text Identity ()
sep Parsec Void Text Value
parsePrimValue