-- | 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 (ExceptT, MonadError (..), runExceptT)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State
import Data.Array hiding (index)
import Data.List.NonEmpty qualified as NE
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 NoInfo Name
t NoInfo StructType
NoInfo Maybe DocComment
_ SrcLoc
loc) = forall (f :: * -> *) vn.
vn
-> [TypeParamBase vn]
-> TypeExp f vn
-> f StructType
-> Maybe DocComment
-> SrcLoc
-> SpecBase f vn
ValSpec Name
name [TypeParamBase Name]
ps TypeExp NoInfo 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 :: NE.NonEmpty UncheckedExp -> ParserMonad UncheckedExp
applyExp :: NonEmpty UncheckedExp -> ParserMonad UncheckedExp
applyExp all_es :: NonEmpty UncheckedExp
all_es@((Constr Name
n [] NoInfo PatType
_ SrcLoc
loc1) NE.:| [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. NonEmpty a -> a
NE.last NonEmpty UncheckedExp
all_es))
applyExp NonEmpty 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. NonEmpty a -> a
NE.head NonEmpty UncheckedExp
es) (forall a. NonEmpty a -> [a]
NE.tail NonEmpty 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 vn.
ExpBase NoInfo vn -> ExpBase NoInfo vn -> ExpBase NoInfo vn
mkApplyUT ExpBase NoInfo vn
f ExpBase NoInfo vn
x

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 NoInfo 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