X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParseUtil.lhs;h=1f8a1f125cba3eed467eaad1a1769af062ecbefa;hb=ab46fd8e68f10b6162e77cfc0b216510d9b1d933;hp=96101064ce60fa2887d4035d2f33e814f2793ca9;hpb=da162afcfc9db8335834bb279217c4707fb67988;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index 9610106..1f8a1f1 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -6,13 +6,12 @@ \begin{code} module ParseUtil ( parseError -- String -> Pa - , cbot -- a , mkVanillaCon, mkRecCon, , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp , groupBindings - , mkExtName -- Maybe ExtName -> RdrName -> ExtName + , mkExtName -- RdrName -> ExtName , checkPrec -- String -> P String , checkContext -- HsType -> P HsContext @@ -20,8 +19,8 @@ module ParseUtil ( , checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName]) , checkSimple -- HsType -> [HsName] -> P ((HsName,[HsName])) , checkPattern -- HsExp -> P HsPat - , checkPatterns -- [HsExp] -> P [HsPat] - -- , checkExpr -- HsExp -> P HsExp + , checkPatterns -- SrcLoc -> [HsExp] -> P [HsPat] + , checkDo -- [HsStmt] -> P [HsStmt] , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl ) where @@ -37,12 +36,11 @@ import RdrHsSyn ( RdrBinding(..), RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails ) import RdrName -import PrelNames ( unitTyCon_RDR, minus_RDR ) -import CallConv +import PrelNames ( unitTyCon_RDR ) import OccName ( dataName, varName, tcClsName, occNameSpace, setOccNameSpace, occNameUserString ) +import CStrings ( CLabelString ) import FastString ( unpackFS ) -import UniqFM ( UniqFM, listToUFM, lookupUFM ) import Outputable ----------------------------------------------------------------------------- @@ -53,7 +51,6 @@ parseError s = getSrcLocP `thenP` \ loc -> failMsgP (hcat [ppr loc, text ": ", text s]) -cbot = panic "CCall:result_ty" ----------------------------------------------------------------------------- -- mkVanillaCon @@ -68,7 +65,7 @@ mkVanillaCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDeta mkVanillaCon ty tys = split ty tys where - split (HsAppTy t u) ts = split t (Unbanged u : ts) + split (HsAppTy t u) ts = split t (unbangedType u : ts) split (HsTyVar tc) ts = tyConToDataCon tc `thenP` \ data_con -> returnP (data_con, VanillaCon ts) split _ _ = parseError "Illegal data/newtype declaration" @@ -91,22 +88,6 @@ tyConToDataCon tc ---------------------------------------------------------------------------- -- Various Syntactic Checks -callConvFM :: UniqFM CallConv -callConvFM = listToUFM $ - map (\ (x,y) -> (_PK_ x,y)) - [ ("stdcall", stdCallConv), - ("ccall", cCallConv) --- ("pascal", pascalCallConv), --- ("fastcall", fastCallConv) - ] - -checkCallConv :: FAST_STRING -> P CallConv -checkCallConv s = - case lookupUFM callConvFM s of - Nothing -> parseError ("unknown calling convention: `" - ++ unpackFS s ++ "'") - Just conv -> returnP conv - checkInstType :: RdrNameHsType -> P RdrNameHsType checkInstType t = case t of @@ -130,16 +111,16 @@ checkContext t checkPred :: RdrNameHsType -> [RdrNameHsType] -> P (HsPred RdrName) checkPred (HsTyVar t) args@(_:_) | not (isRdrTyVar t) - = returnP (HsPClass t args) + = returnP (HsClassP t args) checkPred (HsAppTy l r) args = checkPred l (r:args) -checkPred (HsPredTy (HsPIParam n ty)) [] = returnP (HsPIParam n ty) +checkPred (HsPredTy (HsIParam n ty)) [] = returnP (HsIParam n ty) checkPred _ _ = parseError "Illegal class assertion" checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t) = returnP (mkHsDictTy t args) checkDictTy (HsAppTy l r) args = checkDictTy l (r:args) -checkDictTy _ _ = parseError "Illegal class assertion" +checkDictTy _ _ = parseError "Malformed context in instance header" -- Put more comments! -- Checks that the lhs of a datatype declaration @@ -167,16 +148,29 @@ checkSimple (HsOpTy (HsTyVar t1) tycon (HsTyVar t2)) [] checkSimple t _ = parseError "Illegal left hand side in data/newtype declaration" --------------------------------------------------------------------------- +-- Checking statements in a do-expression +-- We parse do { e1 ; e2 ; } +-- as [ExprStmt e1, ExprStmt e2] +-- checkDo (a) checks that the last thing is an ExprStmt +-- (b) transforms it to a ResultStmt + +checkDo [] = parseError "Empty 'do' construct" +checkDo [ExprStmt e _ l] = returnP [ResultStmt e l] +checkDo [s] = parseError "The last statement in a 'do' construct must be an expression" +checkDo (s:ss) = checkDo ss `thenP` \ ss' -> + returnP (s:ss') + +--------------------------------------------------------------------------- -- Checking Patterns. -- We parse patterns as expressions and check for valid patterns below, -- converting the expression into a pattern at the same time. -checkPattern :: RdrNameHsExpr -> P RdrNamePat -checkPattern e = checkPat e [] +checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat +checkPattern loc e = setSrcLocP loc (checkPat e []) -checkPatterns :: [RdrNameHsExpr] -> P [RdrNamePat] -checkPatterns es = mapP checkPattern es +checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat] +checkPatterns loc es = mapP (checkPattern loc) es checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args) @@ -200,9 +194,9 @@ checkPat e [] = case e of in returnP (SigPatIn e t') - OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral k _)) + OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral k)) | plus == plus_RDR - -> returnP (NPlusKPatIn n lit minus_RDR) + -> returnP (NPlusKPatIn n lit) where plus_RDR = mkUnqual varName SLIT("+") -- Hack @@ -213,7 +207,7 @@ checkPat e [] = case e of _ -> patFail HsPar e -> checkPat e [] `thenP` (returnP . ParPatIn) - ExplicitList es -> mapP (\e -> checkPat e []) es `thenP` \ps -> + ExplicitList _ es -> mapP (\e -> checkPat e []) es `thenP` \ps -> returnP (ListPatIn ps) ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps -> @@ -249,11 +243,11 @@ checkValDef checkValDef lhs opt_sig grhss loc = case isFunLhs lhs [] of Just (f,inf,es) -> - checkPatterns es `thenP` \ps -> + checkPatterns loc es `thenP` \ps -> returnP (RdrValBinding (FunMonoBind f inf [Match [] ps opt_sig grhss] loc)) Nothing -> - checkPattern lhs `thenP` \lhs -> + checkPattern loc lhs `thenP` \lhs -> returnP (RdrValBinding (PatMonoBind lhs grhss loc)) checkValSig @@ -271,6 +265,11 @@ checkValSig other ty loc = parseError "Type signature given for an expressio isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr]) isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op) = Just (op, True, (l:r:es)) + | otherwise + = case isFunLhs l es of + Just (op', True, j : k : es') -> + Just (op', True, j : OpApp k (HsVar op) fix r : es') + _ -> Nothing isFunLhs (HsVar f) es | not (isRdrDataCon f) = Just (f,False,es) isFunLhs (HsApp f e) es = isFunLhs f (e:es) @@ -303,10 +302,8 @@ mkRecConstrOrUpdate _ _ -- 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 -mkExtName (Just x) _ = x +mkExtName :: RdrName -> CLabelString +mkExtName rdrNm = _PK_ (occNameUserString (rdrNameOcc rdrNm)) ----------------------------------------------------------------------------- -- group function bindings into equation groups