-- | Parsers for primitive values and types.
module Language.Futhark.Primitive.Parse
  ( pPrimValue,
    pPrimType,
    pFloatType,
    pIntType,

    -- * Building blocks
    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

-- | Is this character a valid member of an identifier?
constituent :: Char -> Bool
constituent :: Char -> Bool
constituent Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| (Char
c Char -> [Char] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ([Char]
"_/'+-=!&^.<>*|%" :: String))

-- | Consume whitespace (including skipping line comments).
whitespace :: Parsec Void T.Text ()
whitespace :: Parsec Void Text ()
whitespace = Parsec Void Text ()
-> Parsec Void Text ()
-> Parsec Void Text ()
-> Parsec Void Text ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space Parsec Void Text ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1 (Tokens Text -> Parsec Void Text ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment Tokens Text
"--") Parsec Void Text ()
forall a. ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a
empty

-- | Consume whitespace after the provided parser, if it succeeds.
lexeme :: Parsec Void T.Text a -> Parsec Void T.Text a
lexeme :: forall a. Parsec Void Text a -> Parsec Void Text a
lexeme = ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall a. Parsec Void Text a -> Parsec Void Text a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT Void Text Identity a -> ParsecT Void Text Identity a)
-> (ParsecT Void Text Identity a -> ParsecT Void Text Identity a)
-> ParsecT Void Text Identity a
-> ParsecT Void Text Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Void Text ()
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parsec Void Text ()
whitespace

-- | @keyword k@ parses @k@, which must not be immediately followed by
-- a 'constituent' character.  This ensures that @iff@ is not seen as
-- the @if@ keyword followed by @f@.  Sometimes called the "maximum
-- munch" rule.
keyword :: T.Text -> Parsec Void T.Text ()
keyword :: Text -> Parsec Void Text ()
keyword Text
s = Parsec Void Text () -> Parsec Void Text ()
forall a. Parsec Void Text a -> Parsec Void Text a
lexeme (Parsec Void Text () -> Parsec Void Text ())
-> Parsec Void Text () -> Parsec Void Text ()
forall a b. (a -> b) -> a -> b
$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
chunk Text
Tokens Text
s ParsecT Void Text Identity (Tokens Text)
-> Parsec Void Text () -> Parsec Void Text ()
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
*> ParsecT Void Text Identity (Token Text) -> Parsec Void Text ()
forall a. ParsecT Void Text Identity a -> Parsec Void Text ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ((Token Text -> Bool) -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy Char -> Bool
Token Text -> Bool
constituent)

-- | Parse an integer value.
pIntValue :: Parsec Void T.Text IntValue
pIntValue :: Parsec Void Text IntValue
pIntValue = Parsec Void Text IntValue -> Parsec Void Text IntValue
forall a. Parsec Void Text a -> Parsec Void Text a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parsec Void Text IntValue -> Parsec Void Text IntValue)
-> Parsec Void Text IntValue -> Parsec Void Text IntValue
forall a b. (a -> b) -> a -> b
$ do
  Integer
x <- Parsec Void Text ()
-> ParsecT Void Text Identity Integer
-> ParsecT Void Text Identity Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m () -> m a -> m a
L.signed (() -> Parsec Void Text ()
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ParsecT Void Text Identity Integer
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
  IntValue -> Parsec Void Text IntValue
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IntValue -> Parsec Void Text IntValue)
-> IntValue -> Parsec Void Text IntValue
forall a b. (a -> b) -> a -> b
$ IntType -> Integer -> IntValue
forall int. Integral int => IntType -> int -> IntValue
intValue IntType
t (Integer
x :: Integer)

-- | Parse a floating-point value.
pFloatValue :: Parsec Void T.Text FloatValue
pFloatValue :: Parsec Void Text FloatValue
pFloatValue =
  [Parsec Void Text FloatValue] -> Parsec Void Text FloatValue
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" Parsec Void Text () -> FloatValue -> Parsec Void Text FloatValue
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Half -> FloatValue
Float16Value (Half
0 Half -> Half -> Half
forall a. Fractional a => a -> a -> a
/ Half
0),
      Text -> Parsec Void Text ()
keyword Text
"f16.inf" Parsec Void Text () -> FloatValue -> Parsec Void Text FloatValue
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Half -> FloatValue
Float16Value (Half
1 Half -> Half -> Half
forall a. Fractional a => a -> a -> a
/ Half
0),
      Text -> Parsec Void Text ()
keyword Text
"-f16.inf" Parsec Void Text () -> FloatValue -> Parsec Void Text FloatValue
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Half -> FloatValue
Float16Value (-Half
1 Half -> Half -> Half
forall a. Fractional a => a -> a -> a
/ Half
0),
      Text -> Parsec Void Text ()
keyword Text
"f32.nan" Parsec Void Text () -> FloatValue -> Parsec Void Text FloatValue
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Float -> FloatValue
Float32Value (Float
0 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
0),
      Text -> Parsec Void Text ()
keyword Text
"f32.inf" Parsec Void Text () -> FloatValue -> Parsec Void Text FloatValue
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Float -> FloatValue
Float32Value (Float
1 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
0),
      Text -> Parsec Void Text ()
keyword Text
"-f32.inf" Parsec Void Text () -> FloatValue -> Parsec Void Text FloatValue
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Float -> FloatValue
Float32Value (-Float
1 Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
0),
      Text -> Parsec Void Text ()
keyword Text
"f64.nan" Parsec Void Text () -> FloatValue -> Parsec Void Text FloatValue
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Double -> FloatValue
Float64Value (Double
0 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0),
      Text -> Parsec Void Text ()
keyword Text
"f64.inf" Parsec Void Text () -> FloatValue -> Parsec Void Text FloatValue
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Double -> FloatValue
Float64Value (Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0),
      Text -> Parsec Void Text ()
keyword Text
"-f64.inf" Parsec Void Text () -> FloatValue -> Parsec Void Text FloatValue
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Double -> FloatValue
Float64Value (-Double
1 Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
0)
    ]
  where
    pNum :: Parsec Void Text FloatValue
pNum = Parsec Void Text FloatValue -> Parsec Void Text FloatValue
forall a. Parsec Void Text a -> Parsec Void Text a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parsec Void Text FloatValue -> Parsec Void Text FloatValue)
-> Parsec Void Text FloatValue -> Parsec Void Text FloatValue
forall a b. (a -> b) -> a -> b
$ do
      Double
x <- Parsec Void Text ()
-> 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
L.signed (() -> Parsec Void Text ()
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ParsecT Void Text Identity Double
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
      FloatValue -> Parsec Void Text FloatValue
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FloatValue -> Parsec Void Text FloatValue)
-> FloatValue -> Parsec Void Text FloatValue
forall a b. (a -> b) -> a -> b
$ FloatType -> Double -> FloatValue
forall num. Real num => FloatType -> num -> FloatValue
floatValue FloatType
t (Double
x :: Double)

-- | Parse a boolean value.
pBoolValue :: Parsec Void T.Text Bool
pBoolValue :: Parsec Void Text Bool
pBoolValue =
  [Parsec Void Text Bool] -> Parsec Void Text Bool
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ Text -> Parsec Void Text ()
keyword Text
"true" Parsec Void Text () -> Bool -> Parsec Void Text Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
True,
      Text -> Parsec Void Text ()
keyword Text
"false" Parsec Void Text () -> Bool -> Parsec Void Text Bool
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Bool
False
    ]

-- | Defined in this module for convenience.
pPrimValue :: Parsec Void T.Text PrimValue
pPrimValue :: Parsec Void Text PrimValue
pPrimValue =
  [Parsec Void Text PrimValue] -> Parsec Void Text PrimValue
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
    [ FloatValue -> PrimValue
FloatValue (FloatValue -> PrimValue)
-> Parsec Void Text FloatValue -> Parsec Void Text PrimValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text FloatValue
pFloatValue,
      IntValue -> PrimValue
IntValue (IntValue -> PrimValue)
-> Parsec Void Text IntValue -> Parsec Void Text PrimValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text IntValue
pIntValue,
      Bool -> PrimValue
BoolValue (Bool -> PrimValue)
-> Parsec Void Text Bool -> Parsec Void Text PrimValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text Bool
pBoolValue,
      PrimValue
UnitValue PrimValue -> Parsec Void Text Text -> Parsec Void Text PrimValue
forall a b.
a -> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parsec Void Text Text -> Parsec Void Text Text
forall a. Parsec Void Text a -> Parsec Void Text a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parsec Void Text Text -> Parsec Void Text Text
forall a. Parsec Void Text a -> Parsec Void Text a
lexeme Parsec Void Text Text
"(" Parsec Void Text Text
-> Parsec Void Text Text -> Parsec Void Text Text
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 Text -> Parsec Void Text Text
forall a. Parsec Void Text a -> Parsec Void Text a
lexeme Parsec Void Text Text
")")
    ]
    Parsec Void Text PrimValue -> [Char] -> Parsec Void Text PrimValue
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> [Char] -> m a
<?> [Char]
"primitive value"

-- | Parse a floating-point type.
pFloatType :: Parsec Void T.Text FloatType
pFloatType :: Parsec Void Text FloatType
pFloatType = [Parsec Void Text FloatType] -> Parsec Void Text FloatType
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([Parsec Void Text FloatType] -> Parsec Void Text FloatType)
-> [Parsec Void Text FloatType] -> Parsec Void Text FloatType
forall a b. (a -> b) -> a -> b
$ (FloatType -> Parsec Void Text FloatType)
-> [FloatType] -> [Parsec Void Text FloatType]
forall a b. (a -> b) -> [a] -> [b]
map FloatType -> Parsec Void Text FloatType
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 (b -> Text
forall a. Pretty a => a -> Text
prettyText b
t) Parsec Void Text () -> b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> b
t

-- | Parse an integer type.
pIntType :: Parsec Void T.Text IntType
pIntType :: Parsec Void Text IntType
pIntType = [Parsec Void Text IntType] -> Parsec Void Text IntType
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([Parsec Void Text IntType] -> Parsec Void Text IntType)
-> [Parsec Void Text IntType] -> Parsec Void Text IntType
forall a b. (a -> b) -> a -> b
$ (IntType -> Parsec Void Text IntType)
-> [IntType] -> [Parsec Void Text IntType]
forall a b. (a -> b) -> [a] -> [b]
map IntType -> Parsec Void Text IntType
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 (b -> Text
forall a. Pretty a => a -> Text
prettyText b
t) Parsec Void Text () -> b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> b
t

-- | Parse a primitive type.
pPrimType :: Parsec Void T.Text PrimType
pPrimType :: Parsec Void Text PrimType
pPrimType =
  [Parsec Void Text PrimType] -> Parsec Void Text PrimType
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [PrimType -> Parsec Void Text PrimType
forall {b}. Pretty b => b -> ParsecT Void Text Identity b
p PrimType
Bool, PrimType -> Parsec Void Text PrimType
forall {b}. Pretty b => b -> ParsecT Void Text Identity b
p PrimType
Unit, FloatType -> PrimType
FloatType (FloatType -> PrimType)
-> Parsec Void Text FloatType -> Parsec Void Text PrimType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec Void Text FloatType
pFloatType, IntType -> PrimType
IntType (IntType -> PrimType)
-> Parsec Void Text IntType -> Parsec Void Text PrimType
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 (b -> Text
forall a. Pretty a => a -> Text
prettyText b
t) Parsec Void Text () -> b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> b
t