-- | 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,
    Comment (..),
    parse,
    parseWithComments,
    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.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.ByteString.Lazy qualified as BS
import Data.List.NonEmpty qualified as NE
import Data.Monoid
import Data.Text qualified as T
import Data.Text.Encoding 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 (AlexInput, LexerError (..), initialLexerState)
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 (ModTypeDec ModTypeBindBase NoInfo Name
sig) = forall (f :: * -> *) vn. ModTypeBindBase f vn -> DecBase f vn
ModTypeDec (ModTypeBindBase NoInfo Name
sig {modTypeDoc :: Maybe DocComment
modTypeDoc = 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 ModTypeExpBase NoInfo Name
se Maybe DocComment
_ SrcLoc
loc) = forall (f :: * -> *) vn.
vn
-> ModTypeExpBase f vn
-> Maybe DocComment
-> SrcLoc
-> SpecBase f vn
ModSpec Name
name ModTypeExpBase 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 NoUniqueness
_ (Shape [Int64]
dims) ScalarTypeBase Int64 NoUniqueness
_)
  | 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."

-- | A comment consists of its starting and end position, as well as
-- its text.  The contents include the comment start marker.
data Comment = Comment {Comment -> Loc
commentLoc :: Loc, Comment -> Text
commentText :: T.Text}
  deriving (Comment -> Comment -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Comment -> Comment -> Bool
$c/= :: Comment -> Comment -> Bool
== :: Comment -> Comment -> Bool
$c== :: Comment -> Comment -> Bool
Eq, Eq Comment
Comment -> Comment -> Bool
Comment -> Comment -> Ordering
Comment -> Comment -> Comment
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Comment -> Comment -> Comment
$cmin :: Comment -> Comment -> Comment
max :: Comment -> Comment -> Comment
$cmax :: Comment -> Comment -> Comment
>= :: Comment -> Comment -> Bool
$c>= :: Comment -> Comment -> Bool
> :: Comment -> Comment -> Bool
$c> :: Comment -> Comment -> Bool
<= :: Comment -> Comment -> Bool
$c<= :: Comment -> Comment -> Bool
< :: Comment -> Comment -> Bool
$c< :: Comment -> Comment -> Bool
compare :: Comment -> Comment -> Ordering
$ccompare :: Comment -> Comment -> Ordering
Ord, Int -> Comment -> ShowS
[Comment] -> ShowS
Comment -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Comment] -> ShowS
$cshowList :: [Comment] -> ShowS
show :: Comment -> [Char]
$cshow :: Comment -> [Char]
showsPrec :: Int -> Comment -> ShowS
$cshowsPrec :: Int -> Comment -> ShowS
Show)

instance Located Comment where
  locOf :: Comment -> Loc
locOf = Comment -> Loc
commentLoc

data ParserState = ParserState
  { ParserState -> [Char]
_parserFile :: FilePath,
    ParserState -> Text
parserInput :: T.Text,
    -- | Note: reverse order.
    ParserState -> [Comment]
parserComments :: [Comment],
    ParserState -> AlexInput
parserLexerState :: AlexInput
  }

type ParserMonad = ExceptT SyntaxError (State ParserState)

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 StructType
_ 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 StructType -> 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 StructType
_ 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 t -> ParserMonad UncheckedExp
patternExp :: forall t. UncheckedPat t -> ParserMonad UncheckedExp
patternExp (Id Name
v NoInfo t
_ SrcLoc
loc) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) vn.
QualName vn -> f StructType -> SrcLoc -> ExpBase f vn
Var (forall v. v -> QualName v
qualName Name
v) forall {k} (a :: k). NoInfo a
NoInfo SrcLoc
loc
patternExp (TuplePat [PatBase NoInfo Name t]
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 forall t. UncheckedPat t -> ParserMonad UncheckedExp
patternExp [PatBase NoInfo Name t]
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 t
_ 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 t
_ 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 t
_ [PatBase NoInfo Name t]
_ 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
_ PatBase NoInfo Name t
p SrcLoc
_) = forall t. UncheckedPat t -> ParserMonad UncheckedExp
patternExp PatBase NoInfo Name t
p
patternExp (PatAscription PatBase NoInfo Name t
pat TypeExp NoInfo Name
_ SrcLoc
_) = forall t. UncheckedPat t -> ParserMonad UncheckedExp
patternExp PatBase NoInfo Name t
pat
patternExp (PatParens PatBase NoInfo Name t
pat SrcLoc
_) = forall t. UncheckedPat t -> ParserMonad UncheckedExp
patternExp PatBase NoInfo Name t
pat
patternExp (RecordPat [(Name, PatBase NoInfo Name t)]
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 forall {t}.
(Name, UncheckedPat t)
-> ExceptT SyntaxError (State ParserState) (FieldBase NoInfo Name)
field [(Name, PatBase NoInfo Name t)]
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 t)
-> ExceptT SyntaxError (State ParserState) (FieldBase NoInfo Name)
field (Name
name, UncheckedPat t
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
<$> forall t. UncheckedPat t -> ParserMonad UncheckedExp
patternExp UncheckedPat t
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

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 StructType
-> (ExpBase f vn, f (Maybe VName))
-> (ExpBase f vn, f (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

putComment :: Comment -> ParserMonad ()
putComment :: Comment -> ParserMonad ()
putComment Comment
c = 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 {parserComments :: [Comment]
parserComments = Comment
c forall a. a -> [a] -> [a]
: ParserState -> [Comment]
parserComments ParserState
env}

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

lexer :: (L Token -> ParserMonad a) -> ParserMonad a
lexer :: forall a. (L Token -> ParserMonad a) -> ParserMonad a
lexer L Token -> ParserMonad a
cont = do
  AlexInput
ls <- 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 -> AlexInput
parserLexerState
  case AlexInput -> Either LexerError (AlexInput, (Pos, Pos, Token))
getToken AlexInput
ls of
    Left LexerError
e ->
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ LexerError -> SyntaxError
lexerErrToParseErr LexerError
e
    Right (AlexInput
ls', (Pos
start, Pos
end, Token
tok)) -> do
      let loc :: Loc
loc = Pos -> Pos -> Loc
Loc Pos
start Pos
end
      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
s -> ParserState
s {parserLexerState :: AlexInput
parserLexerState = AlexInput
ls'}
      case Token
tok of
        COMMENT Text
text -> do
          Comment -> ParserMonad ()
putComment forall a b. (a -> b) -> a -> b
$ Loc -> Text -> Comment
Comment Loc
loc Text
text
          forall a. (L Token -> ParserMonad a) -> ParserMonad a
lexer L Token -> ParserMonad a
cont
        Token
_ ->
          L Token -> ParserMonad a
cont forall a b. (a -> b) -> a -> b
$ forall a. Loc -> a -> L a
L Loc
loc Token
tok

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 (ERROR Text
"\""), [[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
"Unclosed string literal."
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 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

parseWithComments ::
  ParserMonad a ->
  FilePath ->
  T.Text ->
  Either SyntaxError (a, [Comment])
parseWithComments :: forall a.
ParserMonad a
-> [Char] -> Text -> Either SyntaxError (a, [Comment])
parseWithComments ParserMonad a
p [Char]
file Text
program =
  forall {a} {a}.
(Either a a, ParserState) -> Either a (a, [Comment])
onRes forall a b. (a -> b) -> a -> b
$ forall s a. State s a -> s -> (a, s)
runState (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ParserMonad a
p) ParserState
env
  where
    env :: ParserState
env =
      [Char] -> Text -> [Comment] -> AlexInput -> ParserState
ParserState
        [Char]
file
        Text
program
        []
        (Pos -> ByteString -> AlexInput
initialLexerState Pos
start forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.fromStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 forall a b. (a -> b) -> a -> b
$ Text
program)
    start :: Pos
start = [Char] -> Int -> Int -> Int -> Pos
Pos [Char]
file Int
1 Int
1 Int
0
    onRes :: (Either a a, ParserState) -> Either a (a, [Comment])
onRes (Left a
err, ParserState
_) = forall a b. a -> Either a b
Left a
err
    onRes (Right a
x, ParserState
s) = forall a b. b -> Either a b
Right (a
x, forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ ParserState -> [Comment]
parserComments ParserState
s)

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 a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a.
ParserMonad a
-> [Char] -> Text -> Either SyntaxError (a, [Comment])
parseWithComments ParserMonad a
p [Char]
file Text
program