|
sourcecode:
|
module CurryInterface.Parser where
import CurryInterface.Types
import Prelude hiding ( (*>), (<*), (<*>), (<$>), (<|>), many, empty, some )
import Data.List ( init, last )
import Data.Maybe ( listToMaybe )
import DetParse
--- FOR TESTING
import Debug.Trace ( trace )
-- Helper function for debugging. That is, `pTrace "fn" p` traces
-- "fn: <first line of current parser input>"
-- before applying the parser `p` to the input string.
pTrace :: String -> Parser a -> Parser a
--pTrace _ p = p
pTrace fn p = \s -> trace (fn ++ ": " ++ takeWhile (/= '\n') s) $ p s
--- A parser for the text of a Curry interface.
parseCurryInterface :: String -> Interface
parseCurryInterface txt = case parse interface txt of
Nothing -> error "Parsing failed"
Just i -> i
--parseCurryInterface _ = error "parseCurryInterface not yet implemented"
--- A parser for a Curry interface.
interface :: Parser Interface
interface =
Interface <$>
(tokenInterface *!*> moduleIdent) <*!*>
(tokenWhere *!*> tokenCurlyBracketL *!*> importDecls) <*>
(decls <*!* tokenCurlyBracketR)
--- A parser for a Module Identifier.
moduleIdent :: Parser ModuleIdent
moduleIdent = ModuleIdent <$> identList
--- A parser for a list of Import Declarations.
importDecls :: Parser [IImportDecl]
importDecls = many importDecl
--- A parser for a list of Declarations.
decls :: Parser [IDecl]
decls = parseList tokenSemicolon decl
--- A parser for an Import Declaration.
importDecl :: Parser IImportDecl
importDecl = IImportDecl <$> (tokenImport *!*> moduleIdent <* tokenSemicolon <* skipSomeWs)
--- A parser for a Declaration.
decl :: Parser IDecl
decl = choice
[ hidingDecl
, infixDecl
, dataDecl
, newtypeDecl
, typeDecl
, classDecl
, instanceDecl
, functionDecl
]
--- A parser for an Infix Declaration | Infix Arity Op
infixDecl :: Parser IDecl
infixDecl = IInfixDecl <$> iInfix <*!*> precedence <*!*> qualIdentOp
hidingDecl :: Parser IDecl
hidingDecl = tokenHiding *!*> (hidingDataDecl <!> hidingClassDecl)
--- A parser for a Hiding Data Declaration | hiding data QualIdent [KindExpr] TypeVariableList
hidingDataDecl :: Parser IDecl
hidingDataDecl =
(tokenData *!*> withOptionalKind HidingDataDecl qualIdent) <*>
(map Ident <$> typeVariableList)
--- A parser for a Hiding Class Declaration | hiding class [Context =>] QualIdent [KindExpr] TypeVariable
hidingClassDecl :: Parser IDecl
hidingClassDecl = tokenClass *!*> (case1 <|> case2)
where
case1 :: Parser IDecl
case1 = (tokenParenL *> qualIdent <* skipSomeWs) *>= f
case2 :: Parser IDecl
case2 = (qualIdent <* skipSomeWs) *>= h
f :: QualIdent -> Parser IDecl
f qi =
(HidingClassDecl [] qi <$> (Just <$> (tokenTyping *!*> kind <* tokenParenR)) <*!*> (map Ident <$> typeVariableListNE) <*?*> funDeps)
<!>
((HidingClassDecl <$> (((:) <$> (Constraint qi . unwrapApply <$> typeExpr) <*> (tokenComma *!*> parseList tokenComma constraint)) <* tokenParenR <*!* tokenDoubleArrow <* skipSomeWs) *>=
(flip withOptionalKind qualIdent)) <*!*> (map Ident <$> typeVariableListNE) <*?*> funDeps)
h :: QualIdent -> Parser IDecl
h qi = (((HidingClassDecl <$> (singleton . Constraint qi <$> typeExprs) <*!* tokenDoubleArrow <* skipSomeWs) *>=
(flip withOptionalKind qualIdent)) <*?*> (map Ident <$> typeVariableListNE) <*?*> funDeps)
<!>
(HidingClassDecl [] qi Nothing <$> (map Ident <$> typeVariableListNE) <*?*> funDeps)
--- A parser for a Data Declaration | data QualIdent [KindExpr] TypeVariableList = ConstrDeclList
dataDecl :: Parser IDecl
dataDecl =
tokenData *!*> withOptionalKind IDataDecl qualIdent <*>
(map Ident <$> typeVariableList) <*>
((skipSomeWs *> tokenEqual *!*> parseList (skipSomeWs *> tokenPipe) constrDecl) <!> yield []) <*?*>
hiddenPragma
{-
convert <$> leftSide <*!*> (tokenEqual *!*> rightSide) <*?*> pragma
where
convert :: (QualIdent, Maybe KindExpr, [Ident]) -> [ConstrDecl] -> [Ident] -> IDecl
convert (qi, mk, ids) cs ps = IDataDecl qi mk ids cs ps
leftSide :: Parser (QualIdent, Maybe KindExpr, [Ident])
leftSide =
(,,) <$> (tokenData *!*> qualIdent) <*> optional (skipSomeWs *> kind) <*> (map Ident <$> typeVariableList)
rightSide :: Parser [ConstrDecl]
rightSide = (:) <$> constrDecl <*> many (skipSomeWs *> tokenPipe *!*> constrDecl)
-}
--- A parser for a Newtype Declaration | newtype QualIdent [KindExpr] TypeVariableList = Newtype
newtypeDecl :: Parser IDecl
newtypeDecl =
tokenNewtype *!*> withOptionalKind INewtypeDecl qualIdent <*>
(map Ident <$> typeVariableList) <*!*>
(tokenEqual *!*> iNewtype) <*?*>
hiddenPragma
{-
convert <$> leftSide <*!*> (tokenEqual *!*> rightSide) <*?*> pragma
where
convert :: (QualIdent, Maybe KindExpr, [Ident]) -> NewConstrDecl -> [Ident] -> IDecl
convert (qi, mk, ids) nc ps = INewtypeDecl qi mk ids nc ps
leftSide :: Parser (QualIdent, Maybe KindExpr, [Ident])
leftSide = (,,) <$> (tokenNewtype *!*> qualIdent) <*> optional (skipSomeWs *> kind) <*> (map Ident <$> typeVariableList)
rightSide :: Parser NewConstrDecl
rightSide = iNewtype
-}
--- A parser for a Type Declaration | type QualIdent [KindExpr] TypeVariableList = TypeExpr
typeDecl :: Parser IDecl
typeDecl =
tokenType *!*> withOptionalKind ITypeDecl qualIdent <*>
(map Ident <$> typeVariableList) <*!*>
(tokenEqual *!*> typeExpr)
{-
convert <$> leftSide <*!*> (tokenEqual *!*> rightSide)
where
convert :: (QualIdent, Maybe KindExpr, [Ident]) -> TypeExpr -> IDecl
convert (qi, mk, ids) t = ITypeDecl qi mk ids t
leftSide :: Parser (QualIdent, Maybe KindExpr, [Ident])
leftSide = (,,) <$> (tokenType *!*> qualIdent) <*> optional (skipSomeWs *> kind) <*> (map Ident <$> typeVariableList)
rightSide :: Parser TypeExpr
rightSide = typeExpr
-}
--- A parser for a Function Declaration | QualIdent [MethodPragma] Arity :: QualTypeExpr
functionDecl :: Parser IDecl
functionDecl =
IFunctionDecl <$>
qualIdent <*!*>
optional (skipSomeWs *> methodPragma) <*>
arity <*!*>
(tokenTyping *!*> qualTypeExpr)
--- A parser for a Class Declaration | class [Context =>] QualIdent [KindExpr] TypeVariable \{ MethodList \} [Pragma]
classDecl :: Parser IDecl
classDecl = tokenClass *!*> (case1 <|> case2) <*?*> (tokenCurlyBracketL *!*> parseList tokenSemicolon methodDecl <*?* tokenCurlyBracketR) <*?*> hiddenPragma
where
case1 :: Parser ([IMethodDecl] -> [Ident] -> IDecl)
case1 = (tokenParenL *> qualIdent <* skipSomeWs) *>= f
case2 :: Parser ([IMethodDecl] -> [Ident] -> IDecl)
case2 = (qualIdent <* skipSomeWs) *>= h
f :: QualIdent -> Parser ([IMethodDecl] -> [Ident] -> IDecl)
f qi =
(IClassDecl [] qi <$> (Just <$> (tokenTyping *!*> kind <* tokenParenR)) <*!*> (map Ident <$> typeVariableListNE) <*!*> funDeps)
<!>
((IClassDecl <$> (((:) <$> (Constraint qi . unwrapApply <$> typeExpr) <*> (tokenComma *!*> parseList tokenComma constraint)) <* tokenParenR <*!* tokenDoubleArrow <* skipSomeWs) *>=
(flip withOptionalKind qualIdent)) <*!*> (map Ident <$> typeVariableListNE) <*!*> funDeps)
h :: QualIdent -> Parser ([IMethodDecl] -> [Ident] -> IDecl)
h qi = (((IClassDecl <$> (singleton . Constraint qi <$> typeExprs) <*!* tokenDoubleArrow <* skipSomeWs) *>=
(flip withOptionalKind qualIdent)) <*?*> (map Ident <$> typeVariableListNE) <*!*> funDeps)
<!>
(IClassDecl [] qi Nothing <$> (map Ident <$> typeVariableListNE) <*!*> funDeps)
singleton :: a -> [a]
singleton x = [x]
--- A parser for a list of functional dependencies | [| funDep {, funDep}]
funDeps :: Parser [FunDep]
funDeps = (tokenPipe *> parseList tokenComma funDep) <!> yield []
--- A parser for a functional dependency | [Ident {, Ident}] -> [Ident {, Ident}]
funDep :: Parser FunDep
funDep = FunDep <$> (skipManyWs *> idents' <*?* tokenArrow) <*?*> idents'
where
idents' = map Ident <$> parseList empty ident
--- A parser for an Instance Declaration | instance [Context =>] QualIdent InstanceType \{ MethodImplList \} [ModulePragma]
instanceDecl :: Parser IDecl
instanceDecl =
convert IInstanceDecl <$>
(tokenInstance *!*> (case1 <|> case2)) <*!*>
(tokenCurlyBracketL *!*> parseList tokenSemicolon methodImpl <*!* tokenCurlyBracketR) <*>
(optional (skipSomeWs *> modulePragma))
where
case1 :: Parser (Context, QualIdent, InstanceType)
case1 = (,,) <$> contextList <*!*> qualIdent <*!*> instanceType
case2 :: Parser (Context, QualIdent, InstanceType)
case2 = ((,) <$> qualIdent <*!*> instanceType) *>= decide
decide :: (QualIdent, InstanceType) -> Parser (Context, QualIdent, InstanceType)
decide (qi, it) =
(skipSomeWs *> tokenDoubleArrow *!*> ((,,) [Constraint qi it] <$> qualIdent <*!*> instanceType)) <!>
yield ([], qi, it)
convert :: (Context -> QualIdent -> InstanceType -> a) -> (Context, QualIdent, InstanceType) -> a
convert f (ctx, qi, it) = f ctx qi it
--- A parser for an Infix expression | {infixl | infixr | infix}
iInfix :: Parser Infix
iInfix = word "infix" *> choice [char 'l' *> yield InfixL, char 'r' *> yield InfixR, yield Infix]
--- A parser for a Precedence
precedence :: Parser Precedence
precedence = parseInt
--- A parser for an Arity
arity :: Parser Arity
arity = parseInt
--- A parser for a Qualified Identifier or Operator | [IdentList .] {Ident | Operator}
qualIdentOp :: Parser QualIdent
qualIdentOp =
QualIdent <$> (optional (moduleIdent <* tokenDot))
<*> (Ident <$> (operator <!> ident))
--- A parser for a Qualified Identifier:
--- \( [IdentList .] Operator \) | [IdentList .] Ident
qualIdent :: Parser QualIdent
qualIdent =
(tokenParenL *>
(QualIdent <$>
(optional (moduleIdent <* tokenDot)) <*> (Ident <$> operator))
<* tokenParenR)
<!> (QualIdent <$> (optional (moduleIdent <* tokenDot)) <*> (Ident <$> ident))
--- A parser for a List of Identifiers | Ident [. IdentList]
identList :: Parser [String]
identList = (:) <$> ident <*> (many (tokenDot *> ident)) <!> yield []
--- A longest-match parser for an Identifier (not operator)
ident :: Parser String
ident [] = []
ident (x:xs) | isAlpha x = let (ys,zs) = span isIdChar xs in [(x:ys,zs)]
| otherwise = []
where
isIdChar c = isDigit c || isAlpha c || c == '_' || c == '\''
--- A longest-match parser for an Operator
operator :: Parser String
operator = tokenBacktick *> ident <* tokenBacktick <!> op
where
op xs = let (ys,zs) = span (`elem` allowed) xs
in if null ys || ys `elem` exceptions then [] else [(ys,zs)]
allowed = "!#$%&*+./<=>?@\\^|-~:"
exceptions = ["..", ":", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>"]
--- A longest-match parser for a Type Variable
typeVariable :: Parser String
typeVariable [] = []
typeVariable (x:xs) | isLower x = let (ys,zs) = span isVarChar xs in [(x:ys,zs)]
| otherwise = []
where
isVarChar c = isAlpha c || isDigit c
--- A parser for a Type Variable List | TypeVariable [TypeVariableList]
typeVariableList :: Parser [String]
typeVariableList = many (skipSomeWs *> typeVariable)
--- A parser for a non-empty Type Variable List | TypeVariable [TypeVariableList]
typeVariableListNE :: Parser [String]
typeVariableListNE = some (skipManyWs *> typeVariable)
--- A parser for a Hidden Pragma | ADD SYNTAX DESCRIPTION
hiddenPragma :: Parser [Ident]
hiddenPragma =
(tokenPragmaL *!*> word "HIDING" *!*>
(map Ident <$> parseList tokenComma ident) <*!* tokenPragmaR) <!> yield []
--- A parser for a Method Pragma | ADD SYNTAX DESCRIPTION
methodPragma :: Parser Ident
methodPragma = tokenPragmaL *!*> word "METHOD" *!*> (Ident <$> ident) <*!* tokenPragmaR
--- A parser for a Module Pragma | ADD SYNTAX DESCRIPTION
modulePragma :: Parser ModuleIdent
modulePragma = tokenPragmaL *!*> word "MODULE" *!*> moduleIdent <*!* tokenPragmaR
--- A parser for a Constructor Declaration
-- Constr ::= Ident TypeVariableList
-- | Ident '{' fieldList '}'
-- | TypeExpr Op TypeExpr
constrDecl :: Parser ConstrDecl
constrDecl = (Ident <$> ident *>= decide1) <|> constrDeclOp
where
decide1 :: Ident -> Parser ConstrDecl
--decide1 i = case1 i <|> case2 i
decide1 i = (skipSomeWs *> (case1 i <!> case2 i)) <!> decide2 i []
case1 :: Ident -> Parser ConstrDecl
--case1 i = RecordDecl i <$> (skipSomeWs *> tokenCurlyBracketL *!*> parseList tokenComma fieldDecl <*!* tokenCurlyBracketR)
case1 i = RecordDecl i <$> (tokenCurlyBracketL *!*> parseList tokenComma fieldDecl <*!* tokenCurlyBracketR)
case2 :: Ident -> Parser ConstrDecl
--case2 i = many (skipSomeWs *> typeExpr) *>= decide2 i
case2 i = (:) <$> type2 <*> many (skipSomeWs *> type2) *>= decide2 i
decide2 :: Ident -> [TypeExpr] -> Parser ConstrDecl
decide2 i ts =
(ConOpDecl (foldl1 ApplyType (ConstructorType (identToQualIdent i):ts)) <$> (Ident <$> operator) <*!*> typeExpr) <!>
yield (ConstrDecl i ts)
{-
--- A parser for a simple Constructor Declaration | Ident TypeExprList
constrDeclSimple :: Parser ConstrDecl
constrDeclSimple =
(uncurry ConstrDecl) <$> parseConstructor
-}
--- A parser for an Operator Constructor Declaration | TypeExpr Op TypeExpr
constrDeclOp :: Parser ConstrDecl
constrDeclOp = ConOpDecl <$> typeExpr <*!*> (Ident <$> operator) <*!*> typeExpr
{-
--- A parser for a Record Constructor Declaration | Ident \{ FieldDeclList \}
constrDeclRecord :: Parser ConstrDecl
constrDeclRecord =
RecordDecl <$>
(Ident <$> ident) <*!*>
(
tokenCurlyBracketL *!*>
parseList tokenComma fieldDecl
<*!* tokenCurlyBracketR
)
-}
--- A parser for a Type Expression
typeExpr :: Parser TypeExpr
typeExpr = type0
typeExprs :: Parser [TypeExpr]
typeExprs = some (skipManyWs *> typeExpr)
-- type0 ::= type1 ['->' type0]
type0 :: Parser TypeExpr
type0 = convert <$> type1 <*> (optional (skipSomeWs *> tokenArrow *!*> type0))
where
convert t1 Nothing = t1
convert t1 (Just t0) = ArrowType t1 t0
-- type1 ::= [type1] type2
type1 :: Parser TypeExpr
type1 = foldl1 ApplyType <$> some (skipWhitespace *> type2)
-- type2 ::= identType | parenType | bracketType
type2 :: Parser TypeExpr
type2 = parenType <!> bracketType <!> identType
identType :: Parser TypeExpr
identType = variableType <|> constructorType
variableType :: Parser TypeExpr
variableType = VariableType <$> (Ident <$> typeVariable)
constructorType :: Parser TypeExpr
constructorType = ConstructorType <$> qualType
-- parenType ::= '(' tupleType ')' | '(' arrowType ')'
parenType :: Parser TypeExpr
parenType = tokenParenL *> (arrowType <!> tupleType) <* tokenParenR
arrowType :: Parser TypeExpr
arrowType = word "->" *> yield (ConstructorType (QualIdent Nothing (Ident "->")))
-- tupleType ::= type0
-- | type0 ',' type0 { ',' type0 }
-- |
tupleType :: Parser TypeExpr
tupleType = convert <$> parseList tokenComma type0
where
convert ts = case ts of
[t] -> ParenType t
_ -> TupleType ts
-- bracketType ::= '[' type0 ']'
bracketType :: Parser TypeExpr
--bracketType = ListType <$> ((toList <$> (tokenBracketL *> type0 <* tokenBracketR)) <|> (word "[]" *> yield []))
bracketType = ListType <$> (tokenBracketL *> (toList <$> type0 <!> yield []) <* tokenBracketR)
-- Prelude.Int -> Prelude.Int -> Prelude.Int;
-- Prelude.Show a => a -> [Prelude.Char] ;
--- A parser for a Qualified Type Expression | [Context =>] type0
qualTypeExpr :: Parser QualTypeExpr
qualTypeExpr = singleOrNoConstraint <!> multipleOrNoConstraints
where
singleOrNoConstraint :: Parser QualTypeExpr
singleOrNoConstraint =
(qualIdent *>= decide1) <!>
(tokenBracketL *> (ListType <$> (toList <$> type0 <!> yield [])) <* tokenBracketR *>= decide8)
-- starts with QualIdent, not yet sure if one constraint or not
decide1 :: QualIdent -> Parser QualTypeExpr
decide1 qi =
(skipSomeWs *>
(
(tokenArrow *!*> type0 *>= decide2 qi) <!>
(type0 *>= decide3 qi)
)
) <!>
(yield (QualTypeExpr [] (constructorOrVariable qi)))
-- starts with no constraints but with ArrowType
decide2 :: QualIdent -> TypeExpr -> Parser QualTypeExpr
decide2 qi t =
yield $ QualTypeExpr [] (ArrowType (constructorOrVariable qi) t)
-- starts with QualIdent and TypeExpr
decide3 :: QualIdent -> TypeExpr -> Parser QualTypeExpr
decide3 qi t = let t' = addPrefix (constructorOrVariable qi) t
ts = unwrapApply t in
(QualTypeExpr [Constraint qi ts] <$> (skipSomeWs *> tokenDoubleArrow *!*> type0)) <!>
(yield (QualTypeExpr [] t'))
multipleOrNoConstraints :: Parser QualTypeExpr
multipleOrNoConstraints =
tokenParenL *> (
(
tokenParenR *> (
(skipSomeWs *> tokenArrow *!*> ((QualTypeExpr [] . ArrowType (TupleType [])) <$> type0)) <!>
(yield (QualTypeExpr [] (TupleType [])))
)
) <!>
(qualIdent *>= decide4) <!>
(((type0 *>= (\t -> (yield (ParenType t) <* tokenParenR) <!> ((TupleType . (t:)) <$> (tokenComma *!*> parseList tokenComma type0 <* tokenParenR))))) *>= decide8)
)
-- starts with QualIdent, all cases still possible
decide4 :: QualIdent -> Parser QualTypeExpr
decide4 qi =
(
skipSomeWs *> (
(type0 *>= decide5 qi) <!>
(tokenArrow *!*> type0 *>= decide6 qi)
)
) <!>
(tokenComma *!*> decide7 qi)
-- starts with QualIdent and TypeExpr, all cases still possible
decide5 :: QualIdent -> TypeExpr -> Parser QualTypeExpr
decide5 qi t = let t' = addPrefix (constructorOrVariable qi) t in
--(tokenParenR *> decide8 t') <!>
case t of
ArrowType _ _ -> ((tokenParenR *> yield t') <!> (finishTupleType (tokenComma *> skipSomeWs) [t'])) *>= decide8
_ -> tokenComma *!*> decide9 [(qi, t)]
-- starts with no context, starts with an ArrowType or a TupleType starting with an ArrowType
decide6 :: QualIdent -> TypeExpr -> Parser QualTypeExpr
decide6 qi t = let t' = ArrowType (constructorOrVariable qi) t in
(tokenParenR *> decide8 t') <!>
(finishTupleType (tokenComma *> skipSomeWs) [t'] *>= decide8)
-- starts with no context, starts with tuple type, tuple starts with ConstructorType or VariableType
decide7 :: QualIdent -> Parser QualTypeExpr
decide7 qi =
finishTupleType empty [constructorOrVariable qi] *>= decide8
-- starts with no context, first part of type expression parsed, rest remains to be parsed
decide8 :: TypeExpr -> Parser QualTypeExpr
decide8 t =
(
skipSomeWs *> (
(type0 *>= (\t' -> yield (QualTypeExpr [] (ApplyType t t')))) <!>
(tokenArrow *!*> type0 *>= (\t' -> yield (QualTypeExpr [] (ArrowType t t'))))
)
) <!>
(yield (QualTypeExpr [] t))
-- starts with a comma-seperated list, not yet clear if context or not
decide9 :: [(QualIdent, TypeExpr)] -> Parser QualTypeExpr
decide9 acc = let
ts = map (\(qi, t) -> addPrefix (constructorOrVariable qi) t) acc'
acc' = reverse acc
in
(qualIdent *>= decide10 acc) <!>
(finishTupleType empty ts *>= decide8)
{-
(tokenParenR *> (
skipSomeWs *> tokenDoubleArrow *!*> (QualTypeExpr constraints <$> type0) <|>
decide8 ts
))
-}
-- starts with a comma-seperated list, current element starts with QualIdent, not yet clear if context or not
decide10 :: [(QualIdent, TypeExpr)] -> QualIdent -> Parser QualTypeExpr
decide10 acc qi = let
acc' = reverse acc
t' = constructorOrVariable qi
ts = map (\(qi', t) -> addPrefix (constructorOrVariable qi') t) acc'
in
(finishTupleType (tokenComma *> skipSomeWs) (ts ++ [t']) *>= decide8) <!>
(
skipSomeWs *> (
((tokenArrow *!*> type0) *>= (\t -> decide12 (ts ++ [ArrowType t' t]))) <!>
(type0 *>= decide11 acc qi)
)
) <!>
(tokenParenR *> decide8 (TupleType (ts ++ [t'])))
-- starts with a comma-seperated list, current element starts with QualIdent and TypeExpr, not yet clear if context or not
decide11 :: [(QualIdent, TypeExpr)] -> QualIdent -> TypeExpr -> Parser QualTypeExpr
decide11 acc qi t = let
acc' = reverse acc
t' = addPrefix (constructorOrVariable qi) t
ts = map (\(qi', t'') -> addPrefix (constructorOrVariable qi') t'') acc'
ts' = ts ++ [t']
constraints = map (uncurry ((. unwrapApply) . Constraint)) acc'
constraints' = constraints ++ [Constraint qi (unwrapApply t)]
in
case t of
ArrowType _ _ -> finishTupleType (tokenComma *> skipSomeWs) ts' *>= decide8
_ ->
tokenComma *!*> decide9 ((qi, t):acc) <!>
(
tokenParenR *> (
(QualTypeExpr constraints' <$> (skipSomeWs *> tokenDoubleArrow *!*> type0)) <|>
(decide8 (TupleType ts))
)
) <!>
(finishTupleType (tokenComma *> skipSomeWs) ts' *>= decide8)
-- starts with TupleType, tuple not yet finished to be parsed
decide12 :: [TypeExpr] -> Parser QualTypeExpr
decide12 ts =
(tokenParenR *> decide8 (TupleType ts)) <!>
(finishTupleType (tokenComma *> skipSomeWs) ts *>= decide8)
addPrefix :: TypeExpr -> TypeExpr -> TypeExpr
addPrefix p t = case t of
ApplyType t1 t2 -> ApplyType (addPrefix p t1) t2
ArrowType t1 t2 -> ArrowType (addPrefix p t1) t2
_ -> ApplyType p t
constructorOrVariable :: QualIdent -> TypeExpr
constructorOrVariable qi = case qi of
QualIdent Nothing i -> if isVariable i then VariableType i else ConstructorType qi
_ -> ConstructorType qi
isVariable :: Ident -> Bool
isVariable (Ident s) = all isLower s
finishTupleType :: Parser () -> [TypeExpr] -> Parser TypeExpr
finishTupleType p ts = p *> ((TupleType . (ts ++)) <$> (parseList tokenComma type0 <* tokenParenR))
{-
qualTypeExpr = (QualTypeExpr <$> contextList <*!*> typeExpr) <|> (qualType *>= decide1) <|> ((QualTypeExpr []) <$> typeExpr)
where
decide1 :: QualIdent -> Parser QualTypeExpr
decide1 qi = case1 qi <|> case2 qi
-- QualTypeExpr TypeVariable ... (maybe context)
case1 :: QualIdent -> Parser QualTypeExpr
case1 qi = skipSomeWs *> (Ident <$> typeVariable) *>= decide2 qi
-- QualTypeExpr ... (NOT context)
case2 :: QualIdent -> Parser QualTypeExpr
case2 qi = QualTypeExpr [] <$> arrowOrApply (ConstructorType qi)
-- QualTypeExpr TypeVariable ... (maybe context)
decide2 :: QualIdent -> Ident -> Parser QualTypeExpr
decide2 qi i = (case3 qi i) <|> (case4 qi i)
-- QualTypeExpr TypeVariable '=>' ... (context)
case3 :: QualIdent -> Ident -> Parser QualTypeExpr
case3 qi i = QualTypeExpr [Constraint qi (VariableType i)] <$> (skipSomeWs *> tokenDoubleArrow *!*> typeExpr)
-- QualTypeExpr TypeVariable ... (no context)
case4 :: QualIdent -> Ident -> Parser QualTypeExpr
case4 qi i = QualTypeExpr [] <$> arrowOrApply (ApplyType (ConstructorType qi) (VariableType i))
arrowOrApply :: TypeExpr -> Parser TypeExpr
arrowOrApply t = (ArrowType t <$> (skipSomeWs *> tokenArrow *!*> type0)) <|> (foldl1 ApplyType <$> ((t:) <$> many (skipSomeWs *> type2)))
-}
--- A parser for a Context | {Constraint | (ConstraintList)}
context :: Parser Context
context = choice [contextList, parseSingleContext, parseNoContext]
where
parseSingleContext :: Parser Context
parseSingleContext = toList <$> constraint <*!* tokenDoubleArrow
parseNoContext :: Parser Context
parseNoContext = yield []
--- A parser for a Constraint | QualType TypeExpr
constraint :: Parser Constraint
constraint =
(Constraint <$> qualType <*!*> some typeExpr)
--- A parser for a Qualified Type | ADD SYNTAX DESCRIPTION
qualType :: Parser QualIdent
qualType = check condition qualIdent
where
condition (QualIdent (Just (ModuleIdent ids)) (Ident id)) = all (isUpper . head) ids && (isUpper . head) id
condition (QualIdent Nothing (Ident id)) = (isUpper . head) id
--- A parser for a Field Declaration | IdentList :: TypeExpr
fieldDecl :: Parser FieldDecl
fieldDecl =
FieldDecl <$>
(map Ident <$> identList) <*!*>
(tokenTyping *!*> typeExpr)
--- A parser for a Kind Expression | NOT YET IMPLEMENTED
kind :: Parser KindExpr
kind = kind0
-- kind1 -> kind0
kind0 :: Parser KindExpr
kind0 = convert <$> kind1 <*> (optional (skipSomeWs *> tokenArrow *!*> kind0))
where
convert k1 Nothing = k1
convert k1 (Just k0) = ArrowKind k1 k0
-- * | (kind0) | Constraint
kind1 :: Parser KindExpr
kind1 = tokenStar *> yield Star
<!> tokenParenL *> kind0 <* tokenParenR
<!> tokenConstraint *> yield ConstraintKind
--- A parser for a Newtype
iNewtype :: Parser NewConstrDecl
--iNewtype = newtypeRecord <|> newtypeSimple
iNewtype = (Ident <$> ident <* skipSomeWs) *>= decide1
where
decide1 :: Ident -> Parser NewConstrDecl
decide1 i =
(NewConstrDecl i <$> typeExpr) <!>
(NewRecordDecl i <$> (
tokenCurlyBracketL *!*> parseNewField <*!* tokenCurlyBracketR
))
parseNewField :: Parser (Ident, TypeExpr)
parseNewField = (,) <$> (Ident <$> ident) <*!*> (tokenTyping *!*> typeExpr)
{-
--- A parser for a simple Newtype | Ident TypeExpr
newtypeSimple :: Parser NewConstrDecl
newtypeSimple =
parseConstructor *>= convert
where
convert :: (Ident, [TypeExpr]) -> Parser NewConstrDecl
convert (i, ts) = case ts of
[t] -> yield (NewConstrDecl i t)
_ -> failure
--- A parser for a Record Newtype | Ident '{' FieldDecl '}'
newtypeRecord :: Parser NewConstrDecl
newtypeRecord =
NewRecordDecl <$>
(Ident <$> ident) <*!*>
(
tokenCurlyBracketL *!*>
parseNewField
<*!* tokenCurlyBracketR
)
where
parseNewField :: Parser (Ident, TypeExpr)
parseNewField = (,) <$> (Ident <$> ident) <*!*> (tokenTyping *!*> typeExpr)
-}
--- A parser for a Method Declaration | Ident [Arity] '::' QualTypeExpr
methodDecl :: Parser IMethodDecl
methodDecl =
IMethodDecl <$>
(Ident <$> (ident <!> (tokenParenL *> operator <* tokenParenR))) <*!*>
optional (arity <* skipSomeWs) <*>
(tokenTyping *!*> qualTypeExpr)
--- A parser for an Instance Type
instanceType :: Parser InstanceType
instanceType = some (skipManyWs *> typeExpr)
--- A parser for a Method Implementation | {Ident | '(' Op ')'} Arity
methodImpl :: Parser (Ident, Arity)--IMethodImpl
methodImpl =
(,) <$> (Ident <$> (ident <!> (tokenParenL *> operator <* tokenParenR))) <*!*> arity
-- ################################################################
--- Helper Functions
--- Converts a value into a Singleton List
toList :: a -> [a]
toList x = [x]
identToQualIdent :: Ident -> QualIdent
identToQualIdent i = QualIdent Nothing i
-- Completely unwraps applications of type expressions
unwrapApply :: TypeExpr -> [TypeExpr]
unwrapApply t = case t of
ApplyType l r -> unwrapApply l ++ unwrapApply r
_ -> [t]
-- ################################################################
--- Helper parser
contextList :: Parser Context
contextList = tokenParenL *> parseList tokenComma constraint <* tokenParenR <*!* tokenDoubleArrow
qualIdentWithContext :: Parser (Either Context (QualIdent, Maybe KindExpr, [Ident]))
qualIdentWithContext =
(Left <$> contextList <* skipSomeWs) <!>
((,,) <$> qualIdent <*> optional (skipSomeWs *> kind) <*> (map Ident <$> typeVariableListNE) *>= decide)
where
decide :: (QualIdent, Maybe KindExpr, [Ident]) -> Parser (Either Context (QualIdent, Maybe KindExpr, [Ident]))
decide (qi, mk, tvs) = case mk of
Just _ -> yield (Right (qi, mk, tvs))
Nothing -> (skipSomeWs *> tokenDoubleArrow *!*> yield (Left [Constraint qi (map VariableType tvs)])) <!> yield (Right (qi, mk, tvs))
--- Parses a string with enclosing parantheses
parenthesize :: Parser String -> Parser String
parenthesize p = parens <$> (tokenParenL *> p <* tokenParenR)
where
parens s = "(" ++ s ++ ")"
--- A parser for an Integer
parseInt :: Parser Int
parseInt = read <$> some digit
--- A parser for a digit
digit :: Parser Char
digit = check isDigit anyChar
--- Choose the first succeeding parser from a non-empty list of parsers
choice :: [Parser a] -> Parser a
choice = foldr1 (<|>)
--- Parses a list using a parser for the seperator and a parser for the list elements
parseList :: Parser () -> Parser a -> Parser [a]
parseList psep pelem = ((:) <$> pelem <*> many (psep *!*> pelem)) <!> yield []
--- Tries to parse using the given parser or returns Nothing
optional :: Parser a -> Parser (Maybe a)
optional p = Just <$> p <|> yield Nothing
--- A parser for a single Pragma with a Pragma Token
parseSinglePragma :: Parser () -> Parser Ident
parseSinglePragma token = tokenPragmaL *!*> token *!*> (Ident <$> ident) <*!* tokenPragmaR
{-
parseConstructor :: Parser (Ident, [TypeExpr])
parseConstructor =
(,) <$>
(Ident <$> ident) <*>
many (skipSomeWs *> typeExpr)
-}
withOptionalKind :: (a -> Maybe KindExpr -> b) -> Parser a -> Parser b
withOptionalKind c p = withKind <|> withoutKind
where
withKind =
c <$> (tokenParenL *> p) <*!*> (tokenTyping *!*> (Just <$> kind) <* tokenParenR)
withoutKind = c <$> p <*> yield Nothing
--- Debug function to fail with an error message of which function is not yet implemented.
missing :: String -> Parser a
missing name = (\_ -> error (name ++ " not yet implemented"))
infixl 4 <*?*>, <*?*, *?*>, <*!*>, <*!*, *!*>
(<*?*>) :: Parser (a -> b) -> Parser a -> Parser b
pa <*?*> pb = (pa <* skipManyWs) <*> pb
(<*?*) :: Parser a -> Parser b -> Parser a
pa <*?* pb = const <$> pa <*?*> pb
(*?*>) :: Parser a -> Parser b -> Parser b
pa *?*> pb = flip const <$> pa <*?*> pb
(<*!*>) :: Parser (a -> b) -> Parser a -> Parser b
pa <*!*> pb = (pa <* skipSomeWs) <*> pb
(<*!*) :: Parser a -> Parser b -> Parser a
pa <*!* pb = const <$> pa <*!*> pb
(*!*>) :: Parser a -> Parser b -> Parser b
pa *!*> pb = flip const <$> pa <*!*> pb
ws :: Parser ()
ws = check isSpace anyChar *> empty
skipManyWs :: Parser ()
skipManyWs = many ws *> empty
skipSomeWs :: Parser ()
skipSomeWs = some ws *> empty
skipWhitespace :: Parser ()
skipWhitespace = skipManyWs
-- ################################################################
--- Tokens
tokenInterface :: Parser ()
tokenInterface = word "interface"
tokenWhere :: Parser ()
tokenWhere = word "where"
tokenImport :: Parser ()
tokenImport = word "import"
tokenClass :: Parser ()
tokenClass = word "class"
tokenData :: Parser ()
tokenData = word "data"
tokenInstance :: Parser ()
tokenInstance = word "instance"
tokenHiding :: Parser ()
tokenHiding = word "hiding"
tokenCurlyBracketL :: Parser ()
tokenCurlyBracketL = char '{'
tokenCurlyBracketR :: Parser ()
tokenCurlyBracketR = char '}'
tokenSemicolon :: Parser ()
tokenSemicolon = char ';'
tokenComma :: Parser ()
tokenComma = char ','
tokenTyping :: Parser ()
tokenTyping = word "::"
tokenArrow :: Parser ()
tokenArrow = word "->"
tokenDoubleArrow :: Parser ()
tokenDoubleArrow = word "=>"
tokenPragmaL :: Parser ()
tokenPragmaL = word "{-#"
tokenPragmaR :: Parser ()
tokenPragmaR = word "#-}"
tokenEqual :: Parser ()
tokenEqual = char '='
tokenPipe :: Parser ()
tokenPipe = char '|'
tokenDot :: Parser ()
tokenDot = char '.'
tokenParenL :: Parser ()
tokenParenL = char '('
tokenParenR :: Parser ()
tokenParenR = char ')'
tokenPragma :: Parser ()
tokenPragma = choice
[ tokenPragmaLanguage
, tokenPragmaOptions
, tokenPragmaHiding
, tokenPragmaMethod
, tokenPragmaModule
]
tokenPragmaLanguage :: Parser ()
tokenPragmaLanguage = word "LANGUAGE"
tokenPragmaOptions :: Parser ()
tokenPragmaOptions = word "OPTIONS"
tokenPragmaHiding :: Parser ()
tokenPragmaHiding = word "HIDING"
tokenPragmaMethod :: Parser ()
tokenPragmaMethod = word "METHOD"
tokenPragmaModule :: Parser ()
tokenPragmaModule = word "MODULE"
tokenConstraint :: Parser ()
tokenConstraint = word "Constraint"
tokenBracketL :: Parser ()
tokenBracketL = char '['
tokenBracketR :: Parser ()
tokenBracketR = char ']'
tokenNewtype :: Parser ()
tokenNewtype = word "newtype"
tokenType :: Parser ()
tokenType = word "type"
tokenBacktick :: Parser ()
tokenBacktick = char '`'
tokenStar :: Parser ()
tokenStar = char '*'
|