module Language.Futhark.Primitive.Parse
( pPrimValue,
pPrimType,
pFloatType,
pIntType,
constituent,
lexeme,
keyword,
whitespace,
)
where
import Data.Char (isAlphaNum)
import Data.Functor
import Data.Text qualified as T
import Data.Void
import Futhark.Util.Pretty
import Language.Futhark.Primitive
import Text.Megaparsec
import Text.Megaparsec.Char
import Text.Megaparsec.Char.Lexer qualified as L
constituent :: Char -> Bool
constituent :: Char -> Bool
constituent Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| (Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"_/'+-=!&^.<>*|" :: String))
whitespace :: Parsec Void T.Text ()
whitespace :: Parsec Void Text ()
whitespace = forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1 (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment Tokens Text
"--") forall (f :: * -> *) a. Alternative f => f a
empty
lexeme :: Parsec Void T.Text a -> Parsec Void T.Text a
lexeme :: forall a. Parsec Void Text a -> Parsec Void Text a
lexeme = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parsec Void Text ()
whitespace
keyword :: T.Text -> Parsec Void T.Text ()
keyword :: Text -> Parsec Void Text ()
keyword Text
s = forall a. Parsec Void Text a -> Parsec Void Text a
lexeme forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Text
s forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy (forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
constituent)
pIntValue :: Parsec Void T.Text IntValue
pIntValue :: Parsec Void Text IntValue
pIntValue = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ do
Integer
x <- forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m () -> m a -> m a
L.signed (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal
IntType
t <- Parsec Void Text IntType
pIntType
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall int. Integral int => IntType -> int -> IntValue
intValue IntType
t (Integer
x :: Integer)
pFloatValue :: Parsec Void T.Text FloatValue
pFloatValue :: Parsec Void Text FloatValue
pFloatValue =
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
[ Parsec Void Text FloatValue
pNum,
Text -> Parsec Void Text ()
keyword Text
"f16.nan" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Half -> FloatValue
Float16Value (Half
0 forall a. Fractional a => a -> a -> a
/ Half
0),
Text -> Parsec Void Text ()
keyword Text
"f16.inf" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Half -> FloatValue
Float16Value (Half
1 forall a. Fractional a => a -> a -> a
/ Half
0),
Text -> Parsec Void Text ()
keyword Text
"-f16.inf" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Half -> FloatValue
Float16Value (-Half
1 forall a. Fractional a => a -> a -> a
/ Half
0),
Text -> Parsec Void Text ()
keyword Text
"f32.nan" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Float -> FloatValue
Float32Value (Float
0 forall a. Fractional a => a -> a -> a
/ Float
0),
Text -> Parsec Void Text ()
keyword Text
"f32.inf" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Float -> FloatValue
Float32Value (Float
1 forall a. Fractional a => a -> a -> a
/ Float
0),
Text -> Parsec Void Text ()
keyword Text
"-f32.inf" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Float -> FloatValue
Float32Value (-Float
1 forall a. Fractional a => a -> a -> a
/ Float
0),
Text -> Parsec Void Text ()
keyword Text
"f64.nan" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Double -> FloatValue
Float64Value (Double
0 forall a. Fractional a => a -> a -> a
/ Double
0),
Text -> Parsec Void Text ()
keyword Text
"f64.inf" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Double -> FloatValue
Float64Value (Double
1 forall a. Fractional a => a -> a -> a
/ Double
0),
Text -> Parsec Void Text ()
keyword Text
"-f64.inf" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Double -> FloatValue
Float64Value (-Double
1 forall a. Fractional a => a -> a -> a
/ Double
0)
]
where
pNum :: Parsec Void Text FloatValue
pNum = forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ do
Double
x <- forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m () -> m a -> m a
L.signed (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, RealFloat a) =>
m a
L.float
FloatType
t <- Parsec Void Text FloatType
pFloatType
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall num. Real num => FloatType -> num -> FloatValue
floatValue FloatType
t (Double
x :: Double)
pBoolValue :: Parsec Void T.Text Bool
pBoolValue :: Parsec Void Text Bool
pBoolValue =
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
[ Text -> Parsec Void Text ()
keyword Text
"true" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True,
Text -> Parsec Void Text ()
keyword Text
"false" forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False
]
pPrimValue :: Parsec Void T.Text PrimValue
pPrimValue :: Parsec Void Text PrimValue
pPrimValue =
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
[ FloatValue -> PrimValue
FloatValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text FloatValue
pFloatValue,
IntValue -> PrimValue
IntValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text IntValue
pIntValue,
Bool -> PrimValue
BoolValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text Bool
pBoolValue,
PrimValue
UnitValue forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParsecT Void Text Identity Text
"()"
]
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> String -> m a
<?> String
"primitive value"
pFloatType :: Parsec Void T.Text FloatType
pFloatType :: Parsec Void Text FloatType
pFloatType = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {b}. Pretty b => b -> ParsecT Void Text Identity b
p [FloatType]
allFloatTypes
where
p :: b -> ParsecT Void Text Identity b
p b
t = Text -> Parsec Void Text ()
keyword (forall a. Pretty a => a -> Text
prettyText b
t) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> b
t
pIntType :: Parsec Void T.Text IntType
pIntType :: Parsec Void Text IntType
pIntType = forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {b}. Pretty b => b -> ParsecT Void Text Identity b
p [IntType]
allIntTypes
where
p :: b -> ParsecT Void Text Identity b
p b
t = Text -> Parsec Void Text ()
keyword (forall a. Pretty a => a -> Text
prettyText b
t) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> b
t
pPrimType :: Parsec Void T.Text PrimType
pPrimType :: Parsec Void Text PrimType
pPrimType =
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [forall {b}. Pretty b => b -> ParsecT Void Text Identity b
p PrimType
Bool, forall {b}. Pretty b => b -> ParsecT Void Text Identity b
p PrimType
Unit, FloatType -> PrimType
FloatType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text FloatType
pFloatType, IntType -> PrimType
IntType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text IntType
pIntType]
where
p :: b -> ParsecT Void Text Identity b
p b
t = Text -> Parsec Void Text ()
keyword (forall a. Pretty a => a -> Text
prettyText b
t) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> b
t