X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParseUtil.lhs;h=96101064ce60fa2887d4035d2f33e814f2793ca9;hb=da162afcfc9db8335834bb279217c4707fb67988;hp=430460aa24f7212eff5920db17ed8b9ee2238612;hpb=45a3e562564889cf52d65dbe2b98bb426aa305fe;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index 430460a..9610106 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -7,8 +7,7 @@ module ParseUtil ( parseError -- String -> Pa , cbot -- a - , splitForConApp -- RdrNameHsType -> [RdrNameBangType] - -- -> P (RdrName, [RdrNameBangType]) + , mkVanillaCon, mkRecCon, , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp , groupBindings @@ -25,41 +24,24 @@ module ParseUtil ( -- , checkExpr -- HsExp -> P HsExp , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl - - - -- some built-in names (all :: RdrName) - , unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR - , tupleCon_RDR, tupleTyCon_RDR, ubxTupleCon_RDR, ubxTupleTyCon_RDR - , funTyCon_RDR - - -- pseudo-keywords, in var and tyvar forms (all :: RdrName) - , as_var_RDR, hiding_var_RDR, qualified_var_RDR, forall_var_RDR - , export_var_RDR, label_var_RDR, dynamic_var_RDR, unsafe_var_RDR - , stdcall_var_RDR, ccall_var_RDR - - , as_tyvar_RDR, hiding_tyvar_RDR, qualified_tyvar_RDR - , export_tyvar_RDR, label_tyvar_RDR, dynamic_tyvar_RDR - , unsafe_tyvar_RDR, stdcall_tyvar_RDR, ccall_tyvar_RDR - - , minus_RDR, pling_RDR, dot_RDR - ) where #include "HsVersions.h" import Lex -import HsSyn +import HsSyn -- Lots of it import SrcLoc -import RdrHsSyn +import RdrHsSyn ( RdrBinding(..), + RdrNameHsType, RdrNameBangType, RdrNameContext, + RdrNameHsTyVar, RdrNamePat, RdrNameHsExpr, RdrNameGRHSs, + RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails + ) import RdrName +import PrelNames ( unitTyCon_RDR, minus_RDR ) import CallConv -import PrelNames ( pRELUDE_Name, mkTupNameStr ) -import OccName ( dataName, tcName, varName, tvName, setOccNameSpace, occNameUserString ) -import CmdLineOpts ( opt_NoImplicitPrelude ) -import StringBuffer ( lexemeToString ) +import OccName ( dataName, varName, tcClsName, + occNameSpace, setOccNameSpace, occNameUserString ) import FastString ( unpackFS ) -import BasicTypes ( Boxity(..) ) -import ErrUtils import UniqFM ( UniqFM, listToUFM, lookupUFM ) import Outputable @@ -74,25 +56,37 @@ parseError s = cbot = panic "CCall:result_ty" ----------------------------------------------------------------------------- --- splitForConApp +-- mkVanillaCon -- When parsing data declarations, we sometimes inadvertently parse -- a constructor application as a type (eg. in data T a b = C a b `D` E a b) -- This function splits up the type application, adds any pending -- arguments, and converts the type constructor back into a data constructor. -splitForConApp :: RdrNameHsType -> [RdrNameBangType] - -> P (RdrName, [RdrNameBangType]) +mkVanillaCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails) -splitForConApp t ts = split t ts +mkVanillaCon ty tys + = split ty tys where - split (HsAppTy t u) ts = split t (Unbanged u : ts) - - split (HsTyVar t) ts = returnP (con, ts) - where t_occ = rdrNameOcc t - con = setRdrNameOcc t (setOccNameSpace t_occ dataName) + split (HsAppTy t u) ts = split t (Unbanged u : ts) + split (HsTyVar tc) ts = tyConToDataCon tc `thenP` \ data_con -> + returnP (data_con, VanillaCon ts) + split _ _ = parseError "Illegal data/newtype declaration" + +mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails) +mkRecCon con fields + = tyConToDataCon con `thenP` \ data_con -> + returnP (data_con, RecCon fields) + +tyConToDataCon :: RdrName -> P RdrName +tyConToDataCon tc + | occNameSpace tc_occ == tcClsName + = returnP (setRdrNameOcc tc (setOccNameSpace tc_occ dataName)) + | otherwise + = parseError (showSDoc (text "not a constructor:" <+> quotes (ppr tc))) + where + tc_occ = rdrNameOcc tc - split _ _ = parseError "Illegal data/newtype declaration" ---------------------------------------------------------------------------- -- Various Syntactic Checks @@ -147,8 +141,12 @@ checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t) checkDictTy (HsAppTy l r) args = checkDictTy l (r:args) checkDictTy _ _ = parseError "Illegal class assertion" +-- Put more comments! +-- Checks that the lhs of a datatype declaration +-- is of the form Context => T a b ... z checkDataHeader :: RdrNameHsType -> P (RdrNameContext, RdrName, [RdrNameHsTyVar]) + checkDataHeader (HsForAllTy Nothing cs t) = checkSimple t [] `thenP` \(c,ts) -> returnP (cs,c,map UserTyVar ts) @@ -156,17 +154,23 @@ checkDataHeader t = checkSimple t [] `thenP` \(c,ts) -> returnP ([],c,map UserTyVar ts) +-- Checks the type part of the lhs of a datatype declaration checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName])) checkSimple (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a = checkSimple l (a:xs) -checkSimple (HsTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs) -checkSimple t _ = trace (showSDoc (ppr t)) $ parseError "Illegal data/newtype declaration" +checkSimple (HsTyVar tycon) xs | not (isRdrTyVar tycon) = returnP (tycon,xs) + +checkSimple (HsOpTy (HsTyVar t1) tycon (HsTyVar t2)) [] + | not (isRdrTyVar tycon) && isRdrTyVar t1 && isRdrTyVar t2 + = returnP (tycon,[t1,t2]) + +checkSimple t _ = parseError "Illegal left hand side in data/newtype declaration" --------------------------------------------------------------------------- -- Checking Patterns. -- We parse patterns as expressions and check for valid patterns below, --- nverting the expression into a pattern at the same time. +-- converting the expression into a pattern at the same time. checkPattern :: RdrNameHsExpr -> P RdrNamePat checkPattern e = checkPat e [] @@ -183,10 +187,11 @@ checkPat e [] = case e of EWildPat -> returnP WildPatIn HsVar x -> returnP (VarPatIn x) HsLit l -> returnP (LitPatIn l) + HsOverLit l -> returnP (NPatIn l) ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPatIn) EAsPat n e -> checkPat e [] `thenP` (returnP . AsPatIn n) ExprWithTySig e t -> checkPat e [] `thenP` \e -> - -- pattern signatures are parsed as sigtypes, + -- Pattern signatures are parsed as sigtypes, -- but they aren't explicit forall points. Hence -- we have to remove the implicit forall here. let t' = case t of @@ -195,8 +200,11 @@ checkPat e [] = case e of in returnP (SigPatIn e t') - OpApp (HsVar n) (HsVar plus) _ (HsLit k@(HsInt _)) | plus == plus_RDR - -> returnP (NPlusKPatIn n k) + OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral k _)) + | plus == plus_RDR + -> returnP (NPlusKPatIn n lit minus_RDR) + where + plus_RDR = mkUnqual varName SLIT("+") -- Hack OpApp l op fix r -> checkPat l [] `thenP` \l -> checkPat r [] `thenP` \r -> @@ -204,14 +212,17 @@ checkPat e [] = case e of HsVar c -> returnP (ConOpPatIn l c fix r) _ -> patFail - NegApp l r -> checkPat l [] `thenP` (returnP . NegPatIn) HsPar e -> checkPat e [] `thenP` (returnP . ParPatIn) ExplicitList es -> mapP (\e -> checkPat e []) es `thenP` \ps -> returnP (ListPatIn ps) + ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps -> returnP (TuplePatIn ps b) + RecordCon c fs -> mapP checkPatField fs `thenP` \fs -> returnP (RecPatIn c fs) +-- Generics + HsType ty -> returnP (TypePatIn ty) _ -> patFail checkPat _ _ = patFail @@ -224,92 +235,7 @@ checkPatField (n,e,b) = patFail = parseError "Parse error in pattern" ---------------------------------------------------------------------------- --- Check Expression Syntax - -{- -We can get away without checkExpr if the renamer generates errors for -pattern syntax used in expressions (wildcards, as patterns and lazy -patterns). - -checkExpr :: RdrNameHsExpr -> P RdrNameHsExpr -checkExpr e = case e of - HsVar _ -> returnP e - HsIPVar _ -> returnP e - HsLit _ -> returnP e - HsLam match -> checkMatch match `thenP` (returnP.HsLam) - HsApp e1 e2 -> check2Exprs e1 e2 HsApp - OpApp e1 e2 fix e3 -> checkExpr e1 `thenP` \e1 -> - checkExpr e2 `thenP` \e2 -> - checkExpr e3 `thenP` \e3 -> - returnP (OpApp e1 e2 fix e3) - NegApp e neg -> checkExpr e `thenP` \e -> - returnP (NegApp e neg) - HsPar e -> check1Expr e HsPar - SectionL e1 e2 -> check2Exprs e1 e2 SectionL - SectionR e1 e2 -> check2Exprs e1 e2 SectionR - HsCase e alts -> mapP checkMatch alts `thenP` \alts -> - checkExpr e `thenP` \e -> - returnP (HsCase e alts) - HsIf e1 e2 e3 -> check3Exprs e1 e2 e3 HsIf - - HsLet bs e -> check1Expr e (HsLet bs) - HsDo stmts -> mapP checkStmt stmts `thenP` (returnP . HsDo) - HsTuple es -> checkManyExprs es HsTuple - HsList es -> checkManyExprs es HsList - HsRecConstr c fields -> mapP checkField fields `thenP` \fields -> - returnP (HsRecConstr c fields) - HsRecUpdate e fields -> mapP checkField fields `thenP` \fields -> - checkExpr e `thenP` \e -> - returnP (HsRecUpdate e fields) - HsEnumFrom e -> check1Expr e HsEnumFrom - HsEnumFromTo e1 e2 -> check2Exprs e1 e2 HsEnumFromTo - HsEnumFromThen e1 e2 -> check2Exprs e1 e2 HsEnumFromThen - HsEnumFromThenTo e1 e2 e3 -> check3Exprs e1 e2 e3 HsEnumFromThenTo - HsListComp e stmts -> mapP checkStmt stmts `thenP` \stmts -> - checkExpr e `thenP` \e -> - returnP (HsListComp e stmts) - RdrNameHsExprTypeSig loc e ty -> checkExpr e `thenP` \e -> - returnP (RdrNameHsExprTypeSig loc e ty) - _ -> parseError "parse error in expression" - --- type signature for polymorphic recursion!! -check1Expr :: RdrNameHsExpr -> (RdrNameHsExpr -> a) -> P a -check1Expr e f = checkExpr e `thenP` (returnP . f) - -check2Exprs :: RdrNameHsExpr -> RdrNameHsExpr -> (RdrNameHsExpr -> RdrNameHsExpr -> a) -> P a -check2Exprs e1 e2 f = - checkExpr e1 `thenP` \e1 -> - checkExpr e2 `thenP` \e2 -> - returnP (f e1 e2) - -check3Exprs :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -> (RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr -> a) -> P a -check3Exprs e1 e2 e3 f = - checkExpr e1 `thenP` \e1 -> - checkExpr e2 `thenP` \e2 -> - checkExpr e3 `thenP` \e3 -> - returnP (f e1 e2 e3) - -checkManyExprs es f = - mapP checkExpr es `thenP` \es -> - returnP (f es) - -checkAlt (HsAlt loc p galts bs) - = checkGAlts galts `thenP` \galts -> returnP (HsAlt loc p galts bs) - -checkGAlts (HsUnGuardedAlt e) = check1Expr e HsUnGuardedAlt -checkGAlts (HsGuardedAlts galts) - = mapP checkGAlt galts `thenP` (returnP . HsGuardedAlts) - -checkGAlt (HsGuardedAlt loc e1 e2) = check2Exprs e1 e2 (HsGuardedAlt loc) - -checkStmt (HsGenerator p e) = check1Expr e (HsGenerator p) -checkStmt (HsQualifier e) = check1Expr e HsQualifier -checkStmt s@(HsLetStmt bs) = returnP s - -checkField (HsFieldUpdate n e) = check1Expr e (HsFieldUpdate n) -checkField e = returnP e --} + --------------------------------------------------------------------------- -- Check Equation Syntax @@ -342,6 +268,7 @@ checkValSig other ty loc = parseError "Type signature given for an expressio -- A variable binding is parsed as an RdrNameFunMonoBind. -- See comments with HsBinds.MonoBinds +isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr]) isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op) = Just (op, True, (l:r:es)) isFunLhs (HsVar f) es | not (isRdrDataCon f) @@ -375,6 +302,7 @@ mkRecConstrOrUpdate _ _ -- it's external name will be "++". Too bad; it's important because we don't -- want z-encoding (e.g. names with z's in them shouldn't be doubled) -- (This is why we use occNameUserString.) + mkExtName :: Maybe ExtName -> RdrName -> ExtName mkExtName Nothing rdrNm = ExtName (_PK_ (occNameUserString (rdrNameOcc rdrNm))) Nothing @@ -408,94 +336,4 @@ groupBindings binds = group Nothing binds = case bind of RdrValBinding b@(FunMonoBind _ _ _ _) -> group (Just b) binds other -> bind `RdrAndBindings` group Nothing binds - ------------------------------------------------------------------------------ --- Built-in names - -unitCon_RDR, unitTyCon_RDR, nilCon_RDR, listTyCon_RDR :: RdrName -tupleCon_RDR, tupleTyCon_RDR :: Int -> RdrName -ubxTupleCon_RDR, ubxTupleTyCon_RDR :: Int -> RdrName - -unitCon_RDR - | opt_NoImplicitPrelude = mkSrcUnqual dataName unitName - | otherwise = mkPreludeQual dataName pRELUDE_Name unitName - -unitTyCon_RDR - | opt_NoImplicitPrelude = mkSrcUnqual tcName unitName - | otherwise = mkPreludeQual tcName pRELUDE_Name unitName - -nilCon_RDR - | opt_NoImplicitPrelude = mkSrcUnqual dataName listName - | otherwise = mkPreludeQual dataName pRELUDE_Name listName - -listTyCon_RDR - | opt_NoImplicitPrelude = mkSrcUnqual tcName listName - | otherwise = mkPreludeQual tcName pRELUDE_Name listName - -funTyCon_RDR - | opt_NoImplicitPrelude = mkSrcUnqual tcName funName - | otherwise = mkPreludeQual tcName pRELUDE_Name funName - -tupleCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr Boxed arity)) - | otherwise = mkPreludeQual dataName pRELUDE_Name - (snd (mkTupNameStr Boxed arity)) - -tupleTyCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr Boxed arity)) - | otherwise = mkPreludeQual tcName pRELUDE_Name - (snd (mkTupNameStr Boxed arity)) - - -ubxTupleCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr Unboxed arity)) - | otherwise = mkPreludeQual dataName pRELUDE_Name - (snd (mkTupNameStr Unboxed arity)) - -ubxTupleTyCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr Unboxed arity)) - | otherwise = mkPreludeQual tcName pRELUDE_Name - (snd (mkTupNameStr Unboxed arity)) - -unitName = SLIT("()") -funName = SLIT("(->)") -listName = SLIT("[]") - -asName = SLIT("as") -hidingName = SLIT("hiding") -qualifiedName = SLIT("qualified") -forallName = SLIT("forall") -exportName = SLIT("export") -labelName = SLIT("label") -dynamicName = SLIT("dynamic") -unsafeName = SLIT("unsafe") -stdcallName = SLIT("stdcall") -ccallName = SLIT("ccall") - -as_var_RDR = mkSrcUnqual varName asName -hiding_var_RDR = mkSrcUnqual varName hidingName -qualified_var_RDR = mkSrcUnqual varName qualifiedName -forall_var_RDR = mkSrcUnqual varName forallName -export_var_RDR = mkSrcUnqual varName exportName -label_var_RDR = mkSrcUnqual varName labelName -dynamic_var_RDR = mkSrcUnqual varName dynamicName -unsafe_var_RDR = mkSrcUnqual varName unsafeName -stdcall_var_RDR = mkSrcUnqual varName stdcallName -ccall_var_RDR = mkSrcUnqual varName ccallName - -as_tyvar_RDR = mkSrcUnqual tvName asName -hiding_tyvar_RDR = mkSrcUnqual tvName hidingName -qualified_tyvar_RDR = mkSrcUnqual tvName qualifiedName -export_tyvar_RDR = mkSrcUnqual tvName exportName -label_tyvar_RDR = mkSrcUnqual tvName labelName -dynamic_tyvar_RDR = mkSrcUnqual tvName dynamicName -unsafe_tyvar_RDR = mkSrcUnqual tvName unsafeName -stdcall_tyvar_RDR = mkSrcUnqual tvName stdcallName -ccall_tyvar_RDR = mkSrcUnqual tvName ccallName - -minus_RDR = mkSrcUnqual varName SLIT("-") -pling_RDR = mkSrcUnqual varName SLIT("!") -dot_RDR = mkSrcUnqual varName SLIT(".") - -plus_RDR = mkSrcUnqual varName SLIT("+") \end{code}