Parse is imported by: Main.
{- ---------------------------------------------------------------------------
Parser for Haskell 98 Syntax
-}
module Parse(parseProg) where import Extra(pair,triple,noPos,Pos(..),isJust) import Lex import Lexical(PosTokenPre(..),LexState(..),PosToken(..)) import Syntax import MkSyntax ( mkAppExp, mkAppInst, mkCase, mkDeclClass , mkDeclFun, mkDeclPat, mkDeclPatFun, mkEnumFrom , mkEnumThenFrom, mkEnumToFrom, mkEnumToThenFrom , mkExpListComp, mkIf, mkInfixList , mkInstList, mkInt, mkParExp, mkParInst, mkParType , mkTypeList, mkPatNplusK ) 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), (L_class, \pos -> mkDeclClass `parseAp` parseContexts `ap` aconid `ap` avarid `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` 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) parseSig :: Parser (Sig TokenId) [PosToken] a parseSig = Sig `parseAp` someSep comma varid `chk` coloncolon `ap` parseStrict parseType parseForeign :: Parser (Decl TokenId) [PosToken] a parseForeign = k_foreign `revChk` ((k_import `revChk` callconv `revChk` ((\(_,LitString _ str) (_,tf) (p,v) t -> DeclForeignImp p str v (calcArity t) tf t v) `parseAp` extfun `ap` unsafe `apCut` varid `chk` coloncolon `ap` parseType)) `orelse` (k_export `revChk` callconv `revChk` ((\(_,LitString _ str) (p,v) t-> DeclForeignExp p str v t) `parseAp` extfun `apCut` varid `chk` coloncolon `ap` parseType)) `orelse` (k_cast `revChk` ((\(p,v) t-> DeclForeignImp p "" v (calcArity t) Cast t v) `parseAp` varid `chk` coloncolon `ap` parseType)) ) where callconv = k_ccall `orelse` k_stdcall `orelse` parse noPos extfun = string `orelse` parse (noPos, LitString UnBoxed "") unsafe = (k_cast `revChk` cast Cast) `orelse` (k_noproto `revChk` cast Noproto) `orelse` (k_unsafe `revChk` cast Unsafe) `orelse` (parse noPos `revChk` cast Safe) cast tf = parse (noPos,tf) 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` parseInfixDecl 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 = (\pos ctx t e-> ExpType pos e ctx t) `parseAp` coloncolon `apCut` parseContexts `ap` parseType `orelse` parse id 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 (getPos decls) decls exp))) `orelse` parse (StmtLet decls))) `orelse` StmtBind `parseAp` parsePat `chk` larrow `apCut` parseExp `orelse` StmtExp `parseAp` parseExp parseExp10 = cases [(L_Lambda,\pos -> (ExpLambda pos) `parseAp` parsePats `chk` rarrow `apCut` parseExp), (L_let, \pos -> (ExpLet pos) `parseChk` lcurl `ap` parseDecls `chk` optSemi `chk` rcurl `chk` lit L_in `ap` parseExp), (L_do, \pos -> (ExpDo 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 `chk` rpar)] (uncurry ExpLit `parseAp` (integer `orelse` rational `orelse` char `orelse` string)) parseFieldExp = varid `into` (\ (pos,ident) -> (FieldExp pos ident `parseChk` equal `ap` parseExp) `orelse` -- H98 removes parse (FieldPun pos ident) -- H98 removes ) parseBrackExp0 pos = -- found '[' (ExpList pos []) `parseChk` rbrack `orelse` parseExp `revAp` parseBrackExp1 pos parseBrackExp1 pos = -- found '[e' (\e -> ExpList pos [e]) `parseChk` 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' (\e2 e1 -> ExpList pos [e1,e2]) `parseChk` rbrack `orelse` mkEnumThenFrom pos `parseChk` dotdot `chk` rbrack `orelse` mkEnumToThenFrom pos `parseChk` dotdot `ap` parseExp `chk` rbrack `orelse` (\es e2 e1 -> ExpList pos (e1:e2:es)) `parseChk` comma `ap` manySep comma parseExp `chk` 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 -> ExpApplication pos (ExpCon pos c:args)) `parseAp` conid `ap` some parseAPat `orelse` parseAPat parseAPat = parseAPat2 `into` parseAPat1 parseFieldPat = varid `into` (\ (pos,ident) -> FieldExp 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) -> 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 `chk` rpar `orelse` ExpList `parseAp` lbrack `ap` manySepSafe comma parsePat `chk` rbrack `orelse` PatIrrefutable `parseAp` lit L_Tidle `ap` parseAPat `orelse` (uncurry ExpLit `parseAp` (integer `orelse` rational `orelse` char `orelse` string))
{- End Module Parse ---------------------------------------------------------}
(HTML for this module was generated on May 15, 2003. About the conversion tool.)