module Curry.Syntax.Parser
( parseSource, parseHeader, parsePragmas, parseInterface, parseGoal
) where
import Curry.Base.Ident
import Curry.Base.Monad (CYM)
import Curry.Base.Position (Position)
import Curry.Base.LLParseComb
import Curry.Syntax.Extension
import Curry.Syntax.Lexer (Token (..), Category (..), Attributes (..), lexer)
import Curry.Syntax.Type
parseSource :: FilePath -> String -> CYM (Module ())
parseSource fn
= fullParser (uncurry <$> moduleHeader <*> layout moduleDecls) lexer fn
parsePragmas :: FilePath -> String -> CYM (Module ())
parsePragmas
= prefixParser ((\ps -> Module ps mainMIdent Nothing [] []) <$> modulePragmas)
lexer
parseHeader :: FilePath -> String -> CYM (Module ())
parseHeader
= prefixParser (moduleHeader <*> startLayout importDecls <*> succeed []) lexer
where importDecls = many (importDecl <*-> many semicolon)
parseInterface :: FilePath -> String -> CYM Interface
parseInterface = fullParser interface lexer
parseGoal :: String -> CYM (Goal ())
parseGoal = fullParser goal lexer ""
moduleHeader :: Parser a Token ([ImportDecl] -> [Decl b] -> Module b)
moduleHeader = (\ps (m, es) -> Module ps m es)
<$> modulePragmas
<*> header
where header = (,) <$-> token KW_module <*> modIdent
<*> option exportSpec
<*-> expectWhere
`opt` (mainMIdent, Nothing)
modulePragmas :: Parser a Token [ModulePragma]
modulePragmas = many (languagePragma <|> optionsPragma)
languagePragma :: Parser a Token ModulePragma
languagePragma = LanguagePragma
<$> tokenPos PragmaLanguage
<*> (languageExtension `sepBy1` comma)
<*-> token PragmaEnd
where languageExtension = classifyExtension <$> ident
optionsPragma :: Parser a Token ModulePragma
optionsPragma = (\pos a -> OptionsPragma pos (fmap classifyTool $ toolVal a)
(toolArgs a))
<$> position
<*> token PragmaOptions
<*-> token PragmaEnd
exportSpec :: Parser a Token ExportSpec
exportSpec = Exporting <$> position <*> parens (export `sepBy` comma)
export :: Parser a Token Export
export = qtycon <**> (parens spec `opt` Export)
<|> Export <$> qfun <\> qtycon
<|> ExportModule <$-> token KW_module <*> modIdent
where spec = ExportTypeAll <$-> token DotDot
<|> flip ExportTypeWith <$> con `sepBy` comma
moduleDecls :: Parser a Token ([ImportDecl], [Decl ()])
moduleDecls = impDecl <$> importDecl
<*> (semicolon <-*> moduleDecls `opt` ([], []))
<|> (,) [] <$> topDecls
where impDecl i (is, ds) = (i:is ,ds)
importDecl :: Parser a Token ImportDecl
importDecl = flip . ImportDecl
<$> tokenPos KW_import
<*> flag (token Id_qualified)
<*> modIdent
<*> option (token Id_as <-*> modIdent)
<*> option importSpec
importSpec :: Parser a Token ImportSpec
importSpec = position
<**> (Hiding <$-> token Id_hiding `opt` Importing)
<*> parens (spec `sepBy` comma)
where
spec = tycon <**> (parens constrs `opt` Import)
<|> Import <$> fun <\> tycon
constrs = ImportTypeAll <$-> token DotDot
<|> flip ImportTypeWith <$> con `sepBy` comma
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)
iImportDecl :: Parser a Token IImportDecl
iImportDecl = IImportDecl <$> tokenPos KW_import <*> modIdent
intfDecl :: Parser a Token IDecl
intfDecl = choice [ iInfixDecl, iHidingDecl, iDataDecl, iNewtypeDecl
, iTypeDecl , iFunctionDecl <\> token Id_hiding
, iClassDecl, iInstanceDecl ]
iInfixDecl :: Parser a Token IDecl
iInfixDecl = infixDeclLhs IInfixDecl <*> integer <*> qfunop
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
iDataDecl :: Parser a Token IDecl
iDataDecl = iTypeDeclLhs IDataDecl KW_data <*> constrs <*> iHiddenPragma
where constrs = equals <-*> constrDecl `sepBy1` bar `opt` []
iNewtypeDecl :: Parser a Token IDecl
iNewtypeDecl = iTypeDeclLhs INewtypeDecl KW_newtype
<*-> equals <*> newConstrDecl <*> iHiddenPragma
iTypeDecl :: Parser a Token IDecl
iTypeDecl = iTypeDeclLhs ITypeDecl KW_type
<*-> equals <*> type0
iHiddenPragma :: Parser a Token [Ident]
iHiddenPragma = token PragmaHiding
<-*> (con `sepBy` comma)
<*-> token PragmaEnd
`opt` []
iFunctionDecl :: Parser a Token IDecl
iFunctionDecl = IFunctionDecl <$> position <*> qfun <*> option iMethodPragma
<*> arity <*-> token DoubleColon <*> qualType
iMethodPragma :: Parser a Token Ident
iMethodPragma = token PragmaMethod <-*> clsvar <*-> token PragmaEnd
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
iClassDecl :: Parser a Token IDecl
iClassDecl = (\(p, cx, (qcls, k), tv) -> IClassDecl p cx qcls k tv)
<$> classInstHead KW_class (withKind qtycls) clsvar
<*> braces (iMethod `sepBy` semicolon)
<*> iClassHidden
iMethod :: Parser a Token IMethodDecl
iMethod = IMethodDecl <$> position
<*> fun <*> option int <*-> token DoubleColon <*> qualType
iClassHidden :: Parser a Token [Ident]
iClassHidden = token PragmaHiding
<-*> (fun `sepBy` comma)
<*-> token PragmaEnd
`opt` []
iInstanceDecl :: Parser a Token IDecl
iInstanceDecl = (\(p, cx, qcls, inst) -> IInstanceDecl p cx qcls inst)
<$> classInstHead KW_instance qtycls type2
<*> braces (iImpl `sepBy` semicolon)
<*> option iModulePragma
iImpl :: Parser a Token IMethodImpl
iImpl = (,) <$> fun <*> arity
iModulePragma :: Parser a Token ModuleIdent
iModulePragma = token PragmaModule <-*> modIdent <*-> token PragmaEnd
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 = typeDeclLhs DataDecl KW_data <*> constrs <*> deriv
where constrs = equals <-*> constrDecl `sepBy1` bar `opt` []
externalDataDecl :: Parser a Token (Decl ())
externalDataDecl = decl <$> tokenPos KW_external <*> typeDeclLhs (,,) KW_data
where decl p (_, tc, tvs) = ExternalDataDecl p tc tvs
newtypeDecl :: Parser a Token (Decl ())
newtypeDecl = typeDeclLhs NewtypeDecl KW_newtype <*-> equals <*> newConstrDecl
<*> deriv
typeDecl :: Parser a Token (Decl ())
typeDecl = typeDeclLhs TypeDecl KW_type <*-> equals <*> type0
typeDeclLhs :: (Position -> Ident -> [Ident] -> a) -> Category
-> Parser b Token a
typeDeclLhs f kw = f <$> tokenPos kw <*> tycon <*> many anonOrTyvar
constrDecl :: Parser a Token ConstrDecl
constrDecl = position <**> (existVars <**> optContext (flip ($)) constr)
where
constr = conId <**> identDecl
<|> leftParen <-*> parenDecl
<|> type1 <\> conId <\> leftParen <**> opDecl
identDecl = many type2 <**> (conType <$> opDecl `opt` conDecl)
<|> recDecl <$> recFields
parenDecl = conOpDeclPrefix
<$> conSym <*-> rightParen <*> type2 <*> type2
<|> tupleType <*-> rightParen <**> opDecl
opDecl = conOpDecl <$> conop <*> type1
recFields = layoutOff <-*> braces
(fieldDecl `sepBy` comma)
conType f tys c = f $ apply (ConstructorType $ qualify c) tys
apply = foldl ApplyType
conDecl tys c cx tvs p = ConstrDecl p tvs cx c tys
conOpDecl op ty2 ty1 cx tvs p = ConOpDecl p tvs cx ty1 op ty2
conOpDeclPrefix op ty1 ty2 cx tvs p = ConOpDecl p tvs cx ty1 op ty2
recDecl fs c cx tvs p = RecordDecl p tvs cx c fs
fieldDecl :: Parser a Token FieldDecl
fieldDecl = FieldDecl <$> position <*> labels <*-> token DoubleColon <*> type0
where labels = fun `sepBy1` comma
newConstrDecl :: Parser a Token NewConstrDecl
newConstrDecl = position <**> (con <**> newConstr)
where newConstr = newConDecl <$> type2
<|> newRecDecl <$> newFieldDecl
newConDecl ty c p = NewConstrDecl p c ty
newRecDecl fld c p = NewRecordDecl p c fld
newFieldDecl :: Parser a Token (Ident, TypeExpr)
newFieldDecl = layoutOff <-*> braces labelDecl
where labelDecl = (,) <$> fun <*-> token DoubleColon <*> type0
deriv :: Parser a Token [QualIdent]
deriv = token KW_deriving <-*> classes `opt` []
where classes = return <$> qtycls
<|> parens (qtycls `sepBy` comma)
existVars :: Parser a Token [Ident]
existVars = token Id_forall <-*> many1 tyvar <*-> dot `opt` []
functionDecl :: Parser a Token (Decl ())
functionDecl = position <**> decl
where decl = fun `sepBy1` comma <**> funListDecl <|?> funRule
funRule :: Parser a Token (Position -> Decl ())
funRule = mkFunDecl <$> lhs <*> declRhs
where lhs = (\f -> (f, FunLhs f [])) <$> fun <|?> funLhs
funListDecl :: Parser a Token ([Ident] -> Position -> Decl ())
funListDecl = typeSig
<|> flip ExternalDecl . map (Var ()) <$-> token KW_external
typeSig :: Parser a Token ([Ident] -> Position -> Decl ())
typeSig = sig <$-> token DoubleColon <*> qualType
where sig qty vs p = TypeSig p vs qty
mkFunDecl :: (Ident, Lhs ()) -> Rhs () -> Position -> Decl ()
mkFunDecl (f, lhs) rhs' p = FunctionDecl p () f [Equation p lhs rhs']
funLhs :: Parser a Token (Ident, Lhs ())
funLhs = mkFunLhs <$> fun <*> many1 pattern2
<|?> flip ($ id) <$> pattern1 <*> opLhs
<|?> curriedLhs
where
opLhs = opLHS funSym (gConSym <\> funSym)
<|> backquote <-*> opLHS (funId <*-> expectBackquote)
(qConId <\> funId <*-> expectBackquote)
opLHS funP consP = mkOpLhs <$> funP <*> pattern0
<|> mkInfixPat <$> consP <*> pattern1 <*> opLhs
mkFunLhs f ts = (f , FunLhs f ts)
mkOpLhs op t2 f t1 = (op, OpLhs (f t1) op t2)
mkInfixPat op t2 f g t1 = f (g . InfixPattern () t1 op) t2
curriedLhs :: Parser a Token (Ident, Lhs ())
curriedLhs = apLhs <$> parens funLhs <*> many1 pattern2
where apLhs (f, lhs) ts = (f, ApLhs lhs ts)
declRhs :: Parser a Token (Rhs ())
declRhs = rhs equals
rhs :: Parser a Token b -> Parser a Token (Rhs ())
rhs eq = rhsExpr <*> localDecls
where rhsExpr = SimpleRhs <$-> eq <*> position <*> expr
<|> GuardedRhs <$> many1 (condExpr eq)
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 integer <*> funop `sepBy1` comma
infixDeclLhs :: (Position -> Infix -> a) -> Parser b Token a
infixDeclLhs f = f <$> position <*> tokenOps infixKW
where infixKW = [(KW_infix, Infix), (KW_infixl, InfixL), (KW_infixr, InfixR)]
valueDecl :: Parser a Token (Decl ())
valueDecl = position <**> decl
where
decl = var `sepBy1` comma <**> valListDecl
<|?> patOrFunDecl <$> pattern0 <*> declRhs
<|?> mkFunDecl <$> curriedLhs <*> declRhs
valListDecl = funListDecl
<|> (flip FreeDecl . map (Var ())) <$-> token KW_free
patOrFunDecl (ConstructorPattern _ c ts)
| not (isConstrId c) = mkFunDecl (f, FunLhs f ts)
where f = unqualify c
patOrFunDecl t = patOrOpDecl id t
patOrOpDecl f (InfixPattern a t1 op t2)
| isConstrId op = patOrOpDecl (f . InfixPattern a t1 op) t2
| otherwise = mkFunDecl (op', OpLhs (f t1) op' t2)
where op' = unqualify op
patOrOpDecl f t = mkPatDecl (f t)
mkPatDecl t rhs' p = PatternDecl p t rhs'
isConstrId c = c == qConsId || isQualified c || isQTupleId c
defaultDecl :: Parser a Token (Decl ())
defaultDecl = DefaultDecl <$> position <*-> token KW_default
<*> parens (type0 `sepBy` comma)
classInstHead :: Category -> Parser a Token b -> Parser a Token c
-> Parser a Token (Position, Context, b, c)
classInstHead kw cls ty = f <$> tokenPos kw
<*> optContext (,) ((,) <$> cls <*> ty)
where f p (cx, (cls', ty')) = (p, cx, cls', ty')
classDecl :: Parser a Token (Decl ())
classDecl = (\(p, cx, cls, tv) -> ClassDecl p cx cls tv)
<$> classInstHead KW_class tycls clsvar
<*> whereClause innerDecls
where
innerDecls = innerDecl `sepBy` semicolon
innerDecl = foldr1 (<|?>) [ position <**> (fun `sepBy1` comma <**> typeSig)
, position <**> funRule
]
instanceDecl :: Parser a Token (Decl ())
instanceDecl = (\(p, cx, qcls, inst) -> InstanceDecl p cx qcls inst)
<$> classInstHead KW_instance qtycls type2
<*> whereClause innerDecls
where
innerDecls = (position <**> funRule) `sepBy` semicolon
optContext :: (Context -> a -> b) -> Parser c Token a -> Parser c Token b
optContext f p = f <$> context <*-> token DoubleArrow <*> p
<|?> f [] <$> p
context :: Parser a Token Context
context = return <$> constraint
<|> parens (constraint `sepBy` comma)
constraint :: Parser a Token Constraint
constraint = Constraint <$> qtycls <*> conType
where varType = VariableType <$> clsvar
conType = varType
<|> parens (foldl ApplyType <$> varType <*> many1 type2)
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 :: Parser a Token KindExpr
kind0 = kind1 `chainr1` (ArrowKind <$-> token RightArrow)
kind1 :: Parser a Token KindExpr
kind1 = Star <$-> token SymStar
<|> parens kind0
qualType :: Parser a Token QualTypeExpr
qualType = optContext QualTypeExpr type0
type0 :: Parser a Token TypeExpr
type0 = type1 `chainr1` (ArrowType <$-> token RightArrow)
type1 :: Parser a Token TypeExpr
type1 = foldl1 ApplyType <$> many1 type2
type2 :: Parser a Token TypeExpr
type2 = anonType <|> identType <|> parenType <|> bracketType
anonType :: Parser a Token TypeExpr
anonType = VariableType <$> anonIdent
identType :: Parser a Token TypeExpr
identType = VariableType <$> tyvar
<|> ConstructorType <$> qtycon <\> tyvar
parenType :: Parser a Token TypeExpr
parenType = parens tupleType
tupleType :: Parser a Token TypeExpr
tupleType = type0 <**> (tuple <$> many1 (comma <-*> type0) `opt` ParenType)
<|> token RightArrow <-*> succeed (ConstructorType qArrowId)
<|> ConstructorType . qTupleId . (+1) . length <$> many1 comma
<|> succeed (ConstructorType qUnitId)
where tuple tys ty = TupleType (ty : tys)
bracketType :: Parser a Token TypeExpr
bracketType = brackets listType
listType :: Parser a Token TypeExpr
listType = ListType <$> type0 `opt` (ConstructorType qListId)
literal :: Parser a Token Literal
literal = Char <$> char
<|> Int <$> integer
<|> Float <$> float
<|> String <$> string
pattern0 :: Parser a Token (Pattern ())
pattern0 = pattern1 `chainr1` (flip (InfixPattern ()) <$> gconop)
pattern1 :: Parser a Token (Pattern ())
pattern1 = varId <**> identPattern'
<|> qConId <\> varId <**> constrPattern
<|> minus <-*> negNum
<|> leftParen <-*> parenPattern'
<|> pattern2 <\> qConId <\> leftParen
where
identPattern' = optAsRecPattern
<|> mkConsPattern qualify <$> many1 pattern2
constrPattern = mkConsPattern id <$> many1 pattern2
<|> optRecPattern
mkConsPattern f ts c = ConstructorPattern () (f c) ts
parenPattern' = minus <**> minusPattern
<|> gconPattern
<|> funSym <\> minus <*-> rightParen <**> identPattern'
<|> parenTuplePattern <\> minus <*-> rightParen
minusPattern = rightParen <-*> identPattern'
<|> parenMinusPattern <*-> rightParen
gconPattern = ConstructorPattern () <$> gconId <*-> rightParen
<*> many pattern2
pattern2 :: Parser a Token (Pattern ())
pattern2 = literalPattern <|> anonPattern <|> identPattern
<|> parenPattern <|> listPattern <|> lazyPattern
literalPattern :: Parser a Token (Pattern ())
literalPattern = LiteralPattern () <$> literal
anonPattern :: Parser a Token (Pattern ())
anonPattern = VariablePattern () <$> anonIdent
identPattern :: Parser a Token (Pattern ())
identPattern = varId <**> optAsRecPattern
<|> qConId <\> varId <**> optRecPattern
parenPattern :: Parser a Token (Pattern ())
parenPattern = leftParen <-*> parenPattern'
where
parenPattern' = minus <**> minusPattern
<|> flip (ConstructorPattern ()) [] <$> gconId <*-> rightParen
<|> funSym <\> minus <*-> rightParen <**> optAsRecPattern
<|> parenTuplePattern <\> minus <*-> rightParen
minusPattern = rightParen <-*> optAsRecPattern
<|> parenMinusPattern <*-> rightParen
listPattern :: Parser a Token (Pattern ())
listPattern = ListPattern () <$> brackets (pattern0 `sepBy` comma)
lazyPattern :: Parser a Token (Pattern ())
lazyPattern = LazyPattern <$-> token Tilde <*> pattern2
optRecPattern :: Parser a Token (QualIdent -> Pattern ())
optRecPattern = mkRecPattern <$> fields pattern0 `opt` mkConPattern
where
mkRecPattern fs c = RecordPattern () c fs
mkConPattern c = ConstructorPattern () c []
gconId :: Parser a Token QualIdent
gconId = colon <|> tupleCommas
negNum :: Parser a Token (Pattern ())
negNum = NegativePattern ()
<$> (Int <$> integer <|> Float <$> float)
optAsRecPattern :: Parser a Token (Ident -> Pattern ())
optAsRecPattern = flip AsPattern <$-> token At <*> pattern2
<|> recPattern <$> fields pattern0
`opt` VariablePattern ()
where recPattern fs v = RecordPattern () (qualify v) fs
optInfixPattern :: Parser a Token (Pattern () -> Pattern ())
optInfixPattern = mkInfixPat <$> gconop <*> pattern0
`opt` id
where mkInfixPat op t2 t1 = InfixPattern () t1 op t2
optTuplePattern :: Parser a Token (Pattern () -> Pattern ())
optTuplePattern = tuple <$> many1 (comma <-*> pattern0)
`opt` ParenPattern
where tuple ts t = TuplePattern (t:ts)
parenMinusPattern :: Parser a Token (Ident -> Pattern ())
parenMinusPattern = const <$> negNum <.> optInfixPattern <.> optTuplePattern
parenTuplePattern :: Parser a Token (Pattern ())
parenTuplePattern = pattern0 <**> optTuplePattern
`opt` ConstructorPattern () qUnitId []
condExpr :: Parser a Token b -> Parser a Token (CondExpr ())
condExpr eq = CondExpr <$> position <*-> bar <*> expr0 <*-> eq <*> expr
expr :: Parser a Token (Expression ())
expr = expr0 <??> (flip Typed <$-> token DoubleColon <*> qualType)
expr0 :: Parser a Token (Expression ())
expr0 = expr1 `chainr1` (flip InfixApply <$> infixOp)
expr1 :: Parser a Token (Expression ())
expr1 = UnaryMinus <$-> minus <*> expr2
<|> expr2
expr2 :: Parser a Token (Expression ())
expr2 = choice [ lambdaExpr, letExpr, doExpr, ifExpr, caseExpr
, foldl1 Apply <$> many1 expr3
]
expr3 :: Parser a Token (Expression ())
expr3 = foldl RecordUpdate <$> expr4 <*> many recUpdate
where recUpdate = layoutOff <-*> braces (field expr0 `sepBy1` comma)
expr4 :: Parser a Token (Expression ())
expr4 = choice
[constant, anonFreeVariable, variable, parenExpr, listExpr]
constant :: Parser a Token (Expression ())
constant = Literal () <$> literal
anonFreeVariable :: Parser a Token (Expression ())
anonFreeVariable = (\ p v -> Variable () $ qualify $ addPositionIdent p v)
<$> position <*> anonIdent
variable :: Parser a Token (Expression ())
variable = qFunId <**> optRecord
where optRecord = flip (Record ()) <$> fields expr0 `opt` Variable ()
parenExpr :: Parser a Token (Expression ())
parenExpr = parens pExpr
where
pExpr = minus <**> minusOrTuple
<|> Constructor () <$> tupleCommas
<|> leftSectionOrTuple <\> minus
<|> opOrRightSection <\> minus
`opt` Constructor () qUnitId
minusOrTuple = const . UnaryMinus <$> expr1 <.> infixOrTuple
`opt` Variable () . qualify
leftSectionOrTuple = expr1 <**> infixOrTuple
infixOrTuple = ($ id) <$> infixOrTuple'
infixOrTuple' = infixOp <**> leftSectionOrExp
<|> (.) <$> (optType <.> tupleExpr)
leftSectionOrExp = expr1 <**> (infixApp <$> infixOrTuple')
`opt` leftSection
optType = flip Typed <$-> token DoubleColon <*> qualType `opt` id
tupleExpr = tuple <$> many1 (comma <-*> expr) `opt` Paren
opOrRightSection = qFunSym <**> optRightSection
<|> colon <**> optCRightSection
<|> infixOp <\> colon <\> qFunSym <**> rightSection
optRightSection = (. InfixOp () ) <$> rightSection `opt` Variable ()
optCRightSection = (. InfixConstr ()) <$> rightSection `opt` Constructor ()
rightSection = flip RightSection <$> expr0
infixApp f e2 op g e1 = f (g . InfixApply e1 op) e2
leftSection op f e = LeftSection (f e) op
tuple es e = Tuple (e:es)
infixOp :: Parser a Token (InfixOp ())
infixOp = InfixOp () <$> qfunop <|> InfixConstr () <$> colon
listExpr :: Parser a Token (Expression ())
listExpr = brackets (elements `opt` List () [])
where
elements = expr <**> rest
rest = comprehension
<|> enumeration (flip EnumFromTo) EnumFrom
<|> comma <-*> expr <**>
(enumeration (flip3 EnumFromThenTo) (flip EnumFromThen)
<|> list <$> many (comma <-*> expr))
`opt` (\e -> List () [e])
comprehension = flip ListCompr <$-> bar <*> quals
enumeration enumTo enum =
token DotDot <-*> (enumTo <$> expr `opt` enum)
list es e2 e1 = List () (e1:e2:es)
flip3 f x y z = f z y x
lambdaExpr :: Parser a Token (Expression ())
lambdaExpr = Lambda <$-> token Backslash <*> many1 pattern2
<*-> expectRightArrow <*> expr
letExpr :: Parser a Token (Expression ())
letExpr = Let <$-> token KW_let <*> layout valueDecls
<*-> (token KW_in <?> "in expected") <*> expr
doExpr :: Parser a Token (Expression ())
doExpr = uncurry Do <$-> token KW_do <*> layout stmts
ifExpr :: Parser a Token (Expression ())
ifExpr = IfThenElse
<$-> token KW_if <*> expr
<*-> (token KW_then <?> "then expected") <*> expr
<*-> (token KW_else <?> "else expected") <*> expr
caseExpr :: Parser a Token (Expression ())
caseExpr = keyword <*> expr
<*-> (token KW_of <?> "of expected") <*> layout (alt `sepBy1` semicolon)
where keyword = Case Flex <$-> token KW_fcase
<|> Case Rigid <$-> token KW_case
alt :: Parser a Token (Alt ())
alt = Alt <$> position <*> pattern0 <*> rhs expectRightArrow
fields :: Parser a Token b -> Parser a Token [Field b]
fields p = layoutOff <-*> braces (field p `sepBy` comma)
field :: Parser a Token b -> Parser a Token (Field b)
field p = Field <$> position <*> qfun <*-> expectEquals <*> p
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 StmtExpr <.> reqStmts `opt` (,) []
quals :: Parser a Token [Statement ()]
quals = stmt (succeed id) (succeed StmtExpr) `sepBy1` comma
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 = token KW_let <-*> layout valueDecls <**> optExpr
where optExpr = flip Let <$-> token KW_in <*> expr <.> exprCont
<|> succeed StmtDecl <.> stmtCont
exprOrBindStmt :: Parser a Token (Statement () -> b)
-> Parser a Token (Expression () -> b)
-> Parser a Token b
exprOrBindStmt stmtCont exprCont =
StmtBind <$> pattern0 <*-> leftArrow <*> expr <**> stmtCont
<|?> expr <\> token KW_let <**> exprCont
goal :: Parser a Token (Goal ())
goal = Goal <$> position <*> expr <*> localDecls
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 <|> parens (funSym <?> "operator symbol expected")
fun :: Parser a Token Ident
fun = funId <|> parens (funSym <?> "operator symbol expected")
con :: Parser a Token Ident
con = conId <|> parens (conSym <?> "operator symbol expected")
funop :: Parser a Token Ident
funop = funSym <|> backquotes (funId <?> "operator name expected")
conop :: Parser a Token Ident
conop = conSym <|> backquotes (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 <|> parens (qFunSym <?> "operator symbol expected")
qfunop :: Parser a Token QualIdent
qfunop = qFunSym <|> backquotes (qFunId <?> "operator name expected")
gconop :: Parser a Token QualIdent
gconop = gConSym <|> backquotes (qConId <?> "operator name expected")
anonIdent :: Parser a Token Ident
anonIdent = (\ p -> addPositionIdent p anonId) <$> tokenPos Underscore
mIdent :: Parser a Token ModuleIdent
mIdent = mIdent' <$> position <*>
tokens [Id,QId,Id_as,Id_ccall,Id_forall,Id_hiding,
Id_interface,Id_primitive,Id_qualified]
where mIdent' p a = addPositionModuleIdent p $
mkMIdent (modulVal a ++ [sval a])
ident :: Parser a Token Ident
ident = (\ pos -> mkIdentPosition pos . sval) <$> position <*>
tokens [Id,Id_as,Id_ccall,Id_forall,Id_hiding,
Id_interface,Id_primitive,Id_qualified]
qIdent :: Parser a Token QualIdent
qIdent = qualify <$> ident
<|> mkQIdent <$> position <*> token QId
where mkQIdent p a = qualifyWith (mkMIdent (modulVal a))
(mkIdentPosition p (sval a))
sym :: Parser a Token Ident
sym = (\ pos -> mkIdentPosition pos . sval) <$> position <*>
tokens [Sym, SymDot, SymMinus, SymStar]
qSym :: Parser a Token QualIdent
qSym = qualify <$> sym <|> mkQIdent <$> position <*> token QSym
where mkQIdent p a = qualifyWith (mkMIdent (modulVal a))
(mkIdentPosition p (sval a))
colon :: Parser a Token QualIdent
colon = (\ p -> qualify $ addPositionIdent p consId) <$> tokenPos Colon
minus :: Parser a Token Ident
minus = (\ p -> addPositionIdent p minusId) <$> tokenPos SymMinus
tupleCommas :: Parser a Token QualIdent
tupleCommas = (\ p -> qualify . addPositionIdent p . tupleId . succ . length)
<$> position <*> many1 comma
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)
braces :: Parser a Token b -> Parser a Token b
braces p = between leftBrace p rightBrace
brackets :: Parser a Token b -> Parser a Token b
brackets p = between leftBracket p rightBracket
parens :: Parser a Token b -> Parser a Token b
parens p = between leftParen p rightParen
backquotes :: Parser a Token b -> Parser a Token b
backquotes p = between backquote p expectBackquote
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
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
dot :: Parser a Token Attributes
dot = token SymDot
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
leftBracket :: Parser a Token Attributes
leftBracket = token LeftBracket
rightBracket :: Parser a Token Attributes
rightBracket = token RightBracket
leftBrace :: Parser a Token Attributes
leftBrace = token LeftBrace
rightBrace :: Parser a Token Attributes
rightBrace = token RightBrace
leftArrow :: Parser a Token Attributes
leftArrow = token LeftArrow
mkIdentPosition :: Position -> String -> Ident
mkIdentPosition pos = addPositionIdent pos . mkIdent