-- | 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) = 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 NoInfo Name
t NoInfo StructType
NoInfo Maybe DocComment
_ SrcLoc
loc) = Name
-> [TypeParamBase Name]
-> TypeExp NoInfo Name
-> NoInfo StructType
-> Maybe DocComment
-> SrcLoc
-> SpecBase NoInfo Name
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 NoInfo StructType
forall {k} (a :: k). 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 -> T.Text -> ParserMonad ()
mustBe :: L Token -> Text -> ParserMonad ()
mustBe (L Loc
_ (ID Name
got)) Text
expected
  | Name -> Text
nameToText Name
got Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
expected = () -> ParserMonad ()
forall a. a -> ExceptT SyntaxError (State ParserState) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
mustBe (L Loc
loc Token
_) Text
expected =
  Loc -> Maybe Text -> ParserMonad ()
forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt Loc
loc (Maybe Text -> ParserMonad ())
-> (Text -> Maybe Text) -> Text -> ParserMonad ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> ParserMonad ()) -> Text -> ParserMonad ()
forall a b. (a -> b) -> a -> b
$
    Text
"Only the keyword '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
expected Text -> Text -> Text
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 Int64 -> [Int64] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int64]
dims = () -> ParserMonad ()
forall a. a -> ExceptT SyntaxError (State ParserState) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
mustBeEmpty loc
loc ValueType
t =
  loc -> Maybe Text -> ParserMonad ()
forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt loc
loc (Maybe Text -> ParserMonad ()) -> Maybe Text -> ParserMonad ()
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ ValueType -> Text
forall a. Pretty a => a -> Text
prettyText ValueType
t Text -> Text -> Text
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
(Comment -> Comment -> Bool)
-> (Comment -> Comment -> Bool) -> Eq Comment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Comment -> Comment -> Bool
== :: Comment -> Comment -> Bool
$c/= :: Comment -> Comment -> Bool
/= :: Comment -> Comment -> Bool
Eq, Eq Comment
Eq Comment
-> (Comment -> Comment -> Ordering)
-> (Comment -> Comment -> Bool)
-> (Comment -> Comment -> Bool)
-> (Comment -> Comment -> Bool)
-> (Comment -> Comment -> Bool)
-> (Comment -> Comment -> Comment)
-> (Comment -> Comment -> Comment)
-> Ord 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
$ccompare :: Comment -> Comment -> Ordering
compare :: Comment -> Comment -> Ordering
$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
>= :: Comment -> Comment -> Bool
$cmax :: Comment -> Comment -> Comment
max :: Comment -> Comment -> Comment
$cmin :: Comment -> Comment -> Comment
min :: Comment -> Comment -> Comment
Ord, Int -> Comment -> ShowS
[Comment] -> ShowS
Comment -> [Char]
(Int -> Comment -> ShowS)
-> (Comment -> [Char]) -> ([Comment] -> ShowS) -> Show Comment
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Comment -> ShowS
showsPrec :: Int -> Comment -> ShowS
$cshow :: Comment -> [Char]
show :: Comment -> [Char]
$cshowList :: [Comment] -> ShowS
showList :: [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 = (Int, Int) -> [a] -> Array Int a
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int
0, [a] -> Int
forall a. [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 :: 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) =
  UncheckedExp -> ParserMonad UncheckedExp
forall a. a -> ExceptT SyntaxError (State ParserState) a
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 StructType -> SrcLoc -> UncheckedExp
forall (f :: * -> *) vn.
Name -> [ExpBase f vn] -> f StructType -> SrcLoc -> ExpBase f vn
Constr Name
n [UncheckedExp]
es NoInfo StructType
forall {k} (a :: k). NoInfo a
NoInfo (SrcLoc -> UncheckedExp -> SrcLoc
forall a b. (Located a, Located b) => a -> b -> SrcLoc
srcspan SrcLoc
loc1 (NonEmpty UncheckedExp -> UncheckedExp
forall a. NonEmpty a -> a
NE.last NonEmpty UncheckedExp
all_es))
applyExp NonEmpty 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 (NonEmpty UncheckedExp -> UncheckedExp
forall a. NonEmpty a -> a
NE.head NonEmpty UncheckedExp
es) (NonEmpty UncheckedExp -> [UncheckedExp]
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) =
      SrcLoc -> Maybe Text -> ParserMonad (ExpBase NoInfo vn)
forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt (SrcLoc -> SrcLoc -> SrcLoc
forall a b. (Located a, Located b) => a -> b -> SrcLoc
srcspan SrcLoc
floc SrcLoc
xloc) (Maybe Text -> ParserMonad (ExpBase NoInfo vn))
-> (Doc Any -> Maybe Text)
-> Doc Any
-> ParserMonad (ExpBase NoInfo vn)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> (Doc Any -> Text) -> Doc Any -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Any -> Text
forall a. Doc a -> Text
docText (Doc Any -> ParserMonad (ExpBase NoInfo vn))
-> Doc Any -> ParserMonad (ExpBase NoInfo vn)
forall a b. (a -> b) -> a -> b
$
        Doc Any
"Incorrect syntax for multi-dimensional indexing."
          Doc Any -> Doc Any -> Doc Any
forall a. Doc a -> Doc a -> Doc a
</> Doc Any
"Use"
          Doc Any -> Doc Any -> Doc Any
forall a. Doc a -> Doc a -> Doc a
<+> Doc Any -> Doc Any
forall ann. Doc ann -> Doc ann
align (ExpBase NoInfo vn -> Doc Any
forall a ann. Pretty a => a -> Doc ann
forall ann. ExpBase NoInfo vn -> Doc ann
pretty 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 {k} (a :: k). NoInfo a
NoInfo
    op ExpBase NoInfo vn
f ExpBase NoInfo vn
x = ExpBase NoInfo vn -> ParserMonad (ExpBase NoInfo vn)
forall a. a -> ExceptT SyntaxError (State ParserState) a
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
$ ExpBase NoInfo vn -> ExpBase NoInfo vn -> ExpBase NoInfo vn
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) = UncheckedExp -> ParserMonad UncheckedExp
forall a. a -> ExceptT SyntaxError (State ParserState) a
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 StructType -> SrcLoc -> UncheckedExp
forall (f :: * -> *) vn.
QualName vn -> f StructType -> SrcLoc -> ExpBase f vn
Var (Name -> QualName Name
forall v. v -> QualName v
qualName Name
v) NoInfo StructType
forall {k} (a :: k). NoInfo a
NoInfo SrcLoc
loc
patternExp (TuplePat [PatBase NoInfo Name t]
pats SrcLoc
loc) = [UncheckedExp] -> SrcLoc -> UncheckedExp
forall (f :: * -> *) vn. [ExpBase f vn] -> SrcLoc -> ExpBase f vn
TupLit ([UncheckedExp] -> SrcLoc -> UncheckedExp)
-> ExceptT SyntaxError (State ParserState) [UncheckedExp]
-> ExceptT SyntaxError (State ParserState) (SrcLoc -> UncheckedExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PatBase NoInfo Name t -> ParserMonad UncheckedExp)
-> [PatBase NoInfo Name t]
-> ExceptT SyntaxError (State ParserState) [UncheckedExp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PatBase NoInfo Name t -> ParserMonad UncheckedExp
forall t. UncheckedPat t -> ParserMonad UncheckedExp
patternExp [PatBase NoInfo Name t]
pats ExceptT SyntaxError (State ParserState) (SrcLoc -> UncheckedExp)
-> ExceptT SyntaxError (State ParserState) SrcLoc
-> ParserMonad UncheckedExp
forall a b.
ExceptT SyntaxError (State ParserState) (a -> b)
-> ExceptT SyntaxError (State ParserState) a
-> ExceptT SyntaxError (State ParserState) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SrcLoc -> ExceptT SyntaxError (State ParserState) SrcLoc
forall a. a -> ExceptT SyntaxError (State ParserState) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SrcLoc
loc
patternExp (Wildcard NoInfo t
_ SrcLoc
loc) = SrcLoc -> Maybe Text -> ParserMonad UncheckedExp
forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt SrcLoc
loc (Maybe Text -> ParserMonad UncheckedExp)
-> Maybe Text -> ParserMonad UncheckedExp
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"cannot have wildcard here."
patternExp (PatLit PatLit
_ NoInfo t
_ SrcLoc
loc) = SrcLoc -> Maybe Text -> ParserMonad UncheckedExp
forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt SrcLoc
loc (Maybe Text -> ParserMonad UncheckedExp)
-> Maybe Text -> ParserMonad UncheckedExp
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"cannot have literal here."
patternExp (PatConstr Name
_ NoInfo t
_ [PatBase NoInfo Name t]
_ SrcLoc
loc) = SrcLoc -> Maybe Text -> ParserMonad UncheckedExp
forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt SrcLoc
loc (Maybe Text -> ParserMonad UncheckedExp)
-> Maybe Text -> ParserMonad UncheckedExp
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"cannot have constructor here."
patternExp (PatAttr AttrInfo Name
_ PatBase NoInfo Name t
p SrcLoc
_) = PatBase NoInfo Name t -> ParserMonad UncheckedExp
forall t. UncheckedPat t -> ParserMonad UncheckedExp
patternExp PatBase NoInfo Name t
p
patternExp (PatAscription PatBase NoInfo Name t
pat TypeExp NoInfo Name
_ SrcLoc
_) = PatBase NoInfo Name t -> ParserMonad UncheckedExp
forall t. UncheckedPat t -> ParserMonad UncheckedExp
patternExp PatBase NoInfo Name t
pat
patternExp (PatParens PatBase NoInfo Name t
pat SrcLoc
_) = PatBase NoInfo Name t -> ParserMonad UncheckedExp
forall t. UncheckedPat t -> ParserMonad UncheckedExp
patternExp PatBase NoInfo Name t
pat
patternExp (RecordPat [(Name, PatBase NoInfo Name t)]
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 (State ParserState) [FieldBase NoInfo Name]
-> ExceptT SyntaxError (State ParserState) (SrcLoc -> UncheckedExp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, PatBase NoInfo Name t)
 -> ExceptT SyntaxError (State ParserState) (FieldBase NoInfo Name))
-> [(Name, PatBase NoInfo Name t)]
-> ExceptT SyntaxError (State ParserState) [FieldBase NoInfo Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name, PatBase NoInfo Name t)
-> ExceptT SyntaxError (State ParserState) (FieldBase NoInfo Name)
forall {t}.
(Name, UncheckedPat t)
-> ExceptT SyntaxError (State ParserState) (FieldBase NoInfo Name)
field [(Name, PatBase NoInfo Name t)]
fs ExceptT SyntaxError (State ParserState) (SrcLoc -> UncheckedExp)
-> ExceptT SyntaxError (State ParserState) SrcLoc
-> ParserMonad UncheckedExp
forall a b.
ExceptT SyntaxError (State ParserState) (a -> b)
-> ExceptT SyntaxError (State ParserState) a
-> ExceptT SyntaxError (State ParserState) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SrcLoc -> ExceptT SyntaxError (State ParserState) SrcLoc
forall a. a -> ExceptT SyntaxError (State ParserState) a
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) = 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 (State ParserState) (SrcLoc -> FieldBase NoInfo Name)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> UncheckedPat t -> ParserMonad UncheckedExp
forall t. UncheckedPat t -> ParserMonad UncheckedExp
patternExp UncheckedPat t
pat ExceptT
  SyntaxError (State ParserState) (SrcLoc -> FieldBase NoInfo Name)
-> ExceptT SyntaxError (State ParserState) SrcLoc
-> ExceptT SyntaxError (State ParserState) (FieldBase NoInfo Name)
forall a b.
ExceptT SyntaxError (State ParserState) (a -> b)
-> ExceptT SyntaxError (State ParserState) a
-> ExceptT SyntaxError (State ParserState) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> SrcLoc -> ExceptT SyntaxError (State ParserState) SrcLoc
forall a. a -> ExceptT SyntaxError (State ParserState) a
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)) = ([Name] -> Name -> QualName Name
forall vn. [vn] -> vn -> QualName vn
QualName [Name]
qs Name
op, Loc
loc)
binOpName L Token
t = [Char] -> (QualName Name, Loc)
forall a. HasCallStack => [Char] -> a
error ([Char] -> (QualName Name, Loc)) -> [Char] -> (QualName Name, Loc)
forall a b. (a -> b) -> a -> b
$ [Char]
"binOpName: unexpected " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ L Token -> [Char]
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 =
  AppExpBase NoInfo Name -> NoInfo AppRes -> UncheckedExp
forall (f :: * -> *) vn.
AppExpBase f vn -> f AppRes -> ExpBase f vn
AppExp ((QualName Name, SrcLoc)
-> NoInfo StructType
-> (UncheckedExp, NoInfo (Maybe VName))
-> (UncheckedExp, NoInfo (Maybe VName))
-> SrcLoc
-> AppExpBase NoInfo Name
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 ([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 StructType
forall {k} (a :: k). NoInfo a
NoInfo (UncheckedExp
x, NoInfo (Maybe VName)
forall {k} (a :: k). NoInfo a
NoInfo) (UncheckedExp
y, NoInfo (Maybe VName)
forall {k} (a :: k). NoInfo a
NoInfo) (UncheckedExp -> UncheckedExp -> SrcLoc
forall a b. (Located a, Located b) => a -> b -> SrcLoc
srcspan UncheckedExp
x UncheckedExp
y)) NoInfo AppRes
forall {k} (a :: k). NoInfo a
NoInfo
binOp UncheckedExp
_ L Token
t UncheckedExp
_ = [Char] -> UncheckedExp
forall a. HasCallStack => [Char] -> a
error ([Char] -> UncheckedExp) -> [Char] -> UncheckedExp
forall a b. (a -> b) -> a -> b
$ [Char]
"binOp: unexpected " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ L Token -> [Char]
forall a. Show a => a -> [Char]
show L Token
t

putComment :: Comment -> ParserMonad ()
putComment :: Comment -> ParserMonad ()
putComment Comment
c = State ParserState () -> ParserMonad ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT SyntaxError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State ParserState () -> ParserMonad ())
-> State ParserState () -> ParserMonad ()
forall a b. (a -> b) -> a -> b
$ (ParserState -> ParserState) -> State ParserState ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((ParserState -> ParserState) -> State ParserState ())
-> (ParserState -> ParserState) -> State ParserState ()
forall a b. (a -> b) -> a -> b
$ \ParserState
env ->
  ParserState
env {parserComments :: [Comment]
parserComments = Comment
c Comment -> [Comment] -> [Comment]
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 (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

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 <- State ParserState AlexInput
-> ExceptT SyntaxError (State ParserState) AlexInput
forall (m :: * -> *) a. Monad m => m a -> ExceptT SyntaxError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State ParserState AlexInput
 -> ExceptT SyntaxError (State ParserState) AlexInput)
-> State ParserState AlexInput
-> ExceptT SyntaxError (State ParserState) AlexInput
forall a b. (a -> b) -> a -> b
$ (ParserState -> AlexInput) -> State ParserState AlexInput
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 ->
      SyntaxError -> ParserMonad a
forall a. SyntaxError -> ExceptT SyntaxError (State ParserState) 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
$ 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
      State ParserState () -> ParserMonad ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT SyntaxError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State ParserState () -> ParserMonad ())
-> State ParserState () -> ParserMonad ()
forall a b. (a -> b) -> a -> b
$ (ParserState -> ParserState) -> State ParserState ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify ((ParserState -> ParserState) -> State ParserState ())
-> (ParserState -> ParserState) -> State ParserState ()
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 (Comment -> ParserMonad ()) -> Comment -> ParserMonad ()
forall a b. (a -> b) -> a -> b
$ Loc -> Text -> Comment
Comment Loc
loc Text
text
          (L Token -> ParserMonad a) -> ParserMonad a
forall a. (L Token -> ParserMonad a) -> ParserMonad a
lexer L Token -> ParserMonad a
cont
        Token
_ ->
          L Token -> ParserMonad a
cont (L Token -> ParserMonad a) -> L Token -> ParserMonad a
forall a b. (a -> b) -> a -> b
$ Loc -> Token -> L Token
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) =
  Loc -> Maybe Text -> ParserMonad a
forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt (Loc -> Loc
forall a. Located a => a -> Loc
locOf Loc
loc) (Maybe Text -> ParserMonad a)
-> ([Text] -> Maybe Text) -> [Text] -> ParserMonad a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> ([Text] -> Text) -> [Text] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> ParserMonad a) -> [Text] -> ParserMonad a
forall a b. (a -> b) -> a -> b
$
    [ Text
"Unexpected end of file.",
      Text
"Expected one of the following: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords (([Char] -> Text) -> [[Char]] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Text
T.pack [[Char]]
expected)
    ]
parseError (L Loc
loc DOC {}, [[Char]]
_) =
  Loc -> Maybe Text -> ParserMonad a
forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt (Loc -> Loc
forall a. Located a => a -> Loc
locOf Loc
loc) (Maybe Text -> ParserMonad a) -> Maybe Text -> ParserMonad a
forall a b. (a -> b) -> a -> b
$
    Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Documentation comments ('-- |') are only permitted when preceding declarations."
parseError (L Loc
loc (ERROR Text
"\""), [[Char]]
_) =
  Loc -> Maybe Text -> ParserMonad a
forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt (Loc -> Loc
forall a. Located a => a -> Loc
locOf Loc
loc) (Maybe Text -> ParserMonad a) -> Maybe Text -> ParserMonad a
forall a b. (a -> b) -> a -> b
$
    Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Unclosed string literal."
parseError (L Loc
loc Token
_, [[Char]]
expected) = do
  Text
input <- State ParserState Text
-> ExceptT SyntaxError (State ParserState) Text
forall (m :: * -> *) a. Monad m => m a -> ExceptT SyntaxError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (State ParserState Text
 -> ExceptT SyntaxError (State ParserState) Text)
-> State ParserState Text
-> ExceptT SyntaxError (State ParserState) Text
forall a b. (a -> b) -> a -> b
$ (ParserState -> Text) -> State ParserState Text
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)) = 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) (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.drop Int
beg Text
input
  Loc -> Maybe Text -> ParserMonad a
forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt Loc
loc (Maybe Text -> ParserMonad a)
-> ([Text] -> Maybe Text) -> [Text] -> ParserMonad a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> ([Text] -> Text) -> [Text] -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> ParserMonad a) -> [Text] -> ParserMonad a
forall a b. (a -> b) -> a -> b
$
    [ Text
"Unexpected token: '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
tok_src Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'",
      Text
"Expected one of the following: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
T.unwords (([Char] -> Text) -> [[Char]] -> [Text]
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 = SyntaxError -> ExceptT SyntaxError (State ParserState) a
forall a. SyntaxError -> ExceptT SyntaxError (State ParserState) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SyntaxError -> ExceptT SyntaxError (State ParserState) a)
-> SyntaxError -> ExceptT SyntaxError (State ParserState) a
forall a b. (a -> b) -> a -> b
$ Loc -> Text -> SyntaxError
SyntaxError (loc -> Loc
forall a. Located a => a -> Loc
locOf loc
loc) Text
"Syntax error."
parseErrorAt loc
loc (Just Text
s) = SyntaxError -> ExceptT SyntaxError (State ParserState) a
forall a. SyntaxError -> ExceptT SyntaxError (State ParserState) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SyntaxError -> ExceptT SyntaxError (State ParserState) a)
-> SyntaxError -> ExceptT SyntaxError (State ParserState) a
forall a b. (a -> b) -> a -> b
$ Loc -> Text -> SyntaxError
SyntaxError (loc -> Loc
forall a. Located a => a -> Loc
locOf loc
loc) Text
s

emptyArrayError :: Loc -> ParserMonad a
emptyArrayError :: forall a. Loc -> ParserMonad a
emptyArrayError Loc
loc =
  Loc -> Maybe Text -> ParserMonad a
forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt Loc
loc (Maybe Text -> ParserMonad a) -> Maybe Text -> ParserMonad a
forall a b. (a -> b) -> a -> b
$
    Text -> Maybe Text
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 = Loc -> Maybe Text -> ParserMonad a
forall loc a. Located loc => loc -> Maybe Text -> ParserMonad a
parseErrorAt Loc
loc (Maybe Text -> ParserMonad a) -> Maybe Text -> ParserMonad a
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
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 (Pos -> Loc) -> Pos -> Loc
forall a b. (a -> b) -> a -> b
$ [Char] -> Int -> Int -> Int -> Pos
Pos [Char]
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 -> 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 =
  (Either SyntaxError a, ParserState)
-> Either SyntaxError (a, [Comment])
forall {a} {a}.
(Either a a, ParserState) -> Either a (a, [Comment])
onRes ((Either SyntaxError a, ParserState)
 -> Either SyntaxError (a, [Comment]))
-> (Either SyntaxError a, ParserState)
-> Either SyntaxError (a, [Comment])
forall a b. (a -> b) -> a -> b
$ State ParserState (Either SyntaxError a)
-> ParserState -> (Either SyntaxError a, ParserState)
forall s a. State s a -> s -> (a, s)
runState (ParserMonad a -> State ParserState (Either SyntaxError a)
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 (ByteString -> AlexInput) -> ByteString -> AlexInput
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BS.fromStrict (ByteString -> ByteString)
-> (Text -> ByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
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
_) = a -> Either a (a, [Comment])
forall a b. a -> Either a b
Left a
err
    onRes (Right a
x, ParserState
s) = (a, [Comment]) -> Either a (a, [Comment])
forall a b. b -> Either a b
Right (a
x, [Comment] -> [Comment]
forall a. [a] -> [a]
reverse ([Comment] -> [Comment]) -> [Comment] -> [Comment]
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 = (a, [Comment]) -> a
forall a b. (a, b) -> a
fst ((a, [Comment]) -> a)
-> Either SyntaxError (a, [Comment]) -> Either SyntaxError a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserMonad a
-> [Char] -> Text -> Either SyntaxError (a, [Comment])
forall a.
ParserMonad a
-> [Char] -> Text -> Either SyntaxError (a, [Comment])
parseWithComments ParserMonad a
p [Char]
file Text
program