noQuMark :: String -> AParser Token
noQuMark s = try $ asKey s << notFollowedBy (char '?')
colT, plusT, minusT, qColonT :: AParser Token
qColonT = asKey (colonS++quMark)
quColon :: AParser (Partiality, Token)
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
-- universe is just a special classId ("Type")
parseClassId :: AParser Kind
parseClassId = fmap (\c -> if showId c "" == "Type"
then Universe [posOfId c]
else ClassKind c MissingKind) classId
parseSimpleKind :: AParser Kind
parseSimpleKind = parseClassId
(cs, ps) <- kind `separatedBy` anComma
return (if isSingle cs then head cs else
Intersection cs (toPos o ps c))
return (Downset (Just i) t MissingKind
(map tokPos [o,d,j,l,p]))
parseExtKind :: AParser ExtKind
parseExtKind = do k <- parseSimpleKind
return (ExtKind k CoVar [tokPos s])
return (ExtKind k ContraVar [tokPos m])
<|> return (ExtKind k InVar [])
return (FunKind k1 k2 $ [tokPos a])
ExtKind k InVar _ -> return k
_ -> unexpected "variance of kind"
extKind :: AParser ExtKind
return (ExtKind (FunKind k1 k2 $ [tokPos a]) InVar [])
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
-- a parsed type may also be interpreted as a kind (by the mixfix analysis)
typeToken :: AParser Type
typeToken = fmap TypeToken (pToken (scanWords <|> placeS <|>
reserved (lessS : equalS : barS :
mkBraces :: AParser a -> ([a] -> [Pos] -> b)
mkBraces p c = bracketParser p oBraceT cBraceT anComma c
type TokenMode = [String]
-- [...] may contain types or ids
aToken :: TokenMode -> AParser Token
aToken b = pToken (scanQuotedChar <|> scanDotWords
<|> scanDigit <|> scanWords <|> placeS <|>
primTypeOrId, typeOrId :: AParser Type
primTypeOrId = fmap TypeToken idToken
<|> mkBraces typeOrId (BracketType Braces)
<|> mkBrackets typeOrId (BracketType Squares)
<|> bracketParser typeOrId oParenT cParenT anComma
typeOrId = do ts <- many1 primTypeOrId
let t = if isSingle ts then head ts
kindAnno :: Type -> AParser Type
kindAnno t = do c <- colT
return (KindedType t k [tokPos c])
primType, lazyType, mixType, prodType, funType :: AParser Type
<|> bracketParser parseType oParenT cParenT anComma
<|> mkBraces parseType (BracketType Braces)
<|> mkBrackets typeOrId (BracketType Squares)
lazyType = do q <- quMarkT
return (LazyType t [tokPos q])
mixType = do ts <- many1 lazyType
let t = if isSingle ts then head ts else MixfixType ts
prodType = do (ts, ps) <- mixType `separatedBy` crossT
return (if isSingle ts then head ts
else ProductType ts (map tokPos ps))
funType = do t1 <- prodType
return $ FunType t1 (fst a) t2 [snd a]
arrowT :: AParser (Arrow, Pos)
arrowT = do a <- noQuMark funS
return (FunArr, tokPos a)
return (PFunArr, tokPos a)
return (ContFunArr, tokPos a)
return (PContFunArr, tokPos a)
parseType :: AParser Type
-----------------------------------------------------------------------------
-- var decls, typevar decls, genVarDecls
-----------------------------------------------------------------------------
varDecls :: AParser [VarDecl]
varDecls = do (vs, ps) <- var `separatedBy` anComma
varDeclType :: [Var] -> [Token] -> AParser [VarDecl]
varDeclType vs ps = do c <- colT
return (makeVarDecls vs ps t (tokPos c))
makeVarDecls :: [Var] -> [Token] -> Type -> Pos -> [VarDecl]
makeVarDecls vs ps t q = zipWith (\ v p -> VarDecl v t Comma [tokPos p])
(init vs) ps ++ [VarDecl (last vs) t Other [q]]
varDeclDownSet :: [TypeId] -> [Token] -> AParser [TypeArg]
return (makeTypeVarDecls vs ps
(ExtKind (Downset Nothing t MissingKind [])
typeVarDecls :: AParser [TypeArg]
typeVarDecls = do (vs, ps) <- typeVar `separatedBy` anComma
return (makeTypeVarDecls vs ps t (tokPos c))
<|> return (makeTypeVarDecls vs ps
(ExtKind star InVar []) nullPos)
makeTypeVarDecls :: [TypeId] -> [Token] -> ExtKind -> Pos -> [TypeArg]
makeTypeVarDecls vs ps cl q =
TypeArg v cl Comma [tokPos p])
++ [TypeArg (last vs) cl Other [q]]
genVarDecls:: AParser [GenVarDecl]
genVarDecls = do (vs, ps) <- typeVar `separatedBy` anComma
fmap (map GenVarDecl) (varDeclType vs ps)
<|> fmap (map GenTypeVarDecl)
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
extTypeVar :: AParser (TypeId, Variance, Pos)
extTypeVar = do t <- restrictedVar [lessS, plusS, minusS]
return (t, CoVar, tokPos a)
return (t, ContraVar, tokPos a)
<|> return (t, InVar, nullPos)
-- relaxed restriction for funKind (products should be disallowed)
typeArgs :: AParser [TypeArg]
typeArgs = do (ts, ps) <- extTypeVar `separatedBy` anComma
if let isInVar(_, InVar, _) = True
return (makeTypeArgs ts ps [tokPos c] k)
return (makeTypeArgs ts ps [tokPos c]
return (makeTypeArgs ts ps [tokPos l]
(ExtKind (Downset Nothing t MissingKind [])
<|> return (makeTypeArgs ts ps [] (ExtKind star InVar []))
where mergeVariance k (ExtKind e InVar _) (t, v, ps) p =
TypeArg t (ExtKind e v [ps]) k p
mergeVariance k e (t, _, _) p =
zipWith (mergeVariance Comma e) (init ts)
++ [mergeVariance Other e (last ts) q]
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
singleTypeArg :: AParser TypeArg
singleTypeArg = do as <- typeArgs
_ -> unexpected "list of type arguments"
typePatternToken, primTypePatternOrId, typePatternOrId, typePatternArg
return $ TypePatternArg a $ toPos o [] p
typePatternToken = fmap TypePatternToken (pToken (scanWords <|> placeS <|>
reserved [lessS, equalS] scanSigns))
primTypePatternOrId = fmap TypePatternToken idToken
<|> mkBraces typePatternOrId (BracketTypePattern Braces)
<|> mkBrackets typePatternOrId (BracketTypePattern Squares)
typePatternOrId = do ts <- many1 primTypePatternOrId
return( if isSingle ts then head ts
else MixfixTypePattern ts)
primTypePattern, typePattern :: AParser TypePattern
primTypePattern = typePatternToken
<|> mkBraces typePattern (BracketTypePattern Braces)
<|> mkBrackets typePatternOrId (BracketTypePattern Squares)
typePattern = do ts <- many1 primTypePattern
let t = if isSingle ts then head ts
else MixfixTypePattern ts
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
-- a parsed pattern may also be interpreted as a type (by the mixfix analysis)
-- thus [ ... ] may be a mixfix-pattern, a compound list,
-- or an instantiation with types
-- special pattern needed that don't contain "->" at the top-level
-- because "->" should be recognized in case-expressions
-- flag b allows "->" in patterns
tokenPattern :: TokenMode -> AParser Pattern
tokenPattern b = fmap PatternToken (aToken b)
primPattern :: TokenMode -> AParser Pattern
primPattern b = tokenPattern b
<|> mkBraces pattern (BracketPattern Braces)
<|> mkBrackets pattern (BracketPattern Squares)
<|> bracketParser pattern oParenT cParenT anComma
mixPattern :: TokenMode -> AParser Pattern
do l <- many1 $ primPattern b
let p = if isSingle l then head l else MixfixPattern l
in typedPattern p <|> return p
typedPattern :: Pattern -> AParser Pattern
typedPattern p = do { c <- colT
; return (TypedPattern p t [tokPos c])
asPattern :: TokenMode -> AParser Pattern
return (AsPattern v t [tokPos c])
pattern :: AParser Pattern
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
-- places may follow instantiation lists
instOpId :: AParser InstOpId
instOpId = do i@(Id is cs ps) <- uninstOpId
if isPlace (last is) then return (InstOpId i [] [])
else do (ts, qs) <- option ([], [])
(mkBrackets parseType (,))
return (InstOpId (Id (is++u) cs ps) ts qs)
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
typeScheme :: AParser TypeScheme
typeScheme = do f <- forallT
(ts, cs) <- typeVarDecls `separatedBy` anSemi
TypeScheme (concat ts ++ ots) q
<|> fmap simpleTypeScheme parseType
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
tToken = pToken(scanFloat <|> scanString
<|> scanQuotedChar <|> scanDotWords
<|> reserved [ifS] scanWords
<|> reserved [barS] scanSigns
termToken :: AParser Term
termToken = fmap TermToken (asKey exEqual <|> asKey equalS <|> tToken)
<|> mkBraces term (BracketTerm Braces)
<|> mkBrackets term (BracketTerm Squares)
-- flag WithIn allows "in"-Terms
baseTerm :: TypeMode -> AParser Term
ifTerm :: TypeMode -> AParser Term
return (MixfixTerm [TermToken i, c, TermToken t, e])
<|> return (MixfixTerm [TermToken i, c])
parenTerm :: AParser Term
parenTerm = do o <- oParenT
do (ts, ps) <- option ([],[]) (term `separatedBy` anComma)
return (BracketTerm Parens ts (toPos o ps p))
partialTypeScheme :: AParser (Token, TypeScheme)
partialTypeScheme = do q <- qColonT
return (q, simpleTypeScheme
(FunType (BracketType Parens [] [tokPos q])
<|> bind (,) colT typeScheme
varTerm :: Token -> AParser Term
varTerm o = do v <- asKey varS
return (QualVar i t (toPos o [v, c] p))
qualOpName :: Token -> AParser Term
qualOpName o = do { v <- asKey opS <|> asKey functS
; (c, t) <- partialTypeScheme
; return (QualOp i t (toPos o [v, c] p))
qualPredName :: Token -> AParser Term
qualPredName o = do { v <- asKey predS
; return (QualOp i (predTypeScheme t)
data TypeMode = NoIn | WithIn
typeQual :: TypeMode -> AParser (TypeQual, Token)
typedTerm :: TypeMode -> AParser Term
return (TypedTerm t q ty [tokPos p])
mixTerm :: TypeMode -> AParser Term
do ts <- many1 $ typedTerm b
return $ if isSingle ts then head ts else MixfixTerm ts
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
forallTerm :: TypeMode -> AParser Term
(vs, ps) <- genVarDecls `separatedBy` anSemi
return (QuantifiedTerm Universal (concat vs) t
exQuant :: AParser (Quantifier, Token)
do { q <- asKey (existsS++exMark)
; return (Existential, q)
exTerm :: TypeMode -> AParser Term
; (vs, ps) <- varDecls `separatedBy` anSemi
; return (QuantifiedTerm q (map GenVarDecl (concat vs)) f
lamDot :: AParser (Partiality, Token)
lamDot = do d <- asKey (dotS++exMark) <|> asKey (cDot++exMark)
lambdaTerm :: TypeMode -> AParser Term
return (LambdaTerm pl k t (toPos l [] d))
lamPattern :: AParser [Pattern]
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
-- b1 allows "->", b2 allows "in"-Terms
patternTermPair :: TokenMode -> TypeMode -> String -> AParser ProgEq
patternTermPair b1 b2 sep =
return (ProgEq p t (tokPos s))
caseTerm :: TypeMode -> AParser Term
(ts, ps) <- patternTermPair ([funS]) b funS
return (CaseTerm t ts (map tokPos (c:o:ps)))
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
letTerm :: TypeMode -> AParser Term
(es, ps) <- patternTermPair ([equalS]) NoIn equalS
return (LetTerm es t (toPos l ps i))