X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fparser%2FParseUtil.lhs;h=dffa2b79fb9685a01ec35f6300a8783dc895f480;hb=8b102da80df1406adcbc62517f72d5ebd5112786;hp=ce4f71bfcfb96d1a6df1324224fed7b65962202b;hpb=c52f850d362bc16fc616c08d84f3c83fbbdea464;p=ghc-hetmet.git diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index ce4f71b..dffa2b7 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -6,25 +6,25 @@ \begin{code} module ParseUtil ( parseError -- String -> Pa - , srcParseErr -- StringBuffer -> SrcLoc -> Message , cbot -- a , splitForConApp -- RdrNameHsType -> [RdrNameBangType] -- -> P (RdrName, [RdrNameBangType]) , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp , groupBindings + + , mkExtName -- Maybe ExtName -> RdrName -> ExtName , checkPrec -- String -> P String - , checkCallConv -- FAST_STRING -> P CallConv , checkContext -- HsType -> P HsContext , checkInstType -- HsType -> P HsType - , checkAssertion -- HsType -> P HsAsst , checkDataHeader -- HsQualType -> P (HsContext,HsName,[HsName]) , checkSimple -- HsType -> [HsName] -> P ((HsName,[HsName])) , checkPattern -- HsExp -> P HsPat , checkPatterns -- [HsExp] -> P [HsPat] -- , checkExpr -- HsExp -> P HsExp , checkValDef -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl + , checkValSig -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl -- some built-in names (all :: RdrName) @@ -35,10 +35,11 @@ module ParseUtil ( -- 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 + , unsafe_tyvar_RDR, stdcall_tyvar_RDR, ccall_tyvar_RDR , minus_RDR, pling_RDR, dot_RDR @@ -52,12 +53,12 @@ import SrcLoc import RdrHsSyn import RdrName import CallConv -import PrelMods ( pRELUDE_Name, mkUbxTupNameStr, mkTupNameStr ) -import OccName ( dataName, tcName, varName, tvName, setOccNameSpace ) +import PrelNames ( pRELUDE_Name, mkTupNameStr ) +import OccName ( dataName, tcName, varName, tvName, tcClsName, + occNameSpace, setOccNameSpace, occNameUserString ) import CmdLineOpts ( opt_NoImplicitPrelude ) -import StringBuffer ( lexemeToString ) import FastString ( unpackFS ) -import ErrUtils +import BasicTypes ( Boxity(..) ) import UniqFM ( UniqFM, listToUFM, lookupUFM ) import Outputable @@ -69,11 +70,6 @@ parseError s = getSrcLocP `thenP` \ loc -> failMsgP (hcat [ppr loc, text ": ", text s]) -srcParseErr :: StringBuffer -> SrcLoc -> Message -srcParseErr s l - = hcat [ppr l, ptext SLIT(": parse error on input "), - char '`', text (lexemeToString s), char '\''] - cbot = panic "CCall:result_ty" ----------------------------------------------------------------------------- @@ -89,9 +85,15 @@ splitForConApp :: RdrNameHsType -> [RdrNameBangType] splitForConApp t ts = split t ts where - split (MonoTyApp t u) ts = split t (Unbanged u : ts) - - split (MonoTyVar t) ts = returnP (con, ts) + split (HsAppTy t u) ts = split t (Unbanged u : ts) + + split (HsTyVar t) ts = + -- check that we've got a type constructor at the head + if occNameSpace t_occ /= tcClsName + then parseError + (showSDoc (text "not a constructor: `" <> + ppr t <> char '\'')) + else returnP (con, ts) where t_occ = rdrNameOcc t con = setRdrNameOcc t (setOccNameSpace t_occ dataName) @@ -120,28 +122,35 @@ checkInstType :: RdrNameHsType -> P RdrNameHsType checkInstType t = case t of HsForAllTy tvs ctxt ty -> - checkAssertion ty [] `thenP` \(c,ts)-> - returnP (HsForAllTy tvs ctxt (MonoDictTy c ts)) + checkDictTy ty [] `thenP` \ dict_ty -> + returnP (HsForAllTy tvs ctxt dict_ty) - ty -> checkAssertion ty [] `thenP` \(c,ts)-> - returnP (HsForAllTy Nothing [] (MonoDictTy c ts)) + ty -> checkDictTy ty [] `thenP` \ dict_ty-> + returnP (HsForAllTy Nothing [] dict_ty) checkContext :: RdrNameHsType -> P RdrNameContext -checkContext (MonoTupleTy ts True) - = mapP (\t -> checkAssertion t []) ts `thenP` \cs -> - returnP cs -checkContext (MonoTyVar t) -- empty contexts are allowed +checkContext (HsTupleTy _ ts) + = mapP (\t -> checkPred t []) ts `thenP` \ps -> + returnP ps +checkContext (HsTyVar t) -- empty contexts are allowed | t == unitTyCon_RDR = returnP [] checkContext t - = checkAssertion t [] `thenP` \c -> - returnP [c] - -checkAssertion :: RdrNameHsType -> [RdrNameHsType] - -> P (ClassAssertion RdrName) -checkAssertion (MonoTyVar t) args@(_:_) | not (isRdrTyVar t) - = returnP (t,args) -checkAssertion (MonoTyApp l r) args = checkAssertion l (r:args) -checkAssertion _ _ = parseError "Illegal class assertion" + = checkPred t [] `thenP` \p -> + returnP [p] + +checkPred :: RdrNameHsType -> [RdrNameHsType] + -> P (HsPred RdrName) +checkPred (HsTyVar t) args@(_:_) | not (isRdrTyVar t) + = returnP (HsPClass t args) +checkPred (HsAppTy l r) args = checkPred l (r:args) +checkPred (HsPredTy (HsPIParam n ty)) [] = returnP (HsPIParam 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" checkDataHeader :: RdrNameHsType -> P (RdrNameContext, RdrName, [RdrNameHsTyVar]) @@ -153,9 +162,9 @@ checkDataHeader t = returnP ([],c,map UserTyVar ts) checkSimple :: RdrNameHsType -> [RdrName] -> P ((RdrName,[RdrName])) -checkSimple (MonoTyApp l (MonoTyVar a)) xs | isRdrTyVar a +checkSimple (HsAppTy l (HsTyVar a)) xs | isRdrTyVar a = checkSimple l (a:xs) -checkSimple (MonoTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs) +checkSimple (HsTyVar t) xs | not (isRdrTyVar t) = returnP (t,xs) checkSimple t _ = trace (showSDoc (ppr t)) $ parseError "Illegal data/newtype declaration" --------------------------------------------------------------------------- @@ -178,7 +187,7 @@ checkPat (HsApp f x) args = checkPat e [] = case e of EWildPat -> returnP WildPatIn HsVar x -> returnP (VarPatIn x) - HsLit l -> returnP (LitPatIn l) + HsLit l -> returnP (LitPatIn l) ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPatIn) EAsPat n e -> checkPat e [] `thenP` (returnP . AsPatIn n) ExprWithTySig e t -> checkPat e [] `thenP` \e -> @@ -231,6 +240,7 @@ 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 @@ -313,23 +323,33 @@ checkValDef -> Maybe RdrNameHsType -> RdrNameGRHSs -> SrcLoc - -> P RdrNameMonoBinds + -> P RdrBinding checkValDef lhs opt_sig grhss loc = case isFunLhs lhs [] of Just (f,inf,es) -> checkPatterns es `thenP` \ps -> - returnP (FunMonoBind f inf [Match [] ps opt_sig grhss] loc) + returnP (RdrValBinding (FunMonoBind f inf [Match [] ps opt_sig grhss] loc)) Nothing -> checkPattern lhs `thenP` \lhs -> - returnP (PatMonoBind lhs grhss loc) + returnP (RdrValBinding (PatMonoBind lhs grhss loc)) + +checkValSig + :: RdrNameHsExpr + -> RdrNameHsType + -> SrcLoc + -> P RdrBinding +checkValSig (HsVar v) ty loc = returnP (RdrSig (Sig v ty loc)) +checkValSig other ty loc = parseError "Type signature given for an expression" + --- A variable binding is parsed as an RdrNamePatBind. +-- A variable binding is parsed as an RdrNameFunMonoBind. +-- See comments with HsBinds.MonoBinds -isFunLhs (OpApp l (HsVar op) fix r) [] | not (isRdrDataCon op) - = Just (op, True, [l,r]) -isFunLhs (HsVar f) es@(_:_) | not (isRdrDataCon f) +isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op) + = Just (op, True, (l:r:es)) +isFunLhs (HsVar f) es | not (isRdrDataCon f) = Just (f,False,es) isFunLhs (HsApp f e) es = isFunLhs f (e:es) isFunLhs (HsPar e) es = isFunLhs e es @@ -354,6 +374,17 @@ mkRecConstrOrUpdate exp fs@(_:_) mkRecConstrOrUpdate _ _ = parseError "Empty record update" +-- Supplying the ext_name in a foreign decl is optional ; if it +-- isn't there, the Haskell name is assumed. Note that no transformation +-- of the Haskell name is then performed, so if you foreign export (++), +-- 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 +mkExtName (Just x) _ = x + ----------------------------------------------------------------------------- -- group function bindings into equation groups @@ -365,8 +396,15 @@ groupBindings binds = group Nothing binds where group :: Maybe RdrNameMonoBinds -> [RdrBinding] -> RdrBinding group (Just bind) [] = RdrValBinding bind group Nothing [] = RdrNullBind + + -- don't group together FunMonoBinds if they have + -- no arguments. This is necessary now that variable bindings + -- with no arguments are now treated as FunMonoBinds rather + -- than pattern bindings (tests/rename/should_fail/rnfail002). group (Just (FunMonoBind f inf1 mtchs ignore_srcloc)) - (RdrValBinding (FunMonoBind f' _ [mtch] loc) : binds) + (RdrValBinding (FunMonoBind f' _ + [mtch@(Match _ (_:_) _ _)] loc) + : binds) | f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds group (Just so_far) binds @@ -404,25 +442,25 @@ funTyCon_RDR | otherwise = mkPreludeQual tcName pRELUDE_Name funName tupleCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr arity)) + | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr Boxed arity)) | otherwise = mkPreludeQual dataName pRELUDE_Name - (snd (mkTupNameStr arity)) + (snd (mkTupNameStr Boxed arity)) tupleTyCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr arity)) + | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr Boxed arity)) | otherwise = mkPreludeQual tcName pRELUDE_Name - (snd (mkTupNameStr arity)) + (snd (mkTupNameStr Boxed arity)) ubxTupleCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkUbxTupNameStr arity)) + | opt_NoImplicitPrelude = mkSrcUnqual dataName (snd (mkTupNameStr Unboxed arity)) | otherwise = mkPreludeQual dataName pRELUDE_Name - (snd (mkUbxTupNameStr arity)) + (snd (mkTupNameStr Unboxed arity)) ubxTupleTyCon_RDR arity - | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkUbxTupNameStr arity)) + | opt_NoImplicitPrelude = mkSrcUnqual tcName (snd (mkTupNameStr Unboxed arity)) | otherwise = mkPreludeQual tcName pRELUDE_Name - (snd (mkUbxTupNameStr arity)) + (snd (mkTupNameStr Unboxed arity)) unitName = SLIT("()") funName = SLIT("(->)") @@ -436,6 +474,8 @@ 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 @@ -445,6 +485,8 @@ 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 @@ -453,6 +495,8 @@ 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("!")