hat-2.7.0.0: compiler98/Parse.hs
{- ---------------------------------------------------------------------------
Parser for Haskell 98 Syntax
-}
module Parse(parseProg) where
import Extra(pair,noPos,strace,strPos,mergePos)
import Lex
import Lexical(PosToken)
import Syntax
import MkSyntax ( mkAppExp, mkCase, mkDeclClass
, mkDeclFun, mkDeclPat, mkDeclPatFun, mkEnumFrom
, mkEnumThenFrom, mkEnumToFrom, mkEnumToThenFrom
, mkExpListComp, mkIf, mkInfixList, mkExpList
, mkLambda, mkLet, mkDo, mkFieldExp
, mkParExp, mkPatNplusK -- , mkParLhs
)
import Parse2
import ParseLib
import ParseLex
import SyntaxPos
import TokenId (t_nplusk,t_Arrow)
optSemi = () `parseChk` semi
`orelse`
parse ()
parseProg :: Parser (Module TokenId) [PosToken] a
parseProg = {- many parsePragma `revChk` -} (parseModule `chkCut` eof)
parseModule :: Parser (Module TokenId) [PosToken] a
parseModule =
(uncurry Module) `parseChk` lit L_module `apCut` bigModId `ap` parseExports
`chk` lit L_where `chk` lcurl
`apCut` parseImpDecls
`apCut` parseFixDecls
`apCut` parseTopDecls
`chk` optSemi `chk` rcurl
parseTopDecls :: Parser (Decls TokenId) [PosToken] a
parseTopDecls =
semi `revChk` parseTopDecls
`orelse`
DeclsParse `parseAp` manysSep semi parseTopDecl
parseTopDecl :: Parser (Decl TokenId) [PosToken] a
parseTopDecl =
cases [
(L_type, \pos -> DeclType `parseAp` parseSimple `chk` equal `ap` parseType),
(L_newtype, \pos ->
DeclData Nothing `parseAp` parseContexts `ap` parseSimple `chk`
equal `apCut` ( (:[]) `parseAp` parseConstr) `apCut` parseDeriving),
(L_data, \pos ->
(\ (pos,conid) size -> DeclDataPrim pos conid size) `parseChk`
k_primitive `ap` conid `chk` equal `apCut` intPrim
`orelse`
(DeclData . Just) `parseAp` unboxed `ap` parseContexts `ap`
parseSimple `chk` equal `apCut`
someSep pipe parseConstr `apCut` parseDeriving
`orelse`
(\ simpl -> DeclData (Just False) [] simpl [] []) `parseAp` parseSimple ),
(L_class, \pos ->
mkDeclClass `parseAp` parseContexts `ap` aconid `ap` some avarid `ap`
parseFunDeps `ap`
(id `parseChk` lit L_where `chk` lcurl `ap` parseCDecls `chk` rcurl
`orelse`
parse (DeclsParse [])
)),
(L_instance, \pos->
(\ctx (pos',cls) -> DeclInstance pos' ctx cls) `parseAp`
parseContexts `ap` aconid `ap` some parseInst `ap`
(lit L_where `revChk` lcurl `revChk` parseValdefs `chk` rcurl
`orelse`
parse (DeclsParse [])
)),
(L_default, \pos ->
DeclDefault `parseChk` lpar `apCut`
manySep comma parseType `chk` rpar
`orelse`
(\x->DeclDefault [x]) `parseAp` parseType)
]
(uncurry DeclPrimitive `parseAp` varid `chk` k_primitive `apCut`
intPrim `chk` coloncolon `ap` parseType
`orelse`
parseForeign
`orelse`
parseDecl)
parseFunDeps :: Parser [FunDep TokenId] [PosToken] a
parseFunDeps =
pipe `revChk` someSep comma parseFunDep
`orelse`
parse []
parseFunDep :: Parser (FunDep TokenId) [PosToken] a
parseFunDep =
(:->:) `parseAp` parseTyVars `chk` rarrow `ap` parseTyVars
where
parseTyVars :: Parser [TokenId] [PosToken] a
parseTyVars =
map snd `parseAp` some avarid
-- map snd `parseAp` (lpar `revChk` someSep comma avarid `chk` rpar)
-- `orelse`
-- ((:[]) . snd) `parseAp` varid
parseForeign :: Parser (Decl TokenId) [PosToken] a
parseForeign =
k_foreign `revAp`
((k_import `revChk`
((\(_,conv) (_,tf) (_,LitString _ str) (_,v) t p ->
DeclForeignImp (mergePos p (getPos t)) conv str v
(calcArity t) tf t v)
`parseAp` callconv `ap` safety `ap` entity `ap` varid `chk`
coloncolon `apCut` parseType))
`orelse`
(k_export `revChk`
((\(_,conv) (_,LitString _ str) (_,v) t p->
DeclForeignExp (mergePos p (getPos t)) conv str v t)
`parseAp` callconv `ap` entity `apCut` varid `chk` coloncolon
`ap` parseType))
`orelse`
(k_import `revChk` -- old syntax, will be removed in the future
((\(_,conv) (_,LitString _ str) (_,tf) (_,v) t p ->
let p' = mergePos p (getPos t) in
strace ("Deprecated FFI syntax used at "++strPos p') $
DeclForeignImp p' conv str v (calcArity t) tf t v)
`parseAp` (callconv `orelse` is C) `ap` entity `ap`
safety `apCut` varid `chk` coloncolon `ap` parseType))
-- `orelse`
-- (k_cast `revChk`
-- ((\(p,v) t-> DeclForeignImp p Cast "" v (calcArity t) Safe t v)
-- `parseAp` varid `chk` coloncolon `ap` parseType))
)
where
callconv = (k_ccall `revChk` is C)
`orelse`
(k_cast `revChk` is Cast)
`orelse`
(k_noproto `revChk` is Noproto)
`orelse`
(k_haskellcall `revChk` is Haskell)
`orelse`
(k_stdcall `revChk` is (Other "stdcall"))
`orelse`
(k_cplusplus `revChk` is (Other "cplusplus"))
`orelse`
(k_dotnet `revChk` is (Other "dotnet"))
`orelse`
(k_jvm `revChk` is (Other "jvm"))
-- `orelse`
-- (is C) -- previously the default, now the name is mandatory
is v = parse (noPos,v)
entity = string `orelse` is (LitString UnBoxed "")
safety = (k_unsafe `revChk` is Unsafe)
`orelse`
(k_safe `revChk` is Safe)
`orelse`
(is Safe) -- default is Safe
calcArity (TypeCons p c ts) | c == t_Arrow = 1 + calcArity (ts!!1)
calcArity _ | otherwise = 0
parseVarsType :: Parser (Decl TokenId) [PosToken] a
parseVarsType =
DeclVarsType `parseAp` someSep comma varid `chk` coloncolon `ap`
parseContexts `ap` parseType
{-
parseNewConstr =
(\ (pos,op) a -> [Constr pos op [(Nothing,a)]]) `parseAp` conid `ap` parseInst
-}
-- parseCSigns = DeclsParse `parseAp` manySep semi parseCSign
-- parseCSign = parseVarsType
parseCDecls :: Parser (Decls TokenId) [PosToken] a
parseCDecls = DeclsParse `parseAp` (manysSep semi parseCDecl) -- H98 added
parseCDecl :: Parser (Decl TokenId) [PosToken] a
parseCDecl = parseVarsType `orelse` parseValdef
`orelse` (DeclFixity `parseAp` parseFixDecl)
parseValdefs :: Parser (Decls TokenId) [PosToken] a
parseValdefs =
semi `revChk` parseValdefs
`orelse`
DeclsParse `parseAp` manysSep semi parseValdef
parseValdef :: Parser (Decl TokenId) [PosToken] a
parseValdef =
mkDeclPat `parseAp` varid `ap` anyop `ap` parsePat `ap`
parseRhs equal `apCut` parseWhere
`orelse`
mkDeclFun `parseAp` varid `ap` parsePats `ap` parseRhs equal `apCut`
parseWhere
`orelse`
mkDeclPatFun `parseAp` parseAlt equal
parseWhere :: Parser (Decls TokenId) [PosToken] a
parseWhere =
lit L_where `revChk` lcurl `revChk` parseDecls `chk` rcurl
`orelse`
parse (DeclsParse [])
parseDecls = DeclsParse `parseAp` (manysSep semi parseDecl)
parseDecl =
parseVarsType
`orelse`
parseValdef
`orelse` -- added in H98
DeclFixity `parseAp` parseFixDecl -- added in H98
{- `orelse`
parsePragma -- added by MW, Sept 2000
-}
parseExp :: Parser (Exp TokenId) [PosToken] a
parseExp =
parseExp0 `revAp` parseExpType
parseExpType :: Parser (Exp TokenId -> Exp TokenId) [PosToken] a
parseExpType =
(\pos ctx t e-> ExpType (mergePos pos (getPos t)) e ctx t)
`parseAp` coloncolon `apCut`
parseContexts `ap` parseType
`orelse`
parse id
parseExp0 :: Parser (Exp TokenId) [PosToken] a
parseExp0 = mkInfixList `parseAp` some (anyop `orelse` parseExp10)
parseStmt =
(lit L_let `into` \_-> lcurl `into` \_-> parseDecls `into`
\decls-> rcurl `into` \_->
((lit L_in `into` \_-> parseExp `into`
\exp-> parse (StmtExp (ExpLet
(mergePos (getPos decls) (getPos exp)) decls exp)))
`orelse`
parse (StmtLet decls)))
`orelse`
StmtBind `parseAp` parsePat `chk` larrow `apCut` parseExp
`orelse`
StmtExp `parseAp` parseExp
parseExp10 =
cases
[(L_Lambda,\pos -> (mkLambda pos)
`parseAp` parsePats `chk` rarrow `apCut` parseExp),
(L_let, \pos -> (mkLet pos)
`parseChk` lcurl `ap` parseDecls
`chk` optSemi `chk` rcurl
`chk` lit L_in `ap` parseExp),
(L_do, \pos -> (mkDo pos)
`parseChk` lcurl `ap` somesSep semi parseStmt
`chk` optSemi `chk` rcurl),
(L_if, \pos -> (mkIf pos)
`parseAp` parseExp
`chk` lit L_then `ap` parseExp
`chk` lit L_else `ap` parseExp),
(L_case, \pos -> (mkCase pos)
`parseAp` parseExp `chk` lit L_of
`chk` lcurl `ap` (somesSep semi (parseAlt rarrow))
`chk` optSemi `chk` rcurl)]
parseFExp
parseFExp = mkAppExp `parseAp` some parseAExpR1
parseAExpR1 =
parseAExp `into` parseAExpR
parseAExpR exp =
(ExpRecord exp `parseChk` lcurl `ap` manySep comma parseFieldExp `chk` rcurl) `into` parseAExpR
`orelse`
parse exp
parseAExp =
aanyid
`orelse`
cases
[(L_LBRACK, \pos -> parseBrackExp0 pos),
(L_LPAR, \pos -> (mkParExp pos) `parseAp` manySep comma parseExp
`ap` rpar)]
(uncurry ExpLit `parseAp`
(integer `orelse` rational `orelse` char `orelse` string))
parseFieldExp =
varid `into` (\(pos,ident)-> (mkFieldExp pos ident `parseChk` equal
`ap` parseExp)
`orelse` -- H98 removes
parse (FieldPun pos ident) -- H98 removes
)
parseBrackExp0 pos = -- found '['
(mkExpList pos []) `parseAp` rbrack
`orelse`
parseExp `revAp` parseBrackExp1 pos
parseBrackExp1 pos = -- found '[e'
(\posr e -> mkExpList pos [e] posr) `parseAp` rbrack
`orelse`
mkEnumFrom pos `parseChk` dotdot `chk` rbrack
`orelse`
mkExpListComp pos `parseChk` pipe `ap` somesSep comma parseQual `chk` rbrack
`orelse`
mkEnumToFrom pos `parseChk` dotdot `ap` parseExp `chk` rbrack
`orelse`
comma `revChk` (parseExp `revAp` parseBrackExp2 pos)
parseBrackExp2 pos = -- found '[e,e'
(\posr e2 e1 -> mkExpList pos [e1,e2] posr) `parseAp` rbrack
`orelse`
mkEnumThenFrom pos `parseChk` dotdot `chk` rbrack
`orelse`
mkEnumToThenFrom pos `parseChk` dotdot `ap` parseExp `chk` rbrack
`orelse`
(\es posr e2 e1 -> mkExpList pos (e1:e2:es) posr) `parseChk` comma
`ap` manySep comma parseExp
`ap` rbrack
parseQual =
(lit L_let `into` \_-> lcurl `into` \_-> parseDecls `into`
\decls-> rcurl `into` \ _ ->
((lit L_in `into` \_-> parseExp `into` \exp->
parse (QualExp (ExpLet (getPos decls) decls exp)))
`orelse`
parse (QualLet decls)))
`orelse`
QualPatExp `parseAp` parsePat `chk` larrow `apCut` parseExp
`orelse`
QualExp `parseAp` parseExp
parseAlt del =
Alt `parseAp` parsePat `ap` parseRhs del `apCut` parseWhere
parseRhs :: Parser Pos [PosToken] a -> Parser (Rhs TokenId) [PosToken] a
parseRhs del =
Unguarded `parseChk` del `apCut` parseExp
`orelse`
Guarded `parseAp` some (parseGdExp del)
parseGdExp :: Parser Pos [PosToken] a
-> Parser (Exp TokenId, Exp TokenId) [PosToken] a
parseGdExp del =
pair `parseChk` pipe `apCut` parseExp `chk` del `apCut` parseExp
parsePats = some parseAPat
-- Pat can not contain cut! It brakes parseStmt if it does.
manySafe p = someSafe p `orelse` parse []
someSafe p = (:) `parseAp` p `ap` manySafe p
manySepSafe' s p = s `revChk` someSepSafe s p
`orelse`
parse []
manySepSafe s p = someSepSafe s p `orelse` parse []
someSepSafe s p = (:) `parseAp` p `apCut` manySepSafe' s p
parsePat =
mkPatNplusK `parseAp` varid `chk` literal (L_AVAROP t_nplusk) `ap` integer
`orelse`
parsePat0
parsePat0 = mkInfixList `parseAp` someSafe (parseOpPat `orelse` parseFPat)
parseOpPat = anyop
parseFPat =
(\(pos,c) args -> mkAppExp (ExpCon pos c:args))
`parseAp` conid `ap` some parseAPat
`orelse`
parseAPat
parseAPat = parseAPat2 `into` parseAPat1
parseFieldPat =
varid `into` (\(pos,ident)-> mkFieldExp pos ident `parseChk` equal
`ap` parsePat
`orelse` -- H98 removes
parse (FieldPun pos ident) -- H98 removes
)
parseAPat1 exp =
(ExpRecord exp `parseChk` lcurl `ap` manySepSafe comma parseFieldPat
`chk` rcurl) `into` parseAPat1
`orelse`
parse exp
parseAPat2 =
varid `revAp` ((\e (pos,i) -> let p = mergePos pos (getPos e)
in p `seq` PatAs pos i e)
`parseChk` lit L_At `ap` parseAPat
`orelse`
parse (\ (pos,e) -> ExpVar pos e)
)
`orelse`
(\(pos,e) -> ExpCon pos e) `parseAp` aconid
`orelse`
PatWildcard `parseAp` lit L_Underscore
`orelse`
mkParExp `parseAp` lpar `ap` manySepSafe comma parsePat `ap` rpar
`orelse`
mkExpList `parseAp` lbrack `ap` manySepSafe comma parsePat `ap` rbrack
`orelse`
PatIrrefutable `parseAp` lit L_Tidle `ap` parseAPat
`orelse`
(uncurry ExpLit `parseAp`
(integer `orelse` rational `orelse` char `orelse` string))
-- `orelse`
-- mkParLhs `parseAp` lpar `ap` parsePat0 `chk` rpar `ap` someSafe parseAPat
{- End Module Parse ---------------------------------------------------------}