curry-base-1.1.1: src/Curry/Syntax/Parser.hs
{- |
Module : $Header$
Description : A Parser for Curry
Copyright : (c) 1999 - 2004 Wolfgang Lux
2005 Martin Engelke
2011 - 2015 Björn Peemöller
2016 - 2017 Finn Teegen
License : BSD-3-clause
Maintainer : bjp@informatik.uni-kiel.de
Stability : experimental
Portability : portable
The Curry parser is implemented using the (mostly) LL(1) parsing
combinators implemented in 'Curry.Base.LLParseComb'.
-}
module Curry.Syntax.Parser
( parseSource, parseHeader, parsePragmas, parseInterface, parseGoal
) where
import Curry.Base.Ident
import Curry.Base.Monad (CYM)
import Curry.Base.Position (Position(..), getPosition, setPosition, incr)
import Curry.Base.LLParseComb
import Curry.Base.Span hiding (file) -- clash with Position.file
import Curry.Base.SpanInfo
import Curry.Syntax.Extension
import Curry.Syntax.Lexer (Token (..), Category (..), Attributes (..), lexer)
import Curry.Syntax.Type
-- |Parse a 'Module'
parseSource :: FilePath -> String -> CYM (Module ())
parseSource = fullParser (uncurry <$> moduleHeader <*> layout moduleDecls) lexer
-- TODO position on prefix parsers?
-- |Parse only pragmas of a 'Module'
parsePragmas :: FilePath -> String -> CYM (Module ())
parsePragmas
= prefixParser ((\ps sp -> setEndPosition NoPos
(Module (SpanInfo sp []) ps mainMIdent
Nothing [] []))
<$> modulePragmas <*> spanPosition)
lexer
-- |Parse a 'Module' header
parseHeader :: FilePath -> String -> CYM (Module ())
parseHeader
= prefixParser (moduleHeader <*> startLayout importDecls <*> succeed []) lexer
where importDecls = many (importDecl <*-> many semicolon)
-- |Parse an 'Interface'
parseInterface :: FilePath -> String -> CYM Interface
parseInterface = fullParser interface lexer
-- |Parse a 'Goal'
parseGoal :: String -> CYM (Goal ())
parseGoal = fullParser goal lexer ""
-- ---------------------------------------------------------------------------
-- Module header
-- ---------------------------------------------------------------------------
-- |Parser for a module header
moduleHeader :: Parser a Token ([ImportDecl] -> [Decl b] -> Module b)
moduleHeader =
(\sp ps (m, es, inf) is ds -> updateEndPos
(Module (SpanInfo sp inf) ps m es is ds))
<$> spanPosition
<*> modulePragmas
<*> header
where header = (\sp1 m es sp2 -> (m, es, [sp1,sp2]))
<$> tokenSpan KW_module
<*> modIdent
<*> option exportSpec
<*> spanPosition
<*-> expectWhere
`opt` (mainMIdent, Nothing, [])
modulePragmas :: Parser a Token [ModulePragma]
modulePragmas = many (languagePragma <|> optionsPragma)
languagePragma :: Parser a Token ModulePragma
languagePragma = languagePragma'
<$> tokenSpan PragmaLanguage
<*> (languageExtension `sepBy1Sp` comma)
<*> tokenSpan PragmaEnd
where languageExtension = classifyExtension <$> ident
languagePragma' sp1 (ex, ss) sp2 = updateEndPos $
LanguagePragma (SpanInfo sp1 (sp1 : ss ++ [sp2])) ex
-- TODO The span info is not 100% complete due to the lexer
-- combining OPTIONS, toolVal and toolArgs
optionsPragma :: Parser a Token ModulePragma
optionsPragma = optionsPragma'
<$> spanPosition
<*> token PragmaOptions
<*> tokenSpan PragmaEnd
where optionsPragma' sp1 a sp2 = updateEndPos $
OptionsPragma (SpanInfo sp1 [sp1, sp2])
(classifyTool <$> toolVal a)
(toolArgs a)
-- |Parser for an export specification
exportSpec :: Parser a Token ExportSpec
exportSpec = exportSpec' <$> spanPosition <*> parensSp (export `sepBySp` comma)
where exportSpec' sp1 ((ex, ss),sp2,sp3) = updateEndPos $
Exporting (SpanInfo sp1 (sp2:(ss ++ [sp3]))) ex
-- |Parser for an export item
export :: Parser a Token Export
export = qtycon <**> (tcExportWith <$> parensSp spec `opt` tcExport)
<|> tcExport <$> qfun <\> qtycon
<|> exportModule' <$> tokenSpan KW_module <*> modIdent
where spec = (\sp -> (ExportTypeAll , [sp])) <$> tokenSpan DotDot
<|> (\(c, ss) -> (exportTypeWith' c, ss )) <$> con `sepBySp` comma
tcExport qtc = updateEndPos $ Export (fromSrcSpan (getSrcSpan qtc)) qtc
tcExportWith ((spc, ss), sp1, sp2) qtc =
updateEndPos $ setSrcInfoPoints (sp1 : (ss ++ [sp2])) $
spc (fromSrcSpan (getSrcSpan qtc)) qtc
exportTypeWith' c spi qtc = ExportTypeWith spi qtc c
exportModule' sp = updateEndPos . ExportModule (SpanInfo sp [sp])
moduleDecls :: Parser a Token ([ImportDecl], [Decl ()])
moduleDecls = impDecl <$> importDecl
<*> (semicolon <-*> moduleDecls `opt` ([], []))
<|> (,) [] <$> topDecls
where impDecl i (is, ds) = (i:is ,ds)
-- |Parser for a single import declaration
importDecl :: Parser a Token ImportDecl
importDecl = importDecl'
<$> tokenSpan KW_import
<*> option (tokenSpan Id_qualified)
<*> modIdent
<*> option ((,) <$> tokenSpan Id_as <*> modIdent)
<*> option importSpec
where
importDecl' sp1 (Just sp2) mid (Just (sp3, alias)) = updateEndPos .
ImportDecl (SpanInfo sp1 [sp1, sp2, sp3]) mid True (Just alias)
importDecl' sp1 Nothing mid (Just (sp3, alias)) = updateEndPos .
ImportDecl (SpanInfo sp1 [sp1, sp3]) mid False (Just alias)
importDecl' sp1 (Just sp2) mid Nothing = updateEndPos .
ImportDecl (SpanInfo sp1 [sp1, sp2]) mid True Nothing
importDecl' sp1 Nothing mid Nothing = updateEndPos .
ImportDecl (SpanInfo sp1 [sp1]) mid False Nothing
-- |Parser for an import specification
importSpec :: Parser a Token ImportSpec
importSpec = spanPosition
<**> (hiding' <$-> token Id_hiding `opt` importing')
<*> parensSp (importSp `sepBySp` comma)
where
hiding' sp1 ((specs, ss), sp2, sp3) = updateEndPos $
Hiding (SpanInfo sp1 (sp1 : sp2 : (ss ++ [sp3]))) specs
importing' sp1 ((specs, ss), sp2, sp3) = updateEndPos $
Importing (SpanInfo sp1 ( sp2 : (ss ++ [sp3]))) specs
importSp :: Parser a Token Import
importSp = tycon <**> (tcImportWith <$> parensSp spec `opt` tcImport)
<|> tcImport <$> fun <\> tycon
where spec = (\sp -> (ImportTypeAll , [sp])) <$> tokenSpan DotDot
<|> (\(c, ss) -> (importTypeWith' c, ss )) <$> con `sepBySp` comma
tcImport tc = updateEndPos $ Import (fromSrcSpan (getSrcSpan tc)) tc
tcImportWith ((spc, ss), sp1, sp2) tc =
updateEndPos $ setSrcInfoPoints (sp1 : (ss ++ [sp2])) $
spc (fromSrcSpan (getSrcSpan tc)) tc
importTypeWith' c spi tc = ImportTypeWith spi tc c
-- ---------------------------------------------------------------------------
-- Interfaces
-- ---------------------------------------------------------------------------
-- |Parser for an interface
interface :: Parser a Token Interface
interface = uncurry <$> intfHeader <*> braces intfDecls
intfHeader :: Parser a Token ([IImportDecl] -> [IDecl] -> Interface)
intfHeader = Interface <$-> token Id_interface <*> modIdent <*-> expectWhere
intfDecls :: Parser a Token ([IImportDecl], [IDecl])
intfDecls = impDecl <$> iImportDecl
<*> (semicolon <-*> intfDecls `opt` ([], []))
<|> (,) [] <$> intfDecl `sepBy` semicolon
where impDecl i (is, ds) = (i:is, ds)
-- |Parser for a single interface import declaration
iImportDecl :: Parser a Token IImportDecl
iImportDecl = IImportDecl <$> tokenPos KW_import <*> modIdent
-- |Parser for a single interface declaration
intfDecl :: Parser a Token IDecl
intfDecl = choice [ iInfixDecl, iHidingDecl, iDataDecl, iNewtypeDecl
, iTypeDecl , iFunctionDecl <\> token Id_hiding
, iClassDecl, iInstanceDecl ]
-- |Parser for an interface infix declaration
iInfixDecl :: Parser a Token IDecl
iInfixDecl = infixDeclLhs iInfixDecl' <*> integer <*> qfunop
where iInfixDecl' sp = IInfixDecl (span2Pos sp)
-- |Parser for an interface hiding declaration
iHidingDecl :: Parser a Token IDecl
iHidingDecl = tokenPos Id_hiding <**> (hDataDecl <|> hClassDecl)
where
hDataDecl = hiddenData <$-> token KW_data <*> withKind qtycon <*> many tyvar
hClassDecl = hiddenClass <$> classInstHead KW_class (withKind qtycls) clsvar
hiddenData (tc, k) tvs p = HidingDataDecl p tc k tvs
hiddenClass (_, _, cx, (qcls, k), tv) p = HidingClassDecl p cx qcls k tv
-- |Parser for an interface data declaration
iDataDecl :: Parser a Token IDecl
iDataDecl = iTypeDeclLhs IDataDecl KW_data <*> constrs <*> iHiddenPragma
where constrs = equals <-*> constrDecl `sepBy1` bar `opt` []
-- |Parser for an interface newtype declaration
iNewtypeDecl :: Parser a Token IDecl
iNewtypeDecl = iTypeDeclLhs INewtypeDecl KW_newtype
<*-> equals <*> newConstrDecl <*> iHiddenPragma
-- |Parser for an interface type synonym declaration
iTypeDecl :: Parser a Token IDecl
iTypeDecl = iTypeDeclLhs ITypeDecl KW_type
<*-> equals <*> type0
-- |Parser for an interface hiding pragma
iHiddenPragma :: Parser a Token [Ident]
iHiddenPragma = token PragmaHiding
<-*> (con `sepBy` comma)
<*-> token PragmaEnd
`opt` []
-- |Parser for an interface function declaration
iFunctionDecl :: Parser a Token IDecl
iFunctionDecl = IFunctionDecl <$> position <*> qfun <*> option iMethodPragma
<*> arity <*-> token DoubleColon <*> qualType
-- |Parser for an interface method pragma
iMethodPragma :: Parser a Token Ident
iMethodPragma = token PragmaMethod <-*> clsvar <*-> token PragmaEnd
-- |Parser for function's arity
arity :: Parser a Token Int
arity = int `opt` 0
iTypeDeclLhs :: (Position -> QualIdent -> Maybe KindExpr -> [Ident] -> a)
-> Category -> Parser b Token a
iTypeDeclLhs f kw = f' <$> tokenPos kw <*> withKind qtycon <*> many tyvar
where f' p (tc, k) = f p tc k
-- |Parser for an interface class declaration
iClassDecl :: Parser a Token IDecl
iClassDecl = (\(sp, _, cx, (qcls, k), tv) ->
IClassDecl (span2Pos sp) cx qcls k tv)
<$> classInstHead KW_class (withKind qtycls) clsvar
<*> braces (iMethod `sepBy` semicolon)
<*> iClassHidden
-- |Parser for an interface method declaration
iMethod :: Parser a Token IMethodDecl
iMethod = IMethodDecl <$> position
<*> fun <*> option int <*-> token DoubleColon <*> qualType
-- |Parser for an interface hiding pragma
iClassHidden :: Parser a Token [Ident]
iClassHidden = token PragmaHiding
<-*> (fun `sepBy` comma)
<*-> token PragmaEnd
`opt` []
-- |Parser for an interface instance declaration
iInstanceDecl :: Parser a Token IDecl
iInstanceDecl = (\(sp, _, cx, qcls, inst) ->
IInstanceDecl (span2Pos sp) cx qcls inst)
<$> classInstHead KW_instance qtycls type2
<*> braces (iImpl `sepBy` semicolon)
<*> option iModulePragma
-- |Parser for an interface method implementation
iImpl :: Parser a Token IMethodImpl
iImpl = (,) <$> fun <*> arity
iModulePragma :: Parser a Token ModuleIdent
iModulePragma = token PragmaModule <-*> modIdent <*-> token PragmaEnd
-- ---------------------------------------------------------------------------
-- Top-Level Declarations
-- ---------------------------------------------------------------------------
topDecls :: Parser a Token [Decl ()]
topDecls = topDecl `sepBy` semicolon
topDecl :: Parser a Token (Decl ())
topDecl = choice [ dataDecl, externalDataDecl, newtypeDecl, typeDecl
, classDecl, instanceDecl, defaultDecl
, infixDecl, functionDecl ]
dataDecl :: Parser a Token (Decl ())
dataDecl = combineWithSpans
<$> typeDeclLhs dataDecl' KW_data
<*> ((addSpan <$> tokenSpan Equals <*> constrs) `opt` ([],[]))
<*> deriv
where constrs = constrDecl `sepBy1Sp` bar
dataDecl' sp = DataDecl (SpanInfo sp [sp])
externalDataDecl :: Parser a Token (Decl ())
externalDataDecl = decl <$> tokenSpan KW_external <*> typeDeclLhs (,,) KW_data
where decl sp1 (sp2, tc, tvs) = updateEndPos $
ExternalDataDecl (SpanInfo sp1 [sp1, sp2]) tc tvs
newtypeDecl :: Parser a Token (Decl ())
newtypeDecl = combineWithSpans
<$> typeDeclLhs newtypeDecl' KW_newtype
<*> ((\sp c -> (c, [sp])) <$> tokenSpan Equals <*> newConstrDecl)
<*> deriv
where newtypeDecl' sp = NewtypeDecl (SpanInfo sp [sp])
combineWithSpans :: HasSpanInfo a =>
(t1 -> t2 -> a) -> (t1, [Span]) -> (t2, [Span]) -> a
combineWithSpans df (cs, sps1) (cls, sps2)
= updateEndPos $ setSrcInfoPoints (getSrcInfoPoints res ++ sps1 ++ sps2) res
where res = df cs cls
typeDecl :: Parser a Token (Decl ())
typeDecl = typeDeclLhs typeDecl' KW_type <*> tokenSpan Equals <*> type0
where typeDecl' sp1 tyc tyv sp2 txp = updateEndPos $
TypeDecl (SpanInfo sp1 [sp1, sp2]) tyc tyv txp
typeDeclLhs :: (Span -> Ident -> [Ident] -> a) -> Category
-> Parser b Token a
typeDeclLhs f kw = f <$> tokenSpan kw <*> tycon <*> many anonOrTyvar
constrDecl :: Parser a Token ConstrDecl
constrDecl = spanPosition <**> constr
where
constr = conId <**> identDecl
<|> tokenSpan LeftParen <**> parenDecl
<|> type1 <\> conId <\> leftParen <**> opDecl
identDecl = many type2 <**> (conType <$> opDecl `opt` conDecl)
<|> recDecl <$> recFields
parenDecl = conOpDeclPrefix
<$> conSym <*> tokenSpan RightParen <*> type2 <*> type2
<|> tupleType <**> (tokenSpan RightParen <**> opDeclParen)
opDecl = conOpDecl <$> conop <*> type1
opDeclParen = conOpDeclParen <$> conop <*> type1
recFields = layoutOff <-*> bracesSp (fieldDecl `sepBySp` comma)
conType f tys c = f $ foldl mkApply (mkConstructorType $ qualify c) tys
mkApply t1 t2 = updateEndPos $ ApplyType (fromSrcSpan (getSrcSpan t1)) t1 t2
mkConstructorType qid = ConstructorType (fromSrcSpan (getSrcSpan qid)) qid
conDecl tys c sp = updateEndPos $
ConstrDecl (SpanInfo sp []) c tys
conOpDecl op ty2 ty1 sp = updateEndPos $
ConOpDecl (SpanInfo sp []) ty1 op ty2
conOpDeclParen op ty2 sp1 ty1 sp2 sp5 = updateEndPos $
ConOpDecl (SpanInfo sp5 [sp2, sp1]) ty1 op ty2
conOpDeclPrefix op sp1 ty1 ty2 sp2 sp3 = updateEndPos $
ConOpDecl (SpanInfo sp3 [sp2, sp1]) ty1 op ty2
recDecl ((fs, ss), sp1, sp2) c sp3 = updateEndPos $
RecordDecl (SpanInfo sp3 (sp1 : ss ++ [sp2])) c fs
fieldDecl :: Parser a Token FieldDecl
fieldDecl = mkFieldDecl <$> spanPosition <*> labels
<*> tokenSpan DoubleColon <*> type0
where labels = fun `sepBy1Sp` comma
mkFieldDecl sp1 (idt,ss) sp2 ty = updateEndPos $
FieldDecl (SpanInfo sp1 (ss ++ [sp2])) idt ty
newConstrDecl :: Parser a Token NewConstrDecl
newConstrDecl = spanPosition <**> (con <**> newConstr)
where newConstr = newConDecl <$> type2
<|> newRecDecl <$> newFieldDecl
newConDecl ty c sp = updateEndPos $ NewConstrDecl (SpanInfo sp []) c ty
newRecDecl ((idt, sp2, ty), sp3, sp4) c sp1 = updateEndPos $
NewRecordDecl (SpanInfo sp1 [sp3,sp2,sp4]) c (idt, ty)
newFieldDecl :: Parser a Token ((Ident, Span, TypeExpr), Span, Span)
newFieldDecl = layoutOff <-*> bracesSp labelDecl
where labelDecl = (,,) <$> fun <*> tokenSpan DoubleColon <*> type0
deriv :: Parser a Token ([QualIdent], [Span])
deriv = (addSpan <$> tokenSpan KW_deriving <*> classes) `opt` ([], [])
where classes = ((\q -> ([q], [])) <$> qtycls)
<|> ((\sp1 (qs, ss) sp2 -> (qs, sp1 : (ss ++ [sp2])))
<$> tokenSpan LeftParen
<*> (qtycls `sepBySp` comma)
<*> tokenSpan RightParen)
functionDecl :: Parser a Token (Decl ())
functionDecl = spanPosition <**> decl
where decl = fun `sepBy1Sp` comma <**> funListDecl <|?> funRule
funRule :: Parser a Token (Span -> Decl ())
funRule = mkFunDecl <$> lhs <*> declRhs
where lhs = (\f ->
(f, updateEndPos $ FunLhs (fromSrcSpan (getSrcSpan f)) f []))
<$> fun <|?> funLhs
funListDecl :: Parser a Token (([Ident],[Span]) -> Span -> Decl ())
funListDecl = typeSig <|> mkExtFun <$> tokenSpan KW_external
where mkExtFun sp1 (vs,ss) sp2 = updateEndPos $
ExternalDecl (SpanInfo sp2 (ss++[sp1])) (map (Var ()) vs)
typeSig :: Parser a Token (([Ident],[Span]) -> Span -> Decl ())
typeSig = sig <$> tokenSpan DoubleColon <*> qualType
where sig sp1 qty (vs,ss) sp2 = updateEndPos $
TypeSig (SpanInfo sp2 (ss++[sp1])) vs qty
mkFunDecl :: (Ident, Lhs ()) -> Rhs () -> Span -> Decl ()
mkFunDecl (f, lhs) rhs' p = updateEndPos $
FunctionDecl (SpanInfo p []) () f [updateEndPos $
Equation (SpanInfo p []) lhs rhs']
funLhs :: Parser a Token (Ident, Lhs ())
funLhs = mkFunLhs <$> fun <*> many1 pattern2
<|?> flip ($ updateEndPos) <$> pattern1 <*> opLhs
<|?> curriedLhs
where
opLhs = opLHS funSym (gConSym <\> funSym)
<|> tokenSpan Backquote <**>
opLHSSp ((,) <$> funId <*> spanPosition
<*-> expectBackquote)
((,) <$> qConId <\> funId <*> spanPosition
<*-> expectBackquote)
opLHS funP consP = mkOpLhs <$> funP <*> pattern0
<|> mkInfixPat <$> consP <*> pattern1 <*> opLhs
opLHSSp funP consP = mkOpLhsSp <$> funP <*> pattern0
<|> mkInfixPatSp <$> consP <*> pattern1 <*> opLhs
mkFunLhs f ts = (f , updateEndPos $ FunLhs (fromSrcSpan (getSrcSpan f)) f ts)
mkOpLhs op t2 f t1 =
let t1' = f t1
in (op, updateEndPos $ OpLhs (fromSrcSpan (getSrcSpan t1')) t1' op t2)
mkInfixPat op t2 f g t1 =
f (g . InfixPattern (fromSrcSpan (getSrcSpan t1)) () t1 op) t2
mkOpLhsSp (op, sp1) t2 sp2 f t1 =
let t1' = f t1
in (op, updateEndPos $
OpLhs (SpanInfo (getSrcSpan t1') [sp2, sp1]) t1' op t2)
mkInfixPatSp (op, sp1) t2 g sp2 f t1 =
g (f . InfixPattern (SpanInfo (getSrcSpan t1) [sp2, sp1]) () t1 op) t2
curriedLhs :: Parser a Token (Ident, Lhs ())
curriedLhs = apLhs <$> parensSp funLhs <*> many1 pattern2
where apLhs ((f, lhs), sp1, sp2) ts =
let spi = fromSrcSpan sp1
in (f, updateEndPos $ setSrcInfoPoints [sp1, sp2] $ ApLhs spi lhs ts)
declRhs :: Parser a Token (Rhs ())
declRhs = rhs equals
rhs :: Parser a Token b -> Parser a Token (Rhs ())
rhs eq = rhsExpr <*> spanPosition <*> localDecls
where rhsExpr = mkSimpleRhs <$> spanPosition <*-> eq <*> expr
<|> mkGuardedRhs <$> spanPosition <*> many1 (condExpr eq)
mkSimpleRhs sp1 e sp2 ds = updateEndPos $
SimpleRhs (SpanInfo sp1 [sp2]) e ds
mkGuardedRhs sp1 ce sp2 ds = updateEndPos $
GuardedRhs (SpanInfo sp1 [sp2]) ce ds
whereClause :: Parser a Token [b] -> Parser a Token [b]
whereClause decls = token KW_where <-*> layout decls `opt` []
localDecls :: Parser a Token [Decl ()]
localDecls = whereClause valueDecls
valueDecls :: Parser a Token [Decl ()]
valueDecls = choice [infixDecl, valueDecl] `sepBy` semicolon
infixDecl :: Parser a Token (Decl ())
infixDecl = infixDeclLhs infixDecl'
<*> option ((,) <$> spanPosition <*> integer)
<*> funop `sepBy1Sp` comma
where infixDecl' sp1 inf (Just (sp2, pr)) (ids, ss) =
updateEndPos $ InfixDecl (SpanInfo sp1 (sp1:sp2:ss)) inf (Just pr) ids
infixDecl' sp1 inf Nothing (ids, ss) =
updateEndPos $ InfixDecl (SpanInfo sp1 (sp1 :ss)) inf Nothing ids
infixDeclLhs :: (Span -> Infix -> a) -> Parser b Token a
infixDeclLhs f = f <$> spanPosition <*> tokenOps infixKW
where infixKW = [(KW_infix, Infix), (KW_infixl, InfixL), (KW_infixr, InfixR)]
valueDecl :: Parser a Token (Decl ())
valueDecl = spanPosition <**> decl
where
decl = var `sepBy1Sp` comma <**> valListDecl
<|?> patOrFunDecl <$> pattern0 <*> declRhs
<|?> mkFunDecl <$> curriedLhs <*> declRhs
valListDecl = funListDecl
<|> mkFree <$> tokenSpan KW_free
where mkFree sp1 (vs, ss) sp2 = updateEndPos $
FreeDecl (SpanInfo sp2 (ss ++ [sp1])) (map (Var ()) vs)
patOrFunDecl (ConstructorPattern spi _ c ts)
| not (isConstrId c) = mkFunDecl (f, FunLhs spi f ts)
where f = unqualify c
patOrFunDecl t = patOrOpDecl updateEndPos t
patOrOpDecl f (InfixPattern spi a t1 op t2)
| isConstrId op = patOrOpDecl (f . InfixPattern spi a t1 op) t2
| otherwise = mkFunDecl (op', updateEndPos $ OpLhs spi (f t1) op' t2)
where op' = unqualify op
patOrOpDecl f t = mkPatDecl (f t)
mkPatDecl t rhs' sp = updateEndPos $ PatternDecl (fromSrcSpan sp) t rhs'
isConstrId c = c == qConsId || isQualified c || isQTupleId c
defaultDecl :: Parser a Token (Decl ())
defaultDecl = mkDefaultDecl <$> tokenSpan KW_default
<*> parensSp (type0 `sepBySp` comma)
where mkDefaultDecl sp1 ((ty, ss), sp2, sp3) = updateEndPos $
DefaultDecl (SpanInfo sp1 (sp1 : sp2 : (ss ++ [sp3]))) ty
classInstHead :: Category -> Parser a Token b -> Parser a Token c
-> Parser a Token (Span, [Span], Context, b, c)
classInstHead kw cls ty = f <$> tokenSpan kw
<*> optContext (,,) ((,) <$> cls <*> ty)
where f sp (cx, ss, (cls', ty')) = (sp, ss, cx, cls', ty')
classDecl :: Parser a Token (Decl ())
classDecl = (\(sp1, ss, cx, cls, tv) sp2 -> updateEndPos .
ClassDecl (SpanInfo sp1 (sp1 : (ss ++ [sp2]))) cx cls tv)
<$> classInstHead KW_class tycls clsvar
<*> spanPosition
<*> whereClause innerDecls
where
innerDecls = innerDecl `sepBy` semicolon
--TODO: Refactor by left-factorization
--TODO: Support infixDecl
innerDecl = foldr1 (<|?>)
[ spanPosition <**> (fun `sepBy1Sp` comma <**> typeSig)
, spanPosition <**> funRule
{-, infixDecl-} ]
instanceDecl :: Parser a Token (Decl ())
instanceDecl = (\(sp1, ss, cx, qcls, inst) sp2 -> updateEndPos .
InstanceDecl (SpanInfo sp1 (sp1 : (ss ++ [sp2]))) cx qcls inst)
<$> classInstHead KW_instance qtycls type2
<*> spanPosition
<*> whereClause innerDecls
where
innerDecls = (spanPosition <**> funRule) `sepBy` semicolon
-- ---------------------------------------------------------------------------
-- Type classes
-- ---------------------------------------------------------------------------
optContext :: (Context -> [Span] -> a -> b)
-> Parser c Token a
-> Parser c Token b
optContext f p = combine <$> context <*> tokenSpan DoubleArrow <*> p
<|?> f [] [] <$> p
where combine (ctx, ss) sp = f ctx (ss ++ [sp])
context :: Parser a Token (Context, [Span])
context = (\c -> ([c], [])) <$> constraint
<|> combine <$> parensSp (constraint `sepBySp` comma)
where combine ((ctx, ss), sp1, sp2) = (ctx, sp1 : (ss ++ [sp2]))
-- TODO: ???
constraint :: Parser a Token Constraint
constraint = mkConstraint <$> spanPosition <*> qtycls <*> conType
where varType = mkVariableType <$> spanPosition <*> clsvar
conType = fmap ((,) []) varType
<|> mk <$> parensSp
(foldl mkApplyType <$> varType <*> many1 type2)
mkConstraint sp qtc (ss, ty) = updateEndPos $
Constraint (SpanInfo sp ss) qtc ty
mkVariableType sp = VariableType (fromSrcSpan sp)
mkApplyType t1 t2 =
ApplyType (fromSrcSpan (combineSpans (getSrcSpan t1)
(getSrcSpan t2)))
t1 t2
mk (a, sp1, sp2) = ([sp1, sp2], a)
-- ---------------------------------------------------------------------------
-- Kinds
-- ---------------------------------------------------------------------------
withKind :: Parser a Token b -> Parser a Token (b, Maybe KindExpr)
withKind p = implicitKind <$> p
<|?> parens (explicitKind <$> p <*-> token DoubleColon <*> kind0)
where implicitKind x = (x, Nothing)
explicitKind x k = (x, Just k)
-- kind0 ::= kind1 ['->' kind0]
kind0 :: Parser a Token KindExpr
kind0 = kind1 `chainr1` (ArrowKind <$-> token RightArrow)
-- kind1 ::= * | '(' kind0 ')'
kind1 :: Parser a Token KindExpr
kind1 = Star <$-> token SymStar
<|> parens kind0
-- ---------------------------------------------------------------------------
-- Types
-- ---------------------------------------------------------------------------
-- qualType ::= [context '=>'] type0
qualType :: Parser a Token QualTypeExpr
qualType = mkQualTypeExpr <$> spanPosition <*> optContext (,,) type0
where mkQualTypeExpr sp (cx, ss, ty) = updateEndPos $
QualTypeExpr (SpanInfo sp ss) cx ty
-- type0 ::= type1 ['->' type0]
type0 :: Parser a Token TypeExpr
type0 = type1 `chainr1` (mkArrowType <$> tokenSpan RightArrow)
where mkArrowType sp ty1 ty2 = updateEndPos $
ArrowType (SpanInfo (getSrcSpan ty1) [sp]) ty1 ty2
-- type1 ::= [type1] type2
type1 :: Parser a Token TypeExpr
type1 = foldl1 mkApplyType <$> many1 type2
where mkApplyType ty1 ty2 = updateEndPos $
ApplyType (fromSrcSpan (getSrcSpan ty1)) ty1 ty2
-- type2 ::= anonType | identType | parenType | bracketType
type2 :: Parser a Token TypeExpr
type2 = anonType <|> identType <|> parenType <|> bracketType
-- anonType ::= '_'
anonType :: Parser a Token TypeExpr
anonType = mkVariableType <$> spanPosition <*> anonIdent
where mkVariableType sp = VariableType (fromSrcSpan sp)
-- identType ::= <identifier>
identType :: Parser a Token TypeExpr
identType = mkVariableType <$> spanPosition <*> tyvar
<|> mkConstructorType <$> spanPosition <*> qtycon <\> tyvar
where mkVariableType sp = VariableType (fromSrcSpan sp)
mkConstructorType sp = ConstructorType (fromSrcSpan sp)
-- parenType ::= '(' tupleType ')'
parenType :: Parser a Token TypeExpr
parenType = fmap updateSpanWithBrackets (parensSp tupleType)
-- tupleType ::= type0 (parenthesized type)
-- | type0 ',' type0 { ',' type0 } (tuple type)
-- | '->' (function type constructor)
-- | ',' { ',' } (tuple type constructor)
-- | (unit type)
tupleType :: Parser a Token TypeExpr
tupleType = type0 <**> (mkTuple <$> many1 ((,) <$> tokenSpan Comma <*> type0)
`opt` ParenType NoSpanInfo)
<|> tokenSpan RightArrow <**> succeed (mkConstructorType qArrowId)
<|> mkConstructorTupleType <$> many1 (tokenSpan Comma)
<|> succeed (ConstructorType NoSpanInfo qUnitId)
where mkTuple stys ty = let (ss, tys) = unzip stys
in TupleType (fromSrcInfoPoints ss) (ty : tys)
mkConstructorType qid sp = ConstructorType (fromSrcInfoPoints [sp]) qid
mkConstructorTupleType ss = ConstructorType (fromSrcInfoPoints ss)
(qTupleId (length ss + 1))
-- bracketType ::= '[' listType ']'
bracketType :: Parser a Token TypeExpr
bracketType = fmap updateSpanWithBrackets (bracketsSp listType)
-- listType ::= type0 (list type)
-- | (list type constructor)
listType :: Parser a Token TypeExpr
listType = ListType NoSpanInfo <$> type0
`opt` ConstructorType NoSpanInfo qListId
-- ---------------------------------------------------------------------------
-- Literals
-- ---------------------------------------------------------------------------
-- literal ::= '\'' <escaped character> '\''
-- | <integer>
-- | <float>
-- | '"' <escaped string> '"'
literal :: Parser a Token Literal
literal = Char <$> char
<|> Int <$> integer
<|> Float <$> float
<|> String <$> string
-- ---------------------------------------------------------------------------
-- Patterns
-- ---------------------------------------------------------------------------
-- pattern0 ::= pattern1 [ gconop pattern0 ]
pattern0 :: Parser a Token (Pattern ())
pattern0 = pattern1 `chainr1` (mkInfixPattern <$> gconop)
where mkInfixPattern qid p1 p2 =
InfixPattern (fromSrcSpan (combineSpans (getSrcSpan p1)
(getSrcSpan p2)))
() p1 qid p2
-- pattern1 ::= varId
-- | QConId { pattern2 }
-- | '-' Integer
-- | '-.' Float
-- | '(' parenPattern'
-- | pattern2
pattern1 :: Parser a Token (Pattern ())
pattern1 = varId <**> identPattern' -- unqualified
<|> qConId <\> varId <**> constrPattern -- qualified
<|> mkNegNum <$> minus <*> negNum
<|> tokenSpan LeftParen <**> parenPattern'
<|> pattern2 <\> qConId <\> leftParen
where
identPattern' = optAsRecPattern
<|> mkConsPattern qualify <$> many1 pattern2
constrPattern = mkConsPattern id <$> many1 pattern2
<|> optRecPattern
parenPattern' = minus <**> minusPattern
<|> mkGconPattern <$> gconId <*> tokenSpan RightParen <*> many pattern2
<|> mkFunIdentP <$> funSym <\> minus <*> tokenSpan RightParen
<*> identPattern'
<|> mkParenTuple <$> parenTuplePattern <\> minus <*> tokenSpan RightParen
minusPattern = flip mkParenMinus <$> tokenSpan RightParen <*> identPattern'
<|> mkParenMinus <$> parenMinusPattern <*> tokenSpan RightParen
mkNegNum idt p = setEndPosition (end (getSrcSpan idt)) p
mkParenTuple p sp1 sp2 =
setSpanInfo (SpanInfo (combineSpans sp2 sp1) [sp2, sp1]) p
mkFunIdentP idt sp1 f sp2 = setSrcSpan (combineSpans sp2 sp1) (f idt)
mkParenMinus f sp1 idt sp2 = setSrcSpan (combineSpans sp2 sp1) (f idt)
mkConsPattern f ts c = updateEndPos $
ConstructorPattern (fromSrcSpan (getSrcSpan (f c))) () (f c) ts
mkGconPattern qid sp1 ps sp2 = updateEndPos $
ConstructorPattern (SpanInfo (getSrcSpan qid) [sp2,sp1]) () qid ps
pattern2 :: Parser a Token (Pattern ())
pattern2 = literalPattern <|> anonPattern <|> identPattern
<|> parenPattern <|> listPattern <|> lazyPattern
-- literalPattern ::= <integer> | <char> | <float> | <string>
literalPattern :: Parser a Token (Pattern ())
literalPattern = flip LiteralPattern () <$> fmap fromSrcSpan spanPosition
<*> literal
-- anonPattern ::= '_'
anonPattern :: Parser a Token (Pattern ())
anonPattern = flip VariablePattern () <$> fmap fromSrcSpan spanPosition
<*> anonIdent
-- identPattern ::= Variable [ '@' pattern2 | '{' fields '}'
-- | qConId [ '{' fields '}' ]
identPattern :: Parser a Token (Pattern ())
identPattern = varId <**> optAsRecPattern -- unqualified
<|> qConId <\> varId <**> optRecPattern -- qualified
-- TODO: document me!
parenPattern :: Parser a Token (Pattern ())
parenPattern = tokenSpan LeftParen <**> parenPattern'
where
parenPattern' = minus <**> minusPattern
<|> mkConstructorPattern <$> gconId <*> tokenSpan RightParen
<|> mkFunAsRec <$> funSym <\> minus <*> tokenSpan RightParen
<*> optAsRecPattern
<|> mkParenTuple <$> parenTuplePattern <\> minus <*> tokenSpan RightParen
minusPattern = mkOptAsRec <$> tokenSpan RightParen <*> optAsRecPattern
<|> mkParen <$> parenMinusPattern <*> tokenSpan RightParen
mkConstructorPattern qid sp1 sp2 =
ConstructorPattern (fromSrcSpan (combineSpans sp2 sp1)) () qid []
mkFunAsRec = flip (flip . mkOptAsRec)
mkParenTuple p sp1 sp2 =
let ss = getSrcInfoPoints p
spi = SpanInfo (combineSpans sp2 sp1) (sp2 : (ss ++ [sp1]))
in setSpanInfo spi p
mkOptAsRec sp1 f idt sp2 =
let p = f idt
ss = getSrcInfoPoints p
spi = SpanInfo (combineSpans sp2 sp1) ([sp2, sp1] ++ ss)
in setSpanInfo spi p
mkParen f sp1 idt sp2 =
let p = f idt
ss = getSrcInfoPoints p
spi = SpanInfo (combineSpans sp2 sp1) (sp2 : (ss ++ [sp1]))
in setSpanInfo spi p
-- listPattern ::= '[' pattern0s ']'
-- pattern0s ::= {- empty -}
-- | pattern0 ',' pattern0s
listPattern :: Parser a Token (Pattern ())
listPattern = mkListPattern <$> bracketsSp (pattern0 `sepBySp` comma)
where mkListPattern ((ps, ss), sp1, sp2) = updateEndPos $
ListPattern (SpanInfo sp1 (sp1 : (ss ++ [sp2]))) () ps
-- lazyPattern ::= '~' pattern2
lazyPattern :: Parser a Token (Pattern ())
lazyPattern = mkLazyPattern <$> tokenSpan Tilde <*> pattern2
where mkLazyPattern sp p = updateEndPos $ LazyPattern (SpanInfo sp [sp]) p
-- optRecPattern ::= [ '{' fields '}' ]
optRecPattern :: Parser a Token (QualIdent -> Pattern ())
optRecPattern = mkRecordPattern <$> fieldsSp pattern0 `opt` mkConPattern
where
mkRecordPattern ((fs, ss), sp1, sp2) c = updateEndPos $
RecordPattern (SpanInfo (getSrcSpan c) (sp1 : (ss ++ [sp2]))) () c fs
mkConPattern c = ConstructorPattern (fromSrcSpan (getSrcSpan c)) () c []
-- ---------------------------------------------------------------------------
-- Partial patterns used in the combinators above, but also for parsing
-- the left-hand side of a declaration.
-- ---------------------------------------------------------------------------
gconId :: Parser a Token QualIdent
gconId = colon <|> tupleCommas
negNum :: Parser a Token (Pattern ())
negNum = mkNegativePattern <$> spanPosition <*>
(Int <$> integer <|> Float <$> float)
where mkNegativePattern sp = NegativePattern (fromSrcSpan sp) ()
optAsRecPattern :: Parser a Token (Ident -> Pattern ())
optAsRecPattern = mkAsPattern <$> tokenSpan At <*> pattern2
<|> mkRecordPattern <$> fieldsSp pattern0
`opt` mkVariablePattern
where mkRecordPattern ((fs,ss),sp1,sp2) v =
let s = getPosition v
e = end sp2
f = file s
spi = SpanInfo (Span f s e) (sp1 : (ss ++ [sp2]))
in updateEndPos $ RecordPattern spi () (qualify v) fs
mkAsPattern sp p idt =
AsPattern (SpanInfo (getSrcSpan idt) [sp]) idt p
mkVariablePattern idt =
VariablePattern (fromSrcSpan (getSrcSpan idt)) () idt
optInfixPattern :: Parser a Token (Pattern () -> Pattern ())
optInfixPattern = mkInfixPat <$> gconop <*> pattern0
`opt` id
where mkInfixPat op t2 t1 =
let s = getPosition t1
e = getSrcSpanEnd t2
f = file s
in InfixPattern (fromSrcSpan (Span f s e)) () t1 op t2
optTuplePattern :: Parser a Token (Pattern () -> Pattern ())
optTuplePattern = mkTuple <$> many1 ((,) <$> tokenSpan Comma <*> pattern0)
`opt` ParenPattern NoSpanInfo
where mkTuple ts t = let (ss, ps) = unzip ts
in TuplePattern (fromSrcInfoPoints ss) (t:ps)
parenMinusPattern :: Parser a Token (Ident -> Pattern ())
parenMinusPattern = mkNeg <$> negNum <.> optInfixPattern <.> optTuplePattern
where mkNeg neg idt = setEndPosition (end (getSrcSpan idt)) neg
parenTuplePattern :: Parser a Token (Pattern ())
parenTuplePattern = pattern0 <**> optTuplePattern
`opt` ConstructorPattern NoSpanInfo () qUnitId []
-- ---------------------------------------------------------------------------
-- Expressions
-- ---------------------------------------------------------------------------
-- condExpr ::= '|' expr0 eq expr
--
-- Note: The guard is an `expr0` instead of `expr` since conditional expressions
-- may also occur in case expressions, and an expression like
-- @
-- case a of { _ -> True :: Bool -> a }
-- @
-- can not be parsed with a limited parser lookahead.
condExpr :: Parser a Token b -> Parser a Token (CondExpr ())
condExpr eq = mkCondExpr <$> spanPosition <*-> bar <*> expr0
<*> spanPosition <*-> eq <*> expr
where mkCondExpr sp1 e1 sp2 e2 = updateEndPos $
CondExpr (SpanInfo sp1 [sp1, sp2]) e1 e2
-- expr ::= expr0 [ '::' type0 ]
expr :: Parser a Token (Expression ())
expr = expr0 <??> (mkTyped <$> tokenSpan DoubleColon <*> qualType)
where mkTyped sp qty e = updateEndPos $ setSrcSpan (getSrcSpan e) $
Typed (fromSrcInfoPoints [sp]) e qty
-- expr0 ::= expr1 { infixOp expr1 }
expr0 :: Parser a Token (Expression ())
expr0 = expr1 `chainr1` (mkInfixApply <$> infixOp)
where mkInfixApply op e1 e2 = InfixApply
(fromSrcSpan (combineSpans (getSrcSpan e1) (getSrcSpan e2))) e1 op e2
-- expr1 ::= - expr2 | -. expr2 | expr2
expr1 :: Parser a Token (Expression ())
expr1 = mkUnaryMinus <$> minus <*> expr2
<|> expr2
where mkUnaryMinus idt ex =
let p = getPosition idt
e = getSrcSpanEnd ex
f = file p
in UnaryMinus (SpanInfo (Span f p e) [Span f p (incr p 1)]) ex
-- expr2 ::= lambdaExpr | letExpr | doExpr | ifExpr | caseExpr | expr3
expr2 :: Parser a Token (Expression ())
expr2 = choice [ lambdaExpr, letExpr, doExpr, ifExpr, caseExpr
, foldl1 mkApply <$> many1 expr3
]
where mkApply e1 e2 = updateEndPos $ Apply (fromSrcSpan (getSrcSpan e1)) e1 e2
expr3 :: Parser a Token (Expression ())
expr3 = foldl mkRecordUpdate <$> expr4 <*> many recUpdate
where recUpdate = layoutOff <-*> bracesSp (field expr0 `sepBy1Sp` comma)
mkRecordUpdate e ((fs,ss), sp1, sp2) = updateEndPos $
setSrcInfoPoints (sp1 : (ss ++ [sp2])) $
RecordUpdate (fromSrcSpan (getSrcSpan e)) e fs
expr4 :: Parser a Token (Expression ())
expr4 = choice
[constant, anonFreeVariable, variable, parenExpr, listExpr]
constant :: Parser a Token (Expression ())
constant = mkLiteral <$> spanPosition <*> literal
where mkLiteral sp = Literal (fromSrcSpan sp) ()
anonFreeVariable :: Parser a Token (Expression ())
anonFreeVariable = (\ p v -> mkVariable $ qualify $ addPositionIdent p v)
<$> position <*> anonIdent
where mkVariable qid = Variable (fromSrcSpan (getSrcSpan qid)) () qid
variable :: Parser a Token (Expression ())
variable = qFunId <**> optRecord
where optRecord = mkRecord <$> fieldsSp expr0 `opt` mkVariable
mkRecord ((fs,ss), sp1, sp2) qid =
let spi = SpanInfo (getSrcSpan qid) (sp1 : (ss ++ [sp2]))
in updateEndPos $ Record spi () qid fs
mkVariable qid = Variable (fromSrcSpan (getSrcSpan qid)) () qid
parenExpr :: Parser a Token (Expression ())
parenExpr = fmap updateSpanWithBrackets (parensSp pExpr)
where
pExpr = minus <**> minusOrTuple
<|> mkConstructor () <$> tupleCommas
<|> leftSectionOrTuple <\> minus
<|> opOrRightSection <\> minus
`opt` Constructor (fromSrcInfoPoints []) () qUnitId
minusOrTuple = mkUnaryMinus <$> expr1 <.> infixOrTuple
`opt` mkVariable . qualify
leftSectionOrTuple = expr1 <**> infixOrTuple
infixOrTuple = ($ updateEndPos) <$> infixOrTuple'
infixOrTuple' = infixOp <**> leftSectionOrExp
<|> (.) <$> (optType <.> tupleExpr)
leftSectionOrExp = expr1 <**> (infixApp <$> infixOrTuple')
`opt` leftSection
optType = mkTyped <$> tokenSpan DoubleColon <*> qualType `opt` id
tupleExpr = mkTuple <$> many1 ((,) <$> tokenSpan Comma <*> expr)
`opt` Paren NoSpanInfo
opOrRightSection = qFunSym <**> optRightSection
<|> colon <**> optCRightSection
<|> infixOp <\> colon <\> qFunSym <**> rightSection
optRightSection = (. InfixOp () ) <$> rightSection
`opt` Variable NoSpanInfo ()
optCRightSection = (. InfixConstr ()) <$> rightSection
`opt` Constructor NoSpanInfo ()
rightSection = mkRightSection <$> expr0
infixApp f e2 op g e1 = f (g . mkInfixApply e1 op) e2
leftSection op f e = mkLeftSection (f e) op
mkTuple ses e = let (ss,es) = unzip ses
in Tuple (fromSrcInfoPoints ss) (e:es)
mkConstructor = Constructor NoSpanInfo
mkTyped sp ty e = Typed (fromSrcInfoPoints [sp]) e ty
mkRightSection = flip (RightSection NoSpanInfo)
mkLeftSection = LeftSection NoSpanInfo
mkInfixApply e1 op e2 = InfixApply (fromSrcSpan
(combineSpans (getSrcSpan e1) (getSrcSpan e2))) e1 op e2
mkVariable = Variable NoSpanInfo ()
mkUnaryMinus ex idt =
let p = getPosition idt
e = getSrcSpanEnd ex
f = file p
in UnaryMinus (SpanInfo (Span f p e) [Span f p (incr p 1)]) ex
infixOp :: Parser a Token (InfixOp ())
infixOp = InfixOp () <$> qfunop <|> InfixConstr () <$> colon
listExpr :: Parser a Token (Expression ())
listExpr = updateSpanWithBrackets <$>
bracketsSp (elements `opt` List (fromSrcInfoPoints []) () [])
where
elements = expr <**> rest
rest = comprehension
<|> enumeration mkEnumFromTo mkEnumFrom
<|> (tokenSpan Comma <**> (expr <**>(
enumeration mkEnumFromThenTo mkEnumFromThen
<|> list <$> many ((,) <$> tokenSpan Comma <*> expr)))
`opt` (\ e -> List (fromSrcInfoPoints []) () [e]))
comprehension = mkListCompr <$> tokenSpan Bar <*> quals
enumeration enumTo enum =
tokenSpan DotDot <**> (enumTo <$> expr `opt` enum)
mkEnumFrom sp =
EnumFrom (fromSrcInfoPoints [sp])
mkEnumFromTo e1 sp e2 =
EnumFromTo (fromSrcInfoPoints [sp]) e2 e1
mkEnumFromThen sp1 e1 sp2 e2 =
EnumFromThen (fromSrcInfoPoints [sp2,sp1]) e2 e1
mkEnumFromThenTo e1 sp1 e2 sp2 e3 =
EnumFromThenTo (fromSrcInfoPoints [sp2,sp1]) e3 e2 e1
mkListCompr sp qu e = ListCompr (fromSrcInfoPoints [sp]) e qu
list xs e2 sp e1 = let (ss, es) = unzip xs
in List (fromSrcInfoPoints (sp:ss)) () (e1:e2:es)
updateSpanWithBrackets :: HasSpanInfo a => (a, Span, Span) -> a
updateSpanWithBrackets (ex, sp1, sp2) =
let ss = getSrcInfoPoints ex
s = getPosition sp1
e = end sp2
f = file s
spi = SpanInfo (Span f s e) (sp1 : (ss ++ [sp2]))
in setSpanInfo spi ex
lambdaExpr :: Parser a Token (Expression ())
lambdaExpr = mkLambda <$> tokenSpan Backslash <*> many1 pattern2
<*> spanPosition <*-> expectRightArrow
<*> expr
where mkLambda sp1 ps sp2 e = updateEndPos $ Lambda (SpanInfo sp1 [sp1, sp2]) ps e
letExpr :: Parser a Token (Expression ())
letExpr = mkLet <$> tokenSpan KW_let <*> layout valueDecls
<*> (tokenSpan KW_in <?> "in expected") <*> expr
where mkLet sp1 ds sp2 e = updateEndPos $ Let (SpanInfo sp1 [sp1, sp2]) ds e
doExpr :: Parser a Token (Expression ())
doExpr = mkDo <$> tokenSpan KW_do <*> layout stmts
where mkDo sp (stms, ex) = updateEndPos $ Do (SpanInfo sp [sp]) stms ex
ifExpr :: Parser a Token (Expression ())
ifExpr = mkIfThenElse
<$> tokenSpan KW_if <*> expr
<*> (tokenSpan KW_then <?> "then expected") <*> expr
<*> (tokenSpan KW_else <?> "else expected") <*> expr
where mkIfThenElse sp1 e1 sp2 e2 sp3 e3 = updateEndPos $
IfThenElse (SpanInfo sp1 [sp1, sp2, sp3]) e1 e2 e3
caseExpr :: Parser a Token (Expression ())
caseExpr = (mkCase Flex <$> tokenSpan KW_fcase
<|> mkCase Rigid <$> tokenSpan KW_case)
<*> expr
<*> (tokenSpan KW_of <?> "of expected")
<*> layout (alt `sepBy1` semicolon)
where mkCase ct sp1 e sp2 = updateEndPos . Case (SpanInfo sp1 [sp1, sp2]) ct e
alt :: Parser a Token (Alt ())
alt = mkAlt <$> spanPosition <*> pattern0
<*> spanPosition <*> rhs expectRightArrow
where mkAlt sp1 p sp2 = updateEndPos . Alt (SpanInfo sp1 [sp2]) p
fieldsSp :: Parser a Token b -> Parser a Token (([Field b], [Span]), Span, Span)
fieldsSp p = layoutOff <-*> bracesSp (field p `sepBySp` comma)
field :: Parser a Token b -> Parser a Token (Field b)
field p = mkField <$> spanPosition <*> qfun
<*> spanPosition <*-> expectEquals
<*> p
where mkField sp1 q sp2 = updateEndPos . Field (SpanInfo sp1 [sp2]) q
-- ---------------------------------------------------------------------------
-- \paragraph{Statements in list comprehensions and \texttt{do} expressions}
-- Parsing statements is a bit difficult because the syntax of patterns
-- and expressions largely overlaps. The parser will first try to
-- recognize the prefix \emph{Pattern}~\texttt{<-} of a binding statement
-- and if this fails fall back into parsing an expression statement. In
-- addition, we have to be prepared that the sequence
-- \texttt{let}~\emph{LocalDefs} can be either a let-statement or the
-- prefix of a let expression.
-- ---------------------------------------------------------------------------
stmts :: Parser a Token ([Statement ()], Expression ())
stmts = stmt reqStmts optStmts
reqStmts :: Parser a Token (Statement () -> ([Statement ()], Expression ()))
reqStmts = (\ (sts, e) st -> (st : sts, e)) <$-> semicolon <*> stmts
optStmts :: Parser a Token (Expression () -> ([Statement ()], Expression ()))
optStmts = succeed mkStmtExpr <.> reqStmts `opt` (,) []
where mkStmtExpr e = StmtExpr (fromSrcSpan (getSrcSpan e)) e
quals :: Parser a Token [Statement ()]
quals = stmt (succeed id) (succeed mkStmtExpr) `sepBy1` comma
where mkStmtExpr e = StmtExpr (fromSrcSpan (getSrcSpan e)) e
stmt :: Parser a Token (Statement () -> b)
-> Parser a Token (Expression () -> b) -> Parser a Token b
stmt stmtCont exprCont = letStmt stmtCont exprCont
<|> exprOrBindStmt stmtCont exprCont
letStmt :: Parser a Token (Statement () -> b)
-> Parser a Token (Expression () -> b) -> Parser a Token b
letStmt stmtCont exprCont = ((,) <$> tokenSpan KW_let <*> layout valueDecls)
<**> optExpr
where optExpr = let' <$> tokenSpan KW_in <*> expr <.> exprCont
<|> succeed stmtDecl' <.> stmtCont
where
let' sp1 e (sp2, ds) = updateEndPos $
Let (SpanInfo sp2 [sp2, sp1]) ds e
stmtDecl' (sp2, ds) = updateEndPos $
StmtDecl (SpanInfo sp2 [sp2]) ds
exprOrBindStmt :: Parser a Token (Statement () -> b)
-> Parser a Token (Expression () -> b)
-> Parser a Token b
exprOrBindStmt stmtCont exprCont =
stmtBind' <$> spanPosition <*> pattern0 <*> tokenSpan LeftArrow <*> expr
<**> stmtCont
<|?> expr <\> token KW_let <**> exprCont
where
stmtBind' sp1 p sp2 e = updateEndPos $
StmtBind (SpanInfo sp1 [sp2]) p e
-- ---------------------------------------------------------------------------
-- Goals
-- ---------------------------------------------------------------------------
goal :: Parser a Token (Goal ())
goal = mkGoal <$> spanPosition <*> expr <*> spanPosition <*> localDecls
where mkGoal sp1 ex sp2 ds = updateEndPos $
Goal (SpanInfo sp1 [sp2]) ex ds
-- ---------------------------------------------------------------------------
-- Literals, identifiers, and (infix) operators
-- ---------------------------------------------------------------------------
char :: Parser a Token Char
char = cval <$> token CharTok
float :: Parser a Token Double
float = fval <$> token FloatTok
int :: Parser a Token Int
int = fromInteger <$> integer
integer :: Parser a Token Integer
integer = ival <$> token IntTok
string :: Parser a Token String
string = sval <$> token StringTok
tycon :: Parser a Token Ident
tycon = conId
anonOrTyvar :: Parser a Token Ident
anonOrTyvar = anonIdent <|> tyvar
tyvar :: Parser a Token Ident
tyvar = varId
clsvar :: Parser a Token Ident
clsvar = tyvar
tycls :: Parser a Token Ident
tycls = conId
qtycls :: Parser a Token QualIdent
qtycls = qConId
qtycon :: Parser a Token QualIdent
qtycon = qConId
varId :: Parser a Token Ident
varId = ident
funId :: Parser a Token Ident
funId = ident
conId :: Parser a Token Ident
conId = ident
funSym :: Parser a Token Ident
funSym = sym
conSym :: Parser a Token Ident
conSym = sym
modIdent :: Parser a Token ModuleIdent
modIdent = mIdent <?> "module name expected"
var :: Parser a Token Ident
var = varId <|> updateSpanWithBrackets
<$> parensSp (funSym <?> "operator symbol expected")
fun :: Parser a Token Ident
fun = funId <|> updateSpanWithBrackets
<$> parensSp (funSym <?> "operator symbol expected")
con :: Parser a Token Ident
con = conId <|> updateSpanWithBrackets
<$> parensSp (conSym <?> "operator symbol expected")
funop :: Parser a Token Ident
funop = funSym <|> updateSpanWithBrackets
<$> backquotesSp (funId <?> "operator name expected")
conop :: Parser a Token Ident
conop = conSym <|> updateSpanWithBrackets
<$> backquotesSp (conId <?> "operator name expected")
qFunId :: Parser a Token QualIdent
qFunId = qIdent
qConId :: Parser a Token QualIdent
qConId = qIdent
qFunSym :: Parser a Token QualIdent
qFunSym = qSym
qConSym :: Parser a Token QualIdent
qConSym = qSym
gConSym :: Parser a Token QualIdent
gConSym = qConSym <|> colon
qfun :: Parser a Token QualIdent
qfun = qFunId <|> updateSpanWithBrackets
<$> parensSp (qFunSym <?> "operator symbol expected")
qfunop :: Parser a Token QualIdent
qfunop = qFunSym <|> updateSpanWithBrackets
<$> backquotesSp (qFunId <?> "operator name expected")
gconop :: Parser a Token QualIdent
gconop = gConSym <|> updateSpanWithBrackets
<$> backquotesSp (qConId <?> "operator name expected")
anonIdent :: Parser a Token Ident
anonIdent = ((`setSpanInfo` anonId) . fromSrcSpanBoth) <$> tokenSpan Underscore
mIdent :: Parser a Token ModuleIdent
mIdent = mIdent' <$> spanPosition <*>
tokens [Id,QId,Id_as,Id_ccall,Id_forall,Id_hiding,
Id_interface,Id_primitive,Id_qualified]
where mIdent' sp a = ModuleIdent (fromSrcSpanBoth sp) (modulVal a ++ [sval a])
ident :: Parser a Token Ident
ident = (\ sp t -> setSpanInfo (fromSrcSpanBoth sp) (mkIdent (sval t)))
<$> spanPosition <*> tokens [Id,Id_as,Id_ccall,Id_forall,Id_hiding,
Id_interface,Id_primitive,Id_qualified]
qIdent :: Parser a Token QualIdent
qIdent = qualify <$> ident <|> qIdentWith QId
sym :: Parser a Token Ident
sym = (\ sp t -> setSpanInfo (fromSrcSpanBoth sp) (mkIdent (sval t)))
<$> spanPosition <*> tokens [Sym, SymDot, SymMinus, SymStar]
qSym :: Parser a Token QualIdent
qSym = qualify <$> sym <|> qIdentWith QSym
qIdentWith :: Category -> Parser a Token QualIdent
qIdentWith c = mkQIdent <$> spanPosition <*> token c
where mkQIdent :: Span -> Attributes -> QualIdent
mkQIdent sp a =
let mid = ModuleIdent (fromSrcSpan sp) (modulVal a)
p = incr (getPosition sp) (mIdentLength mid - 1)
mid' = setEndPosition p mid
idt = setSrcSpan sp $ mkIdent (sval a)
idt' = setPosition (incr p 1) idt
in QualIdent (fromSrcSpanBoth sp) (Just mid') idt'
colon :: Parser a Token QualIdent
colon = (qualify . (`setSpanInfo` consId) . fromSrcSpanBoth) <$> tokenSpan Colon
minus :: Parser a Token Ident
minus = ((`setSpanInfo` minusId) . fromSrcSpanBoth) <$> tokenSpan SymMinus
tupleCommas :: Parser a Token QualIdent
tupleCommas = (\ sp ss -> qualify $ updateEndPos $ setSpanInfo (SpanInfo sp ss)
$ tupleId $ succ $ length ss)
<$> spanPosition <*> many1 (tokenSpan Comma)
-- ---------------------------------------------------------------------------
-- Layout
-- ---------------------------------------------------------------------------
-- |This function starts a new layout block but does not wait for its end.
-- This is only used for parsing the module header.
startLayout :: Parser a Token b -> Parser a Token b
startLayout p = layoutOff <-*> leftBrace <-*> p
<|> layoutOn <-*> p
layout :: Parser a Token b -> Parser a Token b
layout p = layoutOff <-*> braces p
<|> layoutOn <-*> p <*-> (token VRightBrace <|> layoutEnd)
-- ---------------------------------------------------------------------------
-- Bracket combinators
-- ---------------------------------------------------------------------------
braces :: Parser a Token b -> Parser a Token b
braces p = between leftBrace p rightBrace
bracesSp :: Parser a Token b -> Parser a Token (b, Span, Span)
bracesSp p = (\sp1 b sp2 -> (b, sp1, sp2))
<$> tokenSpan LeftBrace
<*> p
<*> tokenSpan RightBrace
bracketsSp :: Parser a Token b -> Parser a Token (b, Span, Span)
bracketsSp p = (\sp1 b sp2 -> (b, sp1, sp2))
<$> tokenSpan LeftBracket
<*> p
<*> tokenSpan RightBracket
parens :: Parser a Token b -> Parser a Token b
parens p = between leftParen p rightParen
parensSp :: Parser a Token b -> Parser a Token (b, Span, Span)
parensSp p = (\sp1 b sp2 -> (b, sp1, sp2))
<$> tokenSpan LeftParen
<*> p
<*> tokenSpan RightParen
backquotesSp :: Parser a Token b -> Parser a Token (b, Span, Span)
backquotesSp p = (\sp1 b sp2 -> (b, sp1, sp2))
<$> tokenSpan Backquote
<*> p
<*> spanPosition <*-> expectBackquote
-- ---------------------------------------------------------------------------
-- Simple token parsers
-- ---------------------------------------------------------------------------
token :: Category -> Parser a Token Attributes
token c = attr <$> symbol (Token c NoAttributes)
where attr (Token _ a) = a
tokens :: [Category] -> Parser a Token Attributes
tokens = foldr1 (<|>) . map token
tokenPos :: Category -> Parser a Token Position
tokenPos c = position <*-> token c
tokenSpan :: Category -> Parser a Token Span
tokenSpan c = spanPosition <*-> token c
tokenOps :: [(Category, b)] -> Parser a Token b
tokenOps cs = ops [(Token c NoAttributes, x) | (c, x) <- cs]
comma :: Parser a Token Attributes
comma = token Comma
semicolon :: Parser a Token Attributes
semicolon = token Semicolon <|> token VSemicolon
bar :: Parser a Token Attributes
bar = token Bar
equals :: Parser a Token Attributes
equals = token Equals
expectEquals :: Parser a Token Attributes
expectEquals = equals <?> "= expected"
expectWhere :: Parser a Token Attributes
expectWhere = token KW_where <?> "where expected"
expectRightArrow :: Parser a Token Attributes
expectRightArrow = token RightArrow <?> "-> expected"
backquote :: Parser a Token Attributes
backquote = token Backquote
expectBackquote :: Parser a Token Attributes
expectBackquote = backquote <?> "backquote (`) expected"
leftParen :: Parser a Token Attributes
leftParen = token LeftParen
rightParen :: Parser a Token Attributes
rightParen = token RightParen
leftBrace :: Parser a Token Attributes
leftBrace = token LeftBrace
rightBrace :: Parser a Token Attributes
rightBrace = token RightBrace