{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}

-- | 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,
    combArrayElements,
    binOp,
    binOpName,
    mustBe,
    floatNegate,
    intNegate,
    primNegate,
    primTypeFromName,
    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 qualified Data.Map.Strict as M
import Data.Monoid
import qualified Data.Text as T
import Futhark.Util.Loc
import Futhark.Util.Pretty hiding (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) = ValBindBase NoInfo Name -> UncheckedDec
forall (f :: * -> *) vn. ValBindBase f vn -> DecBase f vn
ValDec (ValBindBase NoInfo Name
val {valBindDoc :: Maybe DocComment
valBindDoc = DocComment -> Maybe DocComment
forall a. a -> Maybe a
Just DocComment
doc})
addDoc DocComment
doc (TypeDec TypeBindBase NoInfo Name
tp) = TypeBindBase NoInfo Name -> UncheckedDec
forall (f :: * -> *) vn. TypeBindBase f vn -> DecBase f vn
TypeDec (TypeBindBase NoInfo Name
tp {typeDoc :: Maybe DocComment
typeDoc = DocComment -> Maybe DocComment
forall a. a -> Maybe a
Just DocComment
doc})
addDoc DocComment
doc (SigDec SigBindBase NoInfo Name
sig) = SigBindBase NoInfo Name -> UncheckedDec
forall (f :: * -> *) vn. SigBindBase f vn -> DecBase f vn
SigDec (SigBindBase NoInfo Name
sig {sigDoc :: Maybe DocComment
sigDoc = DocComment -> Maybe DocComment
forall a. a -> Maybe a
Just DocComment
doc})
addDoc DocComment
doc (ModDec ModBindBase NoInfo Name
mod) = ModBindBase NoInfo Name -> UncheckedDec
forall (f :: * -> *) vn. ModBindBase f vn -> DecBase f vn
ModDec (ModBindBase NoInfo Name
mod {modDoc :: Maybe DocComment
modDoc = DocComment -> Maybe DocComment
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) = TypeBindBase NoInfo Name -> SpecBase NoInfo Name
forall (f :: * -> *) vn. TypeBindBase f vn -> SpecBase f vn
TypeAbbrSpec (TypeBindBase NoInfo Name
tpsig {typeDoc :: Maybe DocComment
typeDoc = DocComment -> Maybe DocComment
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) = Name
-> [TypeParamBase Name]
-> TypeExp Name
-> NoInfo StructType
-> Maybe DocComment
-> SrcLoc
-> SpecBase NoInfo Name
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 NoInfo StructType
forall a. NoInfo a
NoInfo (DocComment -> Maybe DocComment
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) = Liftedness
-> Name
-> [TypeParamBase Name]
-> Maybe DocComment
-> SrcLoc
-> SpecBase NoInfo Name
forall (f :: * -> *) vn.
Liftedness
-> vn
-> [TypeParamBase vn]
-> Maybe DocComment
-> SrcLoc
-> SpecBase f vn
TypeSpec Liftedness
l Name
name [TypeParamBase Name]
ps (DocComment -> Maybe DocComment
forall a. a -> Maybe a
Just DocComment
doc) SrcLoc
loc
addDocSpec DocComment
doc (ModSpec Name
name SigExpBase NoInfo Name
se Maybe DocComment
_ SrcLoc
loc) = Name
-> SigExpBase NoInfo Name
-> Maybe DocComment
-> SrcLoc
-> SpecBase NoInfo Name
forall (f :: * -> *) vn.
vn
-> SigExpBase f vn -> Maybe DocComment -> SrcLoc -> SpecBase f vn
ModSpec Name
name SigExpBase NoInfo Name
se (DocComment -> Maybe DocComment
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) =
  ValBindBase NoInfo Name -> UncheckedDec
forall (f :: * -> *) vn. ValBindBase f vn -> DecBase f vn
ValDec (ValBindBase NoInfo Name -> UncheckedDec)
-> ValBindBase NoInfo Name -> UncheckedDec
forall a b. (a -> b) -> a -> b
$ ValBindBase NoInfo Name
val {valBindAttrs :: [AttrInfo Name]
valBindAttrs = AttrInfo Name
attr AttrInfo Name -> [AttrInfo Name] -> [AttrInfo Name]
forall a. a -> [a] -> [a]
: ValBindBase NoInfo Name -> [AttrInfo Name]
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 -> String -> ParserMonad ()
mustBe :: L Token -> String -> ParserMonad ()
mustBe (L Loc
_ (ID Name
got)) String
expected
  | Name -> String
nameToString Name
got String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
expected = () -> ParserMonad ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
mustBe (L Loc
loc Token
_) String
expected =
  Loc -> Maybe String -> ParserMonad ()
forall loc a. Located loc => loc -> Maybe String -> ParserMonad a
parseErrorAt Loc
loc (Maybe String -> ParserMonad ())
-> (String -> Maybe String) -> String -> ParserMonad ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just (String -> ParserMonad ()) -> String -> ParserMonad ()
forall a b. (a -> b) -> a -> b
$
    String
"Only the keyword '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
expected String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' may appear here."

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

data ParserState = ParserState
  { ParserState -> String
_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 = (Maybe Text -> ReadLineMonad (Maybe Text))
-> ReadLineMonad (Maybe Text)
forall a. (Maybe Text -> ReadLineMonad a) -> ReadLineMonad a
GetLine Maybe Text -> ReadLineMonad (Maybe Text)
forall a. a -> ReadLineMonad a
Value

instance Monad ReadLineMonad where
  Value a
x >>= :: 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 = (Maybe Text -> ReadLineMonad b) -> ReadLineMonad b
forall a. (Maybe Text -> ReadLineMonad a) -> ReadLineMonad a
GetLine ((Maybe Text -> ReadLineMonad b) -> ReadLineMonad b)
-> (Maybe Text -> ReadLineMonad b) -> ReadLineMonad b
forall a b. (a -> b) -> a -> b
$ Maybe Text -> ReadLineMonad a
g (Maybe Text -> ReadLineMonad a)
-> (a -> ReadLineMonad b) -> Maybe Text -> ReadLineMonad b
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 :: (a -> b) -> ReadLineMonad a -> ReadLineMonad b
fmap = (a -> b) -> ReadLineMonad a -> ReadLineMonad b
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA

instance Applicative ReadLineMonad where
  pure :: a -> ReadLineMonad a
pure = a -> ReadLineMonad a
forall a. a -> ReadLineMonad a
Value
  <*> :: ReadLineMonad (a -> b) -> ReadLineMonad a -> ReadLineMonad 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 :: m Text -> ReadLineMonad a -> m a
getLinesFromM m Text
_ (Value a
x) = a -> m a
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
  m Text -> ReadLineMonad a -> m a
forall (m :: * -> *) a. Monad m => m Text -> ReadLineMonad a -> m a
getLinesFromM m Text
fetch (ReadLineMonad a -> m a) -> ReadLineMonad a -> m a
forall a b. (a -> b) -> a -> b
$ Maybe Text -> ReadLineMonad a
f (Maybe Text -> ReadLineMonad a) -> Maybe Text -> ReadLineMonad a
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s

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

combArrayElements :: Value -> [Value] -> Either SyntaxError Value
combArrayElements :: Value -> [Value] -> Either SyntaxError Value
combArrayElements = (Value -> Value -> Either SyntaxError Value)
-> Value -> [Value] -> Either SyntaxError Value
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Value -> Value -> Either SyntaxError Value
comb
  where
    comb :: Value -> Value -> Either SyntaxError Value
comb Value
x Value
y
      | Value -> ValueType
valueType Value
x ValueType -> ValueType -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> ValueType
valueType Value
y = Value -> Either SyntaxError Value
forall a b. b -> Either a b
Right Value
x
      | Bool
otherwise =
          SyntaxError -> Either SyntaxError Value
forall a b. a -> Either a b
Left (SyntaxError -> Either SyntaxError Value)
-> (String -> SyntaxError) -> String -> Either SyntaxError Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Loc -> String -> SyntaxError
SyntaxError Loc
NoLoc (String -> Either SyntaxError Value)
-> String -> Either SyntaxError Value
forall a b. (a -> b) -> a -> b
$
            String
"Elements " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Pretty a => a -> String
pretty Value
x String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" and "
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Pretty a => a -> String
pretty Value
y
              String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" cannot exist in same array."

arrayFromList :: [a] -> Array Int a
arrayFromList :: [a] -> Array Int a
arrayFromList [a]
l = (Int, Int) -> [a] -> Array Int a
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l Int -> Int -> Int
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) =
  UncheckedExp -> ParserMonad UncheckedExp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UncheckedExp -> ParserMonad UncheckedExp)
-> UncheckedExp -> ParserMonad UncheckedExp
forall a b. (a -> b) -> a -> b
$ Name -> [UncheckedExp] -> NoInfo PatType -> SrcLoc -> UncheckedExp
forall (f :: * -> *) vn.
Name -> [ExpBase f vn] -> f PatType -> SrcLoc -> ExpBase f vn
Constr Name
n [UncheckedExp]
es NoInfo PatType
forall a. NoInfo a
NoInfo (SrcLoc -> UncheckedExp -> SrcLoc
forall a b. (Located a, Located b) => a -> b -> SrcLoc
srcspan SrcLoc
loc1 ([UncheckedExp] -> UncheckedExp
forall a. [a] -> a
last [UncheckedExp]
all_es))
applyExp [UncheckedExp]
es =
  (UncheckedExp -> UncheckedExp -> ParserMonad UncheckedExp)
-> UncheckedExp -> [UncheckedExp] -> ParserMonad UncheckedExp
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM UncheckedExp -> UncheckedExp -> ParserMonad UncheckedExp
forall vn.
(Eq vn, IsName vn) =>
ExpBase NoInfo vn
-> ExpBase NoInfo vn -> ParserMonad (ExpBase NoInfo vn)
op ([UncheckedExp] -> UncheckedExp
forall a. [a] -> a
head [UncheckedExp]
es) ([UncheckedExp] -> [UncheckedExp]
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) =
      SrcLoc -> Maybe String -> ParserMonad (ExpBase NoInfo vn)
forall loc a. Located loc => loc -> Maybe String -> ParserMonad a
parseErrorAt (SrcLoc -> SrcLoc -> SrcLoc
forall a b. (Located a, Located b) => a -> b -> SrcLoc
srcspan SrcLoc
floc SrcLoc
xloc) (Maybe String -> ParserMonad (ExpBase NoInfo vn))
-> (Doc -> Maybe String) -> Doc -> ParserMonad (ExpBase NoInfo vn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> (Doc -> String) -> Doc -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
forall a. Pretty a => a -> String
pretty (Doc -> ParserMonad (ExpBase NoInfo vn))
-> Doc -> ParserMonad (ExpBase NoInfo vn)
forall a b. (a -> b) -> a -> b
$
        Doc
"Incorrect syntax for multi-dimensional indexing."
          Doc -> Doc -> Doc
</> Doc
"Use" Doc -> Doc -> Doc
<+> Doc -> Doc
align (ExpBase NoInfo vn -> Doc
forall a. Pretty a => a -> Doc
ppr ExpBase NoInfo vn
index)
      where
        index :: ExpBase NoInfo vn
index = AppExpBase NoInfo vn -> NoInfo AppRes -> ExpBase NoInfo vn
forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp (ExpBase NoInfo vn
-> SliceBase NoInfo vn -> SrcLoc -> AppExpBase NoInfo vn
forall (f :: * -> *) vn.
ExpBase f vn -> SliceBase f vn -> SrcLoc -> AppExpBase f vn
Index ExpBase NoInfo vn
e (SliceBase NoInfo vn
is SliceBase NoInfo vn -> SliceBase NoInfo vn -> SliceBase NoInfo vn
forall a. [a] -> [a] -> [a]
++ (ExpBase NoInfo vn -> DimIndexBase NoInfo vn)
-> [ExpBase NoInfo vn] -> SliceBase NoInfo vn
forall a b. (a -> b) -> [a] -> [b]
map ExpBase NoInfo vn -> DimIndexBase NoInfo vn
forall (f :: * -> *) vn. ExpBase f vn -> DimIndexBase f vn
DimFix [ExpBase NoInfo vn]
xs) SrcLoc
xloc) NoInfo AppRes
forall a. NoInfo a
NoInfo
    op ExpBase NoInfo vn
f ExpBase NoInfo vn
x =
      ExpBase NoInfo vn -> ParserMonad (ExpBase NoInfo vn)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ExpBase NoInfo vn -> ParserMonad (ExpBase NoInfo vn))
-> ExpBase NoInfo vn -> ParserMonad (ExpBase NoInfo vn)
forall a b. (a -> b) -> a -> b
$ AppExpBase NoInfo vn -> NoInfo AppRes -> ExpBase NoInfo vn
forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp (ExpBase NoInfo vn
-> ExpBase NoInfo vn
-> NoInfo (Diet, Maybe VName)
-> SrcLoc
-> AppExpBase NoInfo vn
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 NoInfo (Diet, Maybe VName)
forall a. NoInfo a
NoInfo (ExpBase NoInfo vn -> ExpBase NoInfo vn -> SrcLoc
forall a b. (Located a, Located b) => a -> b -> SrcLoc
srcspan ExpBase NoInfo vn
f ExpBase NoInfo vn
x)) NoInfo AppRes
forall a. NoInfo a
NoInfo

patternExp :: UncheckedPat -> ParserMonad UncheckedExp
patternExp :: UncheckedPat -> ParserMonad UncheckedExp
patternExp (Id Name
v NoInfo PatType
_ SrcLoc
loc) = UncheckedExp -> ParserMonad UncheckedExp
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UncheckedExp -> ParserMonad UncheckedExp)
-> UncheckedExp -> ParserMonad UncheckedExp
forall a b. (a -> b) -> a -> b
$ QualName Name -> NoInfo PatType -> SrcLoc -> UncheckedExp
forall (f :: * -> *) vn.
QualName vn -> f PatType -> SrcLoc -> ExpBase f vn
Var (Name -> QualName Name
forall v. v -> QualName v
qualName Name
v) NoInfo PatType
forall a. NoInfo a
NoInfo SrcLoc
loc
patternExp (TuplePat [UncheckedPat]
pats SrcLoc
loc) = [UncheckedExp] -> SrcLoc -> UncheckedExp
forall (f :: * -> *) vn. [ExpBase f vn] -> SrcLoc -> ExpBase f vn
TupLit ([UncheckedExp] -> SrcLoc -> UncheckedExp)
-> ExceptT
     SyntaxError (StateT ParserState ReadLineMonad) [UncheckedExp]
-> ExceptT
     SyntaxError
     (StateT ParserState ReadLineMonad)
     (SrcLoc -> UncheckedExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (UncheckedPat -> ParserMonad UncheckedExp)
-> [UncheckedPat]
-> ExceptT
     SyntaxError (StateT ParserState ReadLineMonad) [UncheckedExp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM UncheckedPat -> ParserMonad UncheckedExp
patternExp [UncheckedPat]
pats ExceptT
  SyntaxError
  (StateT ParserState ReadLineMonad)
  (SrcLoc -> UncheckedExp)
-> ExceptT SyntaxError (StateT ParserState ReadLineMonad) SrcLoc
-> ParserMonad UncheckedExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SrcLoc
-> ExceptT SyntaxError (StateT ParserState ReadLineMonad) SrcLoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure SrcLoc
loc
patternExp (Wildcard NoInfo PatType
_ SrcLoc
loc) = SrcLoc -> Maybe String -> ParserMonad UncheckedExp
forall loc a. Located loc => loc -> Maybe String -> ParserMonad a
parseErrorAt SrcLoc
loc (Maybe String -> ParserMonad UncheckedExp)
-> Maybe String -> ParserMonad UncheckedExp
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
"cannot have wildcard here."
patternExp (PatLit PatLit
_ NoInfo PatType
_ SrcLoc
loc) = SrcLoc -> Maybe String -> ParserMonad UncheckedExp
forall loc a. Located loc => loc -> Maybe String -> ParserMonad a
parseErrorAt SrcLoc
loc (Maybe String -> ParserMonad UncheckedExp)
-> Maybe String -> ParserMonad UncheckedExp
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
"cannot have literal here."
patternExp (PatConstr Name
_ NoInfo PatType
_ [UncheckedPat]
_ SrcLoc
loc) = SrcLoc -> Maybe String -> ParserMonad UncheckedExp
forall loc a. Located loc => loc -> Maybe String -> ParserMonad a
parseErrorAt SrcLoc
loc (Maybe String -> ParserMonad UncheckedExp)
-> Maybe String -> ParserMonad UncheckedExp
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
"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) = [FieldBase NoInfo Name] -> SrcLoc -> UncheckedExp
forall (f :: * -> *) vn. [FieldBase f vn] -> SrcLoc -> ExpBase f vn
RecordLit ([FieldBase NoInfo Name] -> SrcLoc -> UncheckedExp)
-> ExceptT
     SyntaxError
     (StateT ParserState ReadLineMonad)
     [FieldBase NoInfo Name]
-> ExceptT
     SyntaxError
     (StateT ParserState ReadLineMonad)
     (SrcLoc -> UncheckedExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, UncheckedPat)
 -> ExceptT
      SyntaxError
      (StateT ParserState ReadLineMonad)
      (FieldBase NoInfo Name))
-> [(Name, UncheckedPat)]
-> ExceptT
     SyntaxError
     (StateT ParserState ReadLineMonad)
     [FieldBase NoInfo Name]
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 ExceptT
  SyntaxError
  (StateT ParserState ReadLineMonad)
  (SrcLoc -> UncheckedExp)
-> ExceptT SyntaxError (StateT ParserState ReadLineMonad) SrcLoc
-> ParserMonad UncheckedExp
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SrcLoc
-> ExceptT SyntaxError (StateT ParserState ReadLineMonad) SrcLoc
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) = Name -> UncheckedExp -> SrcLoc -> FieldBase NoInfo Name
forall (f :: * -> *) vn.
Name -> ExpBase f vn -> SrcLoc -> FieldBase f vn
RecordFieldExplicit Name
name (UncheckedExp -> SrcLoc -> FieldBase NoInfo Name)
-> ParserMonad UncheckedExp
-> ExceptT
     SyntaxError
     (StateT ParserState ReadLineMonad)
     (SrcLoc -> FieldBase NoInfo Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UncheckedPat -> ParserMonad UncheckedExp
patternExp UncheckedPat
pat ExceptT
  SyntaxError
  (StateT ParserState ReadLineMonad)
  (SrcLoc -> FieldBase NoInfo Name)
-> ExceptT SyntaxError (StateT ParserState ReadLineMonad) SrcLoc
-> ExceptT
     SyntaxError
     (StateT ParserState ReadLineMonad)
     (FieldBase NoInfo Name)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SrcLoc
-> ExceptT SyntaxError (StateT ParserState ReadLineMonad) SrcLoc
forall (f :: * -> *) a. Applicative f => a -> f a
pure SrcLoc
loc

eof :: Pos -> L Token
eof :: Pos -> L Token
eof Pos
pos = Loc -> Token -> L Token
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)) = ([Name] -> Name -> QualName Name
forall vn. [vn] -> vn -> QualName vn
QualName [Name]
qs Name
op, Loc
loc)
binOpName L Token
t = String -> (QualName Name, Loc)
forall a. HasCallStack => String -> a
error (String -> (QualName Name, Loc)) -> String -> (QualName Name, Loc)
forall a b. (a -> b) -> a -> b
$ String
"binOpName: unexpected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ L Token -> String
forall a. Show a => a -> String
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 =
  AppExpBase NoInfo Name -> NoInfo AppRes -> UncheckedExp
forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp ((QualName Name, SrcLoc)
-> NoInfo PatType
-> (UncheckedExp, NoInfo (StructType, Maybe VName))
-> (UncheckedExp, NoInfo (StructType, Maybe VName))
-> SrcLoc
-> AppExpBase NoInfo Name
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 ([Name] -> Name -> QualName Name
forall vn. [vn] -> vn -> QualName vn
QualName [Name]
qs Name
op, Loc -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf Loc
loc) NoInfo PatType
forall a. NoInfo a
NoInfo (UncheckedExp
x, NoInfo (StructType, Maybe VName)
forall a. NoInfo a
NoInfo) (UncheckedExp
y, NoInfo (StructType, Maybe VName)
forall a. NoInfo a
NoInfo) (UncheckedExp -> UncheckedExp -> SrcLoc
forall a b. (Located a, Located b) => a -> b -> SrcLoc
srcspan UncheckedExp
x UncheckedExp
y)) NoInfo AppRes
forall a. NoInfo a
NoInfo
binOp UncheckedExp
_ L Token
t UncheckedExp
_ = String -> UncheckedExp
forall a. HasCallStack => String -> a
error (String -> UncheckedExp) -> String -> UncheckedExp
forall a b. (a -> b) -> a -> b
$ String
"binOp: unexpected " String -> String -> String
forall a. [a] -> [a] -> [a]
++ L Token -> String
forall a. Show a => a -> String
show L Token
t

getTokens :: ParserMonad ([L Token], Pos)
getTokens :: ParserMonad ([L Token], Pos)
getTokens = StateT ParserState ReadLineMonad ([L Token], Pos)
-> ParserMonad ([L Token], Pos)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT ParserState ReadLineMonad ([L Token], Pos)
 -> ParserMonad ([L Token], Pos))
-> StateT ParserState ReadLineMonad ([L Token], Pos)
-> ParserMonad ([L Token], Pos)
forall a b. (a -> b) -> a -> b
$ (ParserState -> ([L Token], Pos))
-> StateT ParserState ReadLineMonad ([L Token], Pos)
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 = StateT ParserState ReadLineMonad () -> ParserMonad ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT ParserState ReadLineMonad () -> ParserMonad ())
-> StateT ParserState ReadLineMonad () -> ParserMonad ()
forall a b. (a -> b) -> a -> b
$ (ParserState -> ParserState) -> StateT ParserState ReadLineMonad ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((ParserState -> ParserState)
 -> StateT ParserState ReadLineMonad ())
-> (ParserState -> ParserState)
-> StateT ParserState ReadLineMonad ()
forall a b. (a -> b) -> a -> b
$ \ParserState
env -> ParserState
env {parserLexical :: ([L Token], Pos)
parserLexical = ([L Token], Pos)
l}

primTypeFromName :: Loc -> Name -> ParserMonad PrimType
primTypeFromName :: Loc -> Name -> ParserMonad PrimType
primTypeFromName Loc
loc Name
s = ParserMonad PrimType
-> (PrimType -> ParserMonad PrimType)
-> Maybe PrimType
-> ParserMonad PrimType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ParserMonad PrimType
forall a. ParserMonad a
boom PrimType -> ParserMonad PrimType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PrimType -> ParserMonad PrimType)
-> Maybe PrimType -> ParserMonad PrimType
forall a b. (a -> b) -> a -> b
$ Name -> Map Name PrimType -> Maybe PrimType
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
s Map Name PrimType
namesToPrimTypes
  where
    boom :: ParserMonad a
boom = Loc -> Maybe String -> ParserMonad a
forall loc a. Located loc => loc -> Maybe String -> ParserMonad a
parseErrorAt Loc
loc (Maybe String -> ParserMonad a) -> Maybe String -> ParserMonad a
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"No type named " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameToString Name
s

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 (FloatValue -> PrimValue) -> FloatValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ FloatValue -> FloatValue
floatNegate FloatValue
v
primNegate (SignedValue IntValue
v) = IntValue -> PrimValue
SignedValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ IntValue -> IntValue
intNegate IntValue
v
primNegate (UnsignedValue IntValue
v) = IntValue -> PrimValue
UnsignedValue (IntValue -> PrimValue) -> IntValue -> PrimValue
forall a b. (a -> b) -> a -> b
$ IntValue -> IntValue
intNegate IntValue
v
primNegate (BoolValue Bool
v) = Bool -> PrimValue
BoolValue (Bool -> PrimValue) -> Bool -> PrimValue
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 <- StateT ParserState ReadLineMonad (Maybe Text)
-> ParserMonad (Maybe Text)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT ParserState ReadLineMonad (Maybe Text)
 -> ParserMonad (Maybe Text))
-> StateT ParserState ReadLineMonad (Maybe Text)
-> ParserMonad (Maybe Text)
forall a b. (a -> b) -> a -> b
$ ReadLineMonad (Maybe Text)
-> StateT ParserState ReadLineMonad (Maybe Text)
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' ->
      StateT ParserState ReadLineMonad () -> ParserMonad ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT ParserState ReadLineMonad () -> ParserMonad ())
-> StateT ParserState ReadLineMonad () -> ParserMonad ()
forall a b. (a -> b) -> a -> b
$ (ParserState -> ParserState) -> StateT ParserState ReadLineMonad ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((ParserState -> ParserState)
 -> StateT ParserState ReadLineMonad ())
-> (ParserState -> ParserState)
-> StateT ParserState ReadLineMonad ()
forall a b. (a -> b) -> a -> b
$ \ParserState
env -> ParserState
env {parserInput :: Text
parserInput = ParserState -> Text
parserInput ParserState
env Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s'}
    Maybe Text
Nothing -> () -> ParserMonad ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Maybe Text -> ParserMonad (Maybe Text)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Text
s

lexer :: (L Token -> ParserMonad a) -> ParserMonad a
lexer :: (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 <- StateT ParserState ReadLineMonad (Either SyntaxError a)
-> ExceptT
     SyntaxError
     (StateT ParserState ReadLineMonad)
     (Either SyntaxError a)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT ParserState ReadLineMonad (Either SyntaxError a)
 -> ExceptT
      SyntaxError
      (StateT ParserState ReadLineMonad)
      (Either SyntaxError a))
-> StateT ParserState ReadLineMonad (Either SyntaxError a)
-> ExceptT
     SyntaxError
     (StateT ParserState ReadLineMonad)
     (Either SyntaxError a)
forall a b. (a -> b) -> a -> b
$ ParserMonad a
-> StateT ParserState ReadLineMonad (Either SyntaxError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ParserMonad a
 -> StateT ParserState ReadLineMonad (Either SyntaxError a))
-> ParserMonad a
-> StateT ParserState ReadLineMonad (Either SyntaxError a)
forall a b. (a -> b) -> a -> b
$ L Token -> ParserMonad a
cont (L Token -> ParserMonad a) -> L Token -> ParserMonad a
forall a b. (a -> b) -> a -> b
$ Pos -> L Token
eof Pos
pos
      case Either SyntaxError a
ended of
        Right a
x -> a -> ParserMonad a
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 -> SyntaxError
-> ExceptT
     SyntaxError
     (StateT ParserState ReadLineMonad)
     (Either LexerError ([L Token], Pos))
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError SyntaxError
parse_e
              Just Text
line' -> Either LexerError ([L Token], Pos)
-> ExceptT
     SyntaxError
     (StateT ParserState ReadLineMonad)
     (Either LexerError ([L Token], Pos))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LexerError ([L Token], Pos)
 -> ExceptT
      SyntaxError
      (StateT ParserState ReadLineMonad)
      (Either LexerError ([L Token], Pos)))
-> Either LexerError ([L Token], Pos)
-> ExceptT
     SyntaxError
     (StateT ParserState ReadLineMonad)
     (Either LexerError ([L Token], Pos))
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') <- (LexerError -> ParserMonad ([L Token], Pos))
-> (([L Token], Pos) -> ParserMonad ([L Token], Pos))
-> Either LexerError ([L Token], Pos)
-> ParserMonad ([L Token], Pos)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (SyntaxError -> ParserMonad ([L Token], Pos)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SyntaxError -> ParserMonad ([L Token], Pos))
-> (LexerError -> SyntaxError)
-> LexerError
-> ParserMonad ([L Token], Pos)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LexerError -> SyntaxError
lexerErrToParseErr) ([L Token], Pos) -> ParserMonad ([L Token], Pos)
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 (L Token -> ParserMonad a) -> L Token -> ParserMonad a
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')
              (L Token -> ParserMonad a) -> ParserMonad a
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 :: (L Token, [String]) -> ParserMonad a
parseError (L Loc
loc Token
EOF, [String]
expected) =
  Loc -> Maybe String -> ParserMonad a
forall loc a. Located loc => loc -> Maybe String -> ParserMonad a
parseErrorAt (Loc -> Loc
forall a. Located a => a -> Loc
locOf Loc
loc) (Maybe String -> ParserMonad a)
-> ([String] -> Maybe String) -> [String] -> ParserMonad a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> ([String] -> String) -> [String] -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> ParserMonad a) -> [String] -> ParserMonad a
forall a b. (a -> b) -> a -> b
$
    [ String
"Unexpected end of file.",
      String
"Expected one of the following: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
expected
    ]
parseError (L Loc
loc DOC {}, [String]
_) =
  Loc -> Maybe String -> ParserMonad a
forall loc a. Located loc => loc -> Maybe String -> ParserMonad a
parseErrorAt (Loc -> Loc
forall a. Located a => a -> Loc
locOf Loc
loc) (Maybe String -> ParserMonad a) -> Maybe String -> ParserMonad a
forall a b. (a -> b) -> a -> b
$
    String -> Maybe String
forall a. a -> Maybe a
Just String
"Documentation comments ('-- |') are only permitted when preceding declarations."
parseError (L Loc
loc Token
_, [String]
expected) = do
  Text
input <- StateT ParserState ReadLineMonad Text
-> ExceptT SyntaxError (StateT ParserState ReadLineMonad) Text
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT ParserState ReadLineMonad Text
 -> ExceptT SyntaxError (StateT ParserState ReadLineMonad) Text)
-> StateT ParserState ReadLineMonad Text
-> ExceptT SyntaxError (StateT ParserState ReadLineMonad) Text
forall a b. (a -> b) -> a -> b
$ (ParserState -> Text) -> StateT ParserState ReadLineMonad Text
forall (m :: * -> *) s a. Monad m => (s -> a) -> StateT s m a
gets ParserState -> Text
parserInput
  let ~(Loc (Pos String
_ Int
_ Int
_ Int
beg) (Pos String
_ Int
_ Int
_ Int
end)) = Loc -> Loc
forall a. Located a => a -> Loc
locOf Loc
loc
      tok_src :: Text
tok_src = Int -> Text -> Text
T.take (Int
end Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
beg Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
beg Text
input
  Loc -> Maybe String -> ParserMonad a
forall loc a. Located loc => loc -> Maybe String -> ParserMonad a
parseErrorAt Loc
loc (Maybe String -> ParserMonad a)
-> ([String] -> Maybe String) -> [String] -> ParserMonad a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String)
-> ([String] -> String) -> [String] -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> ParserMonad a) -> [String] -> ParserMonad a
forall a b. (a -> b) -> a -> b
$
    [ String
"Unexpected token: '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
tok_src String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"'",
      String
"Expected one of the following: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
unwords [String]
expected
    ]

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

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

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

-- | Move the end position back one column.
backOneCol :: Loc -> Loc
backOneCol :: Loc -> Loc
backOneCol (Loc Pos
start (Pos String
f Int
l Int
c Int
o)) = Pos -> Pos -> Loc
Loc Pos
start (Pos -> Loc) -> Pos -> Loc
forall a b. (a -> b) -> a -> b
$ String -> Int -> Int -> Int -> Pos
Pos String
f Int
l (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int
o Int -> Int -> Int
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 -> String
syntaxErrorMsg :: String}

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

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

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