-- | Utility functions and definitions used in the Happy-generated
-- parser.  They are defined here because the @.y@ file is opaque to
-- linters and other tools.  In particular, we cannot enable warnings
-- for that file, because Happy-generated code is very dirty by GHC's
-- standards.
module Language.Futhark.Parser.Monad
  ( ParserMonad,
    ParserState,
    ReadLineMonad (..),
    parseInMonad,
    parse,
    getLinesFromM,
    lexer,
    mustBeEmpty,
    arrayFromList,
    binOp,
    binOpName,
    mustBe,
    primNegate,
    applyExp,
    patternExp,
    addDocSpec,
    addAttrSpec,
    addDoc,
    addAttr,
    twoDotsRange,
    SyntaxError (..),
    emptyArrayError,
    parseError,
    parseErrorAt,
    backOneCol,

    -- * Reexports
    L,
    Token,
  )
where

import Control.Applicative (liftA)
import Control.Monad
import Control.Monad.Except
import Control.Monad.Trans.State
import Data.Array hiding (index)
import Data.Monoid
import Data.Text qualified as T
import Futhark.Util.Loc
import Futhark.Util.Pretty hiding (line, line')
import Language.Futhark.Parser.Lexer
import Language.Futhark.Parser.Lexer.Wrapper (LexerError (..))
import Language.Futhark.Pretty ()
import Language.Futhark.Prop
import Language.Futhark.Syntax
import Prelude hiding (mod)

addDoc :: DocComment -> UncheckedDec -> UncheckedDec
addDoc :: DocComment -> UncheckedDec -> UncheckedDec
addDoc DocComment
doc (ValDec ValBindBase NoInfo Name
val) = forall (f :: * -> *) vn. ValBindBase f vn -> DecBase f vn
ValDec (ValBindBase NoInfo Name
val {valBindDoc :: Maybe DocComment
valBindDoc = forall a. a -> Maybe a
Just DocComment
doc})
addDoc DocComment
doc (TypeDec TypeBindBase NoInfo Name
tp) = forall (f :: * -> *) vn. TypeBindBase f vn -> DecBase f vn
TypeDec (TypeBindBase NoInfo Name
tp {typeDoc :: Maybe DocComment
typeDoc = forall a. a -> Maybe a
Just DocComment
doc})
addDoc DocComment
doc (SigDec SigBindBase NoInfo Name
sig) = forall (f :: * -> *) vn. SigBindBase f vn -> DecBase f vn
SigDec (SigBindBase NoInfo Name
sig {sigDoc :: Maybe DocComment
sigDoc = forall a. a -> Maybe a
Just DocComment
doc})
addDoc DocComment
doc (ModDec ModBindBase NoInfo Name
mod) = forall (f :: * -> *) vn. ModBindBase f vn -> DecBase f vn
ModDec (ModBindBase NoInfo Name
mod {modDoc :: Maybe DocComment
modDoc = forall a. a -> Maybe a
Just DocComment
doc})
addDoc DocComment
_ UncheckedDec
dec = UncheckedDec
dec

addDocSpec :: DocComment -> SpecBase NoInfo Name -> SpecBase NoInfo Name
addDocSpec :: DocComment -> SpecBase NoInfo Name -> SpecBase NoInfo Name
addDocSpec DocComment
doc (TypeAbbrSpec TypeBindBase NoInfo Name
tpsig) = forall (f :: * -> *) vn. TypeBindBase f vn -> SpecBase f vn
TypeAbbrSpec (TypeBindBase NoInfo Name
tpsig {typeDoc :: Maybe DocComment
typeDoc = forall a. a -> Maybe a
Just DocComment
doc})
addDocSpec DocComment
doc (ValSpec Name
name [TypeParamBase Name]
ps TypeExp Name
t NoInfo StructType
NoInfo Maybe DocComment
_ SrcLoc
loc) = forall (f :: * -> *) vn.
vn
-> [TypeParamBase vn]
-> TypeExp vn
-> f StructType
-> Maybe DocComment
-> SrcLoc
-> SpecBase f vn
ValSpec Name
name [TypeParamBase Name]
ps TypeExp Name
t forall {k} (a :: k). NoInfo a
NoInfo (forall a. a -> Maybe a
Just DocComment
doc) SrcLoc
loc
addDocSpec DocComment
doc (TypeSpec Liftedness
l Name
name [TypeParamBase Name]
ps Maybe DocComment
_ SrcLoc
loc) = forall (f :: * -> *) vn.
Liftedness
-> vn
-> [TypeParamBase vn]
-> Maybe DocComment
-> SrcLoc
-> SpecBase f vn
TypeSpec Liftedness
l Name
name [TypeParamBase Name]
ps (forall a. a -> Maybe a
Just DocComment
doc) SrcLoc
loc
addDocSpec DocComment
doc (ModSpec Name
name SigExpBase NoInfo Name
se Maybe DocComment
_ SrcLoc
loc) = forall (f :: * -> *) vn.
vn
-> SigExpBase f vn -> Maybe DocComment -> SrcLoc -> SpecBase f vn
ModSpec Name
name SigExpBase NoInfo Name
se (forall a. a -> Maybe a
Just DocComment
doc) SrcLoc
loc
addDocSpec DocComment
_ SpecBase NoInfo Name
spec = SpecBase NoInfo Name
spec

addAttr :: AttrInfo Name -> UncheckedDec -> UncheckedDec
addAttr :: AttrInfo Name -> UncheckedDec -> UncheckedDec
addAttr AttrInfo Name
attr (ValDec ValBindBase NoInfo Name
val) =
  forall (f :: * -> *) vn. ValBindBase f vn -> DecBase f vn
ValDec forall a b. (a -> b) -> a -> b
$ ValBindBase NoInfo Name
val {valBindAttrs :: [AttrInfo Name]
valBindAttrs = AttrInfo Name
attr forall a. a -> [a] -> [a]
: forall (f :: * -> *) vn. ValBindBase f vn -> [AttrInfo vn]
valBindAttrs ValBindBase NoInfo Name
val}
addAttr AttrInfo Name
_ UncheckedDec
dec = UncheckedDec
dec

-- We will extend this function once we actually start tracking these.
addAttrSpec :: AttrInfo Name -> UncheckedSpec -> UncheckedSpec
addAttrSpec :: AttrInfo Name -> SpecBase NoInfo Name -> SpecBase NoInfo Name
addAttrSpec AttrInfo Name
_attr SpecBase NoInfo Name
dec = SpecBase NoInfo Name
dec

mustBe :: L Token -> T.Text -> ParserMonad ()
mustBe :: L Token -> Text -> ParserMonad ()
mustBe (L Loc
_ (ID Name
got)) Text
expected
  | Name -> Text
nameToText Name
got forall a. Eq a => a -> a -> Bool
== Text
expected = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
mustBe (L Loc
loc Token
_) Text
expected =
  forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt Loc
loc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
    Text
"Only the keyword '" forall a. Semigroup a => a -> a -> a
<> Text
expected forall a. Semigroup a => a -> a -> a
<> Text
"' may appear here."

mustBeEmpty :: Located loc => loc -> ValueType -> ParserMonad ()
mustBeEmpty :: forall loc. Located loc => loc -> ValueType -> ParserMonad ()
mustBeEmpty loc
_ (Array ()
_ Uniqueness
_ (Shape [Int64]
dims) ScalarTypeBase Int64 ()
_)
  | Int64
0 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int64]
dims = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
mustBeEmpty loc
loc ValueType
t =
  forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt loc
loc forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
prettyText ValueType
t forall a. Semigroup a => a -> a -> a
<> Text
" is not an empty array."

data ParserState = ParserState
  { ParserState -> [Char]
_parserFile :: FilePath,
    ParserState -> Text
parserInput :: T.Text,
    ParserState -> ([L Token], Pos)
parserLexical :: ([L Token], Pos)
  }

type ParserMonad = ExceptT SyntaxError (StateT ParserState ReadLineMonad)

data ReadLineMonad a
  = Value a
  | GetLine (Maybe T.Text -> ReadLineMonad a)

readLineFromMonad :: ReadLineMonad (Maybe T.Text)
readLineFromMonad :: ReadLineMonad (Maybe Text)
readLineFromMonad = forall a. (Maybe Text -> ReadLineMonad a) -> ReadLineMonad a
GetLine forall a. a -> ReadLineMonad a
Value

instance Monad ReadLineMonad where
  Value a
x >>= :: forall a b.
ReadLineMonad a -> (a -> ReadLineMonad b) -> ReadLineMonad b
>>= a -> ReadLineMonad b
f = a -> ReadLineMonad b
f a
x
  GetLine Maybe Text -> ReadLineMonad a
g >>= a -> ReadLineMonad b
f = forall a. (Maybe Text -> ReadLineMonad a) -> ReadLineMonad a
GetLine forall a b. (a -> b) -> a -> b
$ Maybe Text -> ReadLineMonad a
g forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> a -> ReadLineMonad b
f

instance Functor ReadLineMonad where
  fmap :: forall a b. (a -> b) -> ReadLineMonad a -> ReadLineMonad b
fmap = forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA

instance Applicative ReadLineMonad where
  pure :: forall a. a -> ReadLineMonad a
pure = forall a. a -> ReadLineMonad a
Value
  <*> :: forall a b.
ReadLineMonad (a -> b) -> ReadLineMonad a -> ReadLineMonad b
(<*>) = forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

getLinesFromM :: Monad m => m T.Text -> ReadLineMonad a -> m a
getLinesFromM :: forall (m :: * -> *) a. Monad m => m Text -> ReadLineMonad a -> m a
getLinesFromM m Text
_ (Value a
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
getLinesFromM m Text
fetch (GetLine Maybe Text -> ReadLineMonad a
f) = do
  Text
s <- m Text
fetch
  forall (m :: * -> *) a. Monad m => m Text -> ReadLineMonad a -> m a
getLinesFromM m Text
fetch forall a b. (a -> b) -> a -> b
$ Maybe Text -> ReadLineMonad a
f forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
s

getNoLines :: ReadLineMonad a -> Either SyntaxError a
getNoLines :: forall a. ReadLineMonad a -> Either SyntaxError a
getNoLines (Value a
x) = forall a b. b -> Either a b
Right a
x
getNoLines (GetLine Maybe Text -> ReadLineMonad a
f) = forall a. ReadLineMonad a -> Either SyntaxError a
getNoLines forall a b. (a -> b) -> a -> b
$ Maybe Text -> ReadLineMonad a
f forall a. Maybe a
Nothing

arrayFromList :: [a] -> Array Int a
arrayFromList :: forall a. [a] -> Array Int a
arrayFromList [a]
l = forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l forall a. Num a => a -> a -> a
- Int
1) [a]
l

applyExp :: [UncheckedExp] -> ParserMonad UncheckedExp
applyExp :: [UncheckedExp] -> ParserMonad UncheckedExp
applyExp all_es :: [UncheckedExp]
all_es@((Constr Name
n [] NoInfo PatType
_ SrcLoc
loc1) : [UncheckedExp]
es) =
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) vn.
Name -> [ExpBase f vn] -> f PatType -> SrcLoc -> ExpBase f vn
Constr Name
n [UncheckedExp]
es forall {k} (a :: k). NoInfo a
NoInfo (forall a b. (Located a, Located b) => a -> b -> SrcLoc
srcspan SrcLoc
loc1 (forall a. [a] -> a
last [UncheckedExp]
all_es))
applyExp [UncheckedExp]
es =
  forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM forall {vn}.
(Eq vn, IsName vn) =>
ExpBase NoInfo vn
-> ExpBase NoInfo vn -> ParserMonad (ExpBase NoInfo vn)
op (forall a. [a] -> a
head [UncheckedExp]
es) (forall a. [a] -> [a]
tail [UncheckedExp]
es)
  where
    op :: ExpBase NoInfo vn
-> ExpBase NoInfo vn -> ParserMonad (ExpBase NoInfo vn)
op (AppExp (Index ExpBase NoInfo vn
e SliceBase NoInfo vn
is SrcLoc
floc) NoInfo AppRes
_) (ArrayLit [ExpBase NoInfo vn]
xs NoInfo PatType
_ SrcLoc
xloc) =
      forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt (forall a b. (Located a, Located b) => a -> b -> SrcLoc
srcspan SrcLoc
floc SrcLoc
xloc) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Doc a -> Text
docText forall a b. (a -> b) -> a -> b
$
        Doc Any
"Incorrect syntax for multi-dimensional indexing."
          forall a. Doc a -> Doc a -> Doc a
</> Doc Any
"Use"
          forall a. Doc a -> Doc a -> Doc a
<+> forall ann. Doc ann -> Doc ann
align (forall a ann. Pretty a => a -> Doc ann
pretty ExpBase NoInfo vn
index)
      where
        index :: ExpBase NoInfo vn
index = forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp (forall (f :: * -> *) vn.
ExpBase f vn -> SliceBase f vn -> SrcLoc -> AppExpBase f vn
Index ExpBase NoInfo vn
e (SliceBase NoInfo vn
is forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) vn. ExpBase f vn -> DimIndexBase f vn
DimFix [ExpBase NoInfo vn]
xs) SrcLoc
xloc) forall {k} (a :: k). NoInfo a
NoInfo
    op ExpBase NoInfo vn
f ExpBase NoInfo vn
x =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp (forall (f :: * -> *) vn.
ExpBase f vn
-> ExpBase f vn
-> f (Diet, Maybe VName)
-> SrcLoc
-> AppExpBase f vn
Apply ExpBase NoInfo vn
f ExpBase NoInfo vn
x forall {k} (a :: k). NoInfo a
NoInfo (forall a b. (Located a, Located b) => a -> b -> SrcLoc
srcspan ExpBase NoInfo vn
f ExpBase NoInfo vn
x)) forall {k} (a :: k). NoInfo a
NoInfo

patternExp :: UncheckedPat -> ParserMonad UncheckedExp
patternExp :: UncheckedPat -> ParserMonad UncheckedExp
patternExp (Id Name
v NoInfo PatType
_ SrcLoc
loc) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) vn.
QualName vn -> f PatType -> SrcLoc -> ExpBase f vn
Var (forall v. v -> QualName v
qualName Name
v) forall {k} (a :: k). NoInfo a
NoInfo SrcLoc
loc
patternExp (TuplePat [UncheckedPat]
pats SrcLoc
loc) = forall (f :: * -> *) vn. [ExpBase f vn] -> SrcLoc -> ExpBase f vn
TupLit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM UncheckedPat -> ParserMonad UncheckedExp
patternExp [UncheckedPat]
pats forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure SrcLoc
loc
patternExp (Wildcard NoInfo PatType
_ SrcLoc
loc) = forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt SrcLoc
loc forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
"cannot have wildcard here."
patternExp (PatLit PatLit
_ NoInfo PatType
_ SrcLoc
loc) = forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt SrcLoc
loc forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
"cannot have literal here."
patternExp (PatConstr Name
_ NoInfo PatType
_ [UncheckedPat]
_ SrcLoc
loc) = forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt SrcLoc
loc forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
"cannot have constructor here."
patternExp (PatAttr AttrInfo Name
_ UncheckedPat
p SrcLoc
_) = UncheckedPat -> ParserMonad UncheckedExp
patternExp UncheckedPat
p
patternExp (PatAscription UncheckedPat
pat TypeExp Name
_ SrcLoc
_) = UncheckedPat -> ParserMonad UncheckedExp
patternExp UncheckedPat
pat
patternExp (PatParens UncheckedPat
pat SrcLoc
_) = UncheckedPat -> ParserMonad UncheckedExp
patternExp UncheckedPat
pat
patternExp (RecordPat [(Name, UncheckedPat)]
fs SrcLoc
loc) = forall (f :: * -> *) vn. [FieldBase f vn] -> SrcLoc -> ExpBase f vn
RecordLit forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name, UncheckedPat)
-> ExceptT
     SyntaxError
     (StateT ParserState ReadLineMonad)
     (FieldBase NoInfo Name)
field [(Name, UncheckedPat)]
fs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure SrcLoc
loc
  where
    field :: (Name, UncheckedPat)
-> ExceptT
     SyntaxError
     (StateT ParserState ReadLineMonad)
     (FieldBase NoInfo Name)
field (Name
name, UncheckedPat
pat) = forall (f :: * -> *) vn.
Name -> ExpBase f vn -> SrcLoc -> FieldBase f vn
RecordFieldExplicit Name
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UncheckedPat -> ParserMonad UncheckedExp
patternExp UncheckedPat
pat forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure SrcLoc
loc

eof :: Pos -> L Token
eof :: Pos -> L Token
eof Pos
pos = forall a. Loc -> a -> L a
L (Pos -> Pos -> Loc
Loc Pos
pos Pos
pos) Token
EOF

binOpName :: L Token -> (QualName Name, Loc)
binOpName :: L Token -> (QualName Name, Loc)
binOpName (L Loc
loc (SYMBOL BinOp
_ [Name]
qs Name
op)) = (forall vn. [vn] -> vn -> QualName vn
QualName [Name]
qs Name
op, Loc
loc)
binOpName L Token
t = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"binOpName: unexpected " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show L Token
t

binOp :: UncheckedExp -> L Token -> UncheckedExp -> UncheckedExp
binOp :: UncheckedExp -> L Token -> UncheckedExp -> UncheckedExp
binOp UncheckedExp
x (L Loc
loc (SYMBOL BinOp
_ [Name]
qs Name
op)) UncheckedExp
y =
  forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp (forall (f :: * -> *) vn.
(QualName vn, SrcLoc)
-> f PatType
-> (ExpBase f vn, f (StructType, Maybe VName))
-> (ExpBase f vn, f (StructType, Maybe VName))
-> SrcLoc
-> AppExpBase f vn
BinOp (forall vn. [vn] -> vn -> QualName vn
QualName [Name]
qs Name
op, forall a. Located a => a -> SrcLoc
srclocOf Loc
loc) forall {k} (a :: k). NoInfo a
NoInfo (UncheckedExp
x, forall {k} (a :: k). NoInfo a
NoInfo) (UncheckedExp
y, forall {k} (a :: k). NoInfo a
NoInfo) (forall a b. (Located a, Located b) => a -> b -> SrcLoc
srcspan UncheckedExp
x UncheckedExp
y)) forall {k} (a :: k). NoInfo a
NoInfo
binOp UncheckedExp
_ L Token
t UncheckedExp
_ = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"binOp: unexpected " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show L Token
t

getTokens :: ParserMonad ([L Token], Pos)
getTokens :: ParserMonad ([L Token], Pos)
getTokens = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ParserState -> ([L Token], Pos)
parserLexical

putTokens :: ([L Token], Pos) -> ParserMonad ()
putTokens :: ([L Token], Pos) -> ParserMonad ()
putTokens ([L Token], Pos)
l = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify forall a b. (a -> b) -> a -> b
$ \ParserState
env -> ParserState
env {parserLexical :: ([L Token], Pos)
parserLexical = ([L Token], Pos)
l}

intNegate :: IntValue -> IntValue
intNegate :: IntValue -> IntValue
intNegate (Int8Value Int8
v) = Int8 -> IntValue
Int8Value (-Int8
v)
intNegate (Int16Value Int16
v) = Int16 -> IntValue
Int16Value (-Int16
v)
intNegate (Int32Value Int32
v) = Int32 -> IntValue
Int32Value (-Int32
v)
intNegate (Int64Value Int64
v) = Int64 -> IntValue
Int64Value (-Int64
v)

floatNegate :: FloatValue -> FloatValue
floatNegate :: FloatValue -> FloatValue
floatNegate (Float16Value Half
v) = Half -> FloatValue
Float16Value (-Half
v)
floatNegate (Float32Value Float
v) = Float -> FloatValue
Float32Value (-Float
v)
floatNegate (Float64Value Double
v) = Double -> FloatValue
Float64Value (-Double
v)

primNegate :: PrimValue -> PrimValue
primNegate :: PrimValue -> PrimValue
primNegate (FloatValue FloatValue
v) = FloatValue -> PrimValue
FloatValue forall a b. (a -> b) -> a -> b
$ FloatValue -> FloatValue
floatNegate FloatValue
v
primNegate (SignedValue IntValue
v) = IntValue -> PrimValue
SignedValue forall a b. (a -> b) -> a -> b
$ IntValue -> IntValue
intNegate IntValue
v
primNegate (UnsignedValue IntValue
v) = IntValue -> PrimValue
UnsignedValue forall a b. (a -> b) -> a -> b
$ IntValue -> IntValue
intNegate IntValue
v
primNegate (BoolValue Bool
v) = Bool -> PrimValue
BoolValue forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
v

readLine :: ParserMonad (Maybe T.Text)
readLine :: ParserMonad (Maybe Text)
readLine = do
  Maybe Text
s <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ReadLineMonad (Maybe Text)
readLineFromMonad
  case Maybe Text
s of
    Just Text
s' ->
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify forall a b. (a -> b) -> a -> b
$ \ParserState
env -> ParserState
env {parserInput :: Text
parserInput = ParserState -> Text
parserInput ParserState
env forall a. Semigroup a => a -> a -> a
<> Text
"\n" forall a. Semigroup a => a -> a -> a
<> Text
s'}
    Maybe Text
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
s

lexer :: (L Token -> ParserMonad a) -> ParserMonad a
lexer :: forall a. (L Token -> ParserMonad a) -> ParserMonad a
lexer L Token -> ParserMonad a
cont = do
  ([L Token]
ts, Pos
pos) <- ParserMonad ([L Token], Pos)
getTokens
  case [L Token]
ts of
    [] -> do
      Either SyntaxError a
ended <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ L Token -> ParserMonad a
cont forall a b. (a -> b) -> a -> b
$ Pos -> L Token
eof Pos
pos
      case Either SyntaxError a
ended of
        Right a
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
        Left SyntaxError
parse_e -> do
          Maybe Text
line <- ParserMonad (Maybe Text)
readLine
          Either LexerError ([L Token], Pos)
ts' <-
            case Maybe Text
line of
              Maybe Text
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SyntaxError
parse_e
              Just Text
line' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Pos -> Text -> Either LexerError ([L Token], Pos)
scanTokensText (Pos -> Char -> Pos
advancePos Pos
pos Char
'\n') Text
line'
          ([L Token]
ts'', Pos
pos') <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. LexerError -> SyntaxError
lexerErrToParseErr) forall (f :: * -> *) a. Applicative f => a -> f a
pure Either LexerError ([L Token], Pos)
ts'
          case [L Token]
ts'' of
            [] -> L Token -> ParserMonad a
cont forall a b. (a -> b) -> a -> b
$ Pos -> L Token
eof Pos
pos
            [L Token]
xs -> do
              ([L Token], Pos) -> ParserMonad ()
putTokens ([L Token]
xs, Pos
pos')
              forall a. (L Token -> ParserMonad a) -> ParserMonad a
lexer L Token -> ParserMonad a
cont
    (L Loc
_ (COMMENT Text
_) : [L Token]
xs) -> do
      ([L Token], Pos) -> ParserMonad ()
putTokens ([L Token]
xs, Pos
pos)
      forall a. (L Token -> ParserMonad a) -> ParserMonad a
lexer L Token -> ParserMonad a
cont
    (L Token
x : [L Token]
xs) -> do
      ([L Token], Pos) -> ParserMonad ()
putTokens ([L Token]
xs, Pos
pos)
      L Token -> ParserMonad a
cont L Token
x

parseError :: (L Token, [String]) -> ParserMonad a
parseError :: forall a. (L Token, [[Char]]) -> ParserMonad a
parseError (L Loc
loc Token
EOF, [[Char]]
expected) =
  forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt (forall a. Located a => a -> Loc
locOf Loc
loc) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$
    [ Text
"Unexpected end of file.",
      Text
"Expected one of the following: " forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords (forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
T.pack [[Char]]
expected)
    ]
parseError (L Loc
loc DOC {}, [[Char]]
_) =
  forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt (forall a. Located a => a -> Loc
locOf Loc
loc) forall a b. (a -> b) -> a -> b
$
    forall a. a -> Maybe a
Just Text
"Documentation comments ('-- |') are only permitted when preceding declarations."
parseError (L Loc
loc Token
_, [[Char]]
expected) = do
  Text
input <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ParserState -> Text
parserInput
  let ~(Loc (Pos [Char]
_ Int
_ Int
_ Int
beg) (Pos [Char]
_ Int
_ Int
_ Int
end)) = forall a. Located a => a -> Loc
locOf Loc
loc
      tok_src :: Text
tok_src = Int -> Text -> Text
T.take (Int
end forall a. Num a => a -> a -> a
- Int
beg forall a. Num a => a -> a -> a
+ Int
1) forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
beg Text
input
  forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt Loc
loc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$
    [ Text
"Unexpected token: '" forall a. Semigroup a => a -> a -> a
<> Text
tok_src forall a. Semigroup a => a -> a -> a
<> Text
"'",
      Text
"Expected one of the following: " forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords (forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
T.pack [[Char]]
expected)
    ]

parseErrorAt :: Located loc => loc -> Maybe T.Text -> ParserMonad a
parseErrorAt :: forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt loc
loc Maybe Text
Nothing = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Loc -> Text -> SyntaxError
SyntaxError (forall a. Located a => a -> Loc
locOf loc
loc) Text
"Syntax error."
parseErrorAt loc
loc (Just Text
s) = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Loc -> Text -> SyntaxError
SyntaxError (forall a. Located a => a -> Loc
locOf loc
loc) Text
s

emptyArrayError :: Loc -> ParserMonad a
emptyArrayError :: forall a. Loc -> ParserMonad a
emptyArrayError Loc
loc =
  forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt Loc
loc forall a b. (a -> b) -> a -> b
$
    forall a. a -> Maybe a
Just Text
"write empty arrays as 'empty(t)', for element type 't'.\n"

twoDotsRange :: Loc -> ParserMonad a
twoDotsRange :: forall a. Loc -> ParserMonad a
twoDotsRange Loc
loc = forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt Loc
loc forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Text
"use '...' for ranges, not '..'.\n"

-- | Move the end position back one column.
backOneCol :: Loc -> Loc
backOneCol :: Loc -> Loc
backOneCol (Loc Pos
start (Pos [Char]
f Int
l Int
c Int
o)) = Pos -> Pos -> Loc
Loc Pos
start forall a b. (a -> b) -> a -> b
$ [Char] -> Int -> Int -> Int -> Pos
Pos [Char]
f Int
l (Int
c forall a. Num a => a -> a -> a
- Int
1) (Int
o forall a. Num a => a -> a -> a
- Int
1)
backOneCol Loc
NoLoc = Loc
NoLoc

--- Now for the parser interface.

-- | A syntax error.
data SyntaxError = SyntaxError {SyntaxError -> Loc
syntaxErrorLoc :: Loc, SyntaxError -> Text
syntaxErrorMsg :: T.Text}

lexerErrToParseErr :: LexerError -> SyntaxError
lexerErrToParseErr :: LexerError -> SyntaxError
lexerErrToParseErr (LexerError Loc
loc Text
msg) = Loc -> Text -> SyntaxError
SyntaxError Loc
loc Text
msg

parseInMonad :: ParserMonad a -> FilePath -> T.Text -> ReadLineMonad (Either SyntaxError a)
parseInMonad :: forall a.
ParserMonad a
-> [Char] -> Text -> ReadLineMonad (Either SyntaxError a)
parseInMonad ParserMonad a
p [Char]
file Text
program =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. LexerError -> SyntaxError
lexerErrToParseErr)
    (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ParserMonad a
p) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([L Token], Pos) -> ParserState
env)
    (Pos -> Text -> Either LexerError ([L Token], Pos)
scanTokensText ([Char] -> Int -> Int -> Int -> Pos
Pos [Char]
file Int
1 Int
1 Int
0) Text
program)
  where
    env :: ([L Token], Pos) -> ParserState
env = [Char] -> Text -> ([L Token], Pos) -> ParserState
ParserState [Char]
file Text
program

parse :: ParserMonad a -> FilePath -> T.Text -> Either SyntaxError a
parse :: forall a. ParserMonad a -> [Char] -> Text -> Either SyntaxError a
parse ParserMonad a
p [Char]
file Text
program = forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a. ReadLineMonad a -> Either SyntaxError a
getNoLines forall a b. (a -> b) -> a -> b
$ forall a.
ParserMonad a
-> [Char] -> Text -> ReadLineMonad (Either SyntaxError a)
parseInMonad ParserMonad a
p [Char]
file Text
program