X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsUtils.lhs;h=f8efa6cfb94f206e7047953e32c87d6b486eacac;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=582e0f01e313cdd6c8d25642f57c71cb6a5a98f0;hpb=23f40f0e9be6d4aa5cf9ea31d73f4013f8e7b4bd;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsUtils.lhs b/ghc/compiler/hsSyn/HsUtils.lhs index 582e0f0..f8efa6c 100644 --- a/ghc/compiler/hsSyn/HsUtils.lhs +++ b/ghc/compiler/hsSyn/HsUtils.lhs @@ -27,9 +27,9 @@ import RdrName ( RdrName, getRdrName, mkRdrUnqual ) import Var ( Id ) import Type ( Type ) import DataCon ( DataCon, dataConWrapId, dataConSourceArity ) -import BasicTypes ( RecFlag(..) ) -import OccName ( mkVarOcc ) +import OccName ( mkVarOccFS ) import Name ( Name ) +import BasicTypes ( RecFlag(..) ) import SrcLoc import FastString ( mkFastString ) import Outputable @@ -56,14 +56,14 @@ mkHsPar e = L (getLoc e) (HsPar e) mkSimpleMatch :: [LPat id] -> LHsExpr id -> LMatch id mkSimpleMatch pats rhs = L loc $ - Match pats Nothing (GRHSs (unguardedRHS rhs) []) + Match pats Nothing (GRHSs (unguardedRHS rhs) emptyLocalBinds) where loc = case pats of [] -> getLoc rhs (pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs) unguardedRHS :: LHsExpr id -> [LGRHS id] -unguardedRHS rhs@(L loc _) = [L loc (GRHS [L loc (ResultStmt rhs)])] +unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)] mkHsAppTy :: LHsType name -> LHsType name -> LHsType name mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2) @@ -93,10 +93,14 @@ mkHsTyLam tyvars expr = L (getLoc expr) (TyLam tyvars expr) mkHsDictLam [] expr = expr mkHsDictLam dicts expr = L (getLoc expr) (DictLam dicts expr) -mkHsLet :: LHsBinds name -> LHsExpr name -> LHsExpr name -mkHsLet binds expr +mkHsDictLet :: LHsBinds Id -> LHsExpr Id -> LHsExpr Id +-- Used for the dictionary bindings gotten from TcSimplify +-- We make them recursive to be on the safe side +mkHsDictLet binds expr | isEmptyLHsBinds binds = expr - | otherwise = L (getLoc expr) (HsLet [HsBindGroup binds [] Recursive] expr) + | otherwise = L (getLoc expr) (HsLet (HsValBinds val_binds) expr) + where + val_binds = ValBindsOut [(Recursive, binds)] [] mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id -- Used for constructing dictinoary terms etc, so no locations @@ -110,30 +114,37 @@ mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id mkSimpleHsAlt pat expr = mkSimpleMatch [pat] expr -glueBindsOnGRHSs :: HsBindGroup id -> GRHSs id -> GRHSs id --- gaw 2004 -glueBindsOnGRHSs binds1 (GRHSs grhss binds2) - = GRHSs grhss (binds1 : binds2) - +------------------------------- -- These are the bits of syntax that contain rebindable names -- See RnEnv.lookupSyntaxName -mkHsIntegral i = HsIntegral i placeHolderName -mkHsFractional f = HsFractional f placeHolderName -mkNPlusKPat n k = NPlusKPatIn n k placeHolderName -mkHsDo ctxt stmts = HsDo ctxt stmts [] placeHolderType +mkHsIntegral i = HsIntegral i noSyntaxExpr +mkHsFractional f = HsFractional f noSyntaxExpr +mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType + +mkNPat lit neg = NPat lit neg noSyntaxExpr placeHolderType +mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr +mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType +mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr +mkRecStmt stmts = RecStmt stmts [] [] [] emptyLHsBinds + +------------------------------- --- A useful function for building @OpApps@. The operator is always a -- variable, and we don't know the fixity yet. mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2 mkHsSplice e = HsSplice unqualSplice e -unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice")) +unqualSplice = mkRdrUnqual (mkVarOccFS FSLIT("splice")) -- A name (uniquified later) to -- identify the splice mkHsString s = HsString (mkFastString s) + +------------- +userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)] +userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ] \end{code} @@ -188,8 +199,8 @@ nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) nlTuplePat pats box = noLoc (TuplePat pats box) nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking -nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) +nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id +nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body) nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) @@ -203,12 +214,6 @@ nlList exprs = noLoc (ExplicitList placeHolderType exprs) nlHsAppTy f t = noLoc (HsAppTy f t) nlHsTyVar x = noLoc (HsTyVar x) nlHsFunTy a b = noLoc (HsFunTy a b) - -nlExprStmt expr = noLoc (ExprStmt expr placeHolderType) -nlBindStmt pat expr = noLoc (BindStmt pat expr) -nlLetStmt binds = noLoc (LetStmt binds) -nlResultStmt expr = noLoc (ResultStmt expr) -nlParStmt stuff = noLoc (ParStmt stuff) \end{code} @@ -221,36 +226,32 @@ nlParStmt stuff = noLoc (ParStmt stuff) \begin{code} mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName -mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyLHsBinds rhs +mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs +------------ mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName] - -> LHsBinds RdrName -> LHsExpr RdrName - -> LHsBind RdrName + -> LHsExpr RdrName -> LHsBind RdrName -mk_easy_FunBind loc fun pats binds expr - = L loc (FunBind (L loc fun) False{-not infix-} - (mkMatchGroup [mk_easy_Match pats binds expr])) - -mk_easy_Match pats binds expr - = mkMatch pats expr [HsBindGroup binds [] Recursive] - -- The renamer expects everything in its input to be a - -- "recursive" MonoBinds, and it is its job to sort things out - -- from there. +mk_easy_FunBind loc fun pats expr + = L loc (FunBind (L loc fun) False{-not infix-} matches placeHolderNames) + where + matches = mkMatchGroup [mkMatch pats expr emptyLocalBinds] -mk_FunBind :: SrcSpan - -> RdrName - -> [([LPat RdrName], LHsExpr RdrName)] - -> LHsBind RdrName +------------ +mk_FunBind :: SrcSpan -> RdrName + -> [([LPat RdrName], LHsExpr RdrName)] + -> LHsBind RdrName mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind" mk_FunBind loc fun pats_and_exprs - = L loc (FunBind (L loc fun) False{-not infix-} - (mkMatchGroup [mkMatch p e [] | (p,e) <-pats_and_exprs])) + = L loc (FunBind (L loc fun) False{-not infix-} matches placeHolderNames) + where + matches = mkMatchGroup [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs] -mkMatch :: [LPat id] -> LHsExpr id -> [HsBindGroup id] -> LMatch id +------------ +mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id mkMatch pats expr binds = noLoc (Match (map paren pats) Nothing --- gaw 2004 (GRHSs (unguardedRHS expr) binds)) where paren p = case p of @@ -276,29 +277,32 @@ where it should return [x, y, f, a, b] (remember, order important). \begin{code} -collectGroupBinders :: [HsBindGroup name] -> [Located name] -collectGroupBinders groups = foldr collect_group [] groups - where - collect_group (HsBindGroup bag sigs is_rec) acc - = foldrBag (collectAcc . unLoc) acc bag - collect_group (HsIPBinds _) acc = acc - +collectLocalBinders :: HsLocalBinds name -> [Located name] +collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds +collectLocalBinders (HsIPBinds _) = [] +collectLocalBinders EmptyLocalBinds = [] + +collectHsValBinders :: HsValBinds name -> [Located name] +collectHsValBinders (ValBindsIn binds sigs) = collectHsBindLocatedBinders binds +collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds + where + collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds collectAcc :: HsBind name -> [Located name] -> [Located name] -collectAcc (PatBind pat _ _) acc = collectLocatedPatBinders pat ++ acc -collectAcc (FunBind f _ _) acc = f : acc -collectAcc (VarBind f _) acc = noLoc f : acc -collectAcc (AbsBinds _ _ dbinds _ binds) acc - = [noLoc dp | (_,dp,_) <- dbinds] ++ acc +collectAcc (PatBind pat _ _ _) acc = collectLocatedPatBinders pat ++ acc +collectAcc (FunBind f _ _ _) acc = f : acc +collectAcc (VarBind f _) acc = noLoc f : acc +collectAcc (AbsBinds _ _ dbinds binds) acc + = [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc -- ++ foldr collectAcc acc binds -- I don't think we want the binders from the nested binds -- The only time we collect binders from a typechecked -- binding (hence see AbsBinds) is in zonking in TcHsSyn -collectHsBindBinders :: Bag (LHsBind name) -> [name] +collectHsBindBinders :: LHsBinds name -> [name] collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds) -collectHsBindLocatedBinders :: Bag (LHsBind name) -> [Located name] +collectHsBindLocatedBinders :: LHsBinds name -> [Located name] collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds \end{code} @@ -312,20 +316,21 @@ collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds Get all the pattern type signatures out of a bunch of bindings \begin{code} -collectSigTysFromHsBinds :: [LHsBind name] -> [LHsType name] -collectSigTysFromHsBinds binds = concat (map collectSigTysFromHsBind binds) +collectSigTysFromHsBinds :: LHsBinds name -> [LHsType name] +collectSigTysFromHsBinds binds = concatMap collectSigTysFromHsBind (bagToList binds) collectSigTysFromHsBind :: LHsBind name -> [LHsType name] collectSigTysFromHsBind bind = go (unLoc bind) where - go (PatBind pat _ _) + go (PatBind pat _ _ _) = collectSigTysFromPat pat - go (FunBind f _ (MatchGroup ms _)) + go (FunBind f _ (MatchGroup ms _) _) = [sig | L _ (Match [] (Just sig) _) <- ms] -- A binding like x :: a = f y -- is parsed as FunMonoBind, but for this purpose we -- want to treat it as a pattern binding + go out_bind = panic "collectSigTysFromHsBind" \end{code} %************************************************************************ @@ -335,19 +340,22 @@ collectSigTysFromHsBind bind %************************************************************************ \begin{code} -collectStmtsBinders :: [LStmt id] -> [Located id] -collectStmtsBinders = concatMap collectLStmtBinders +collectLStmtsBinders :: [LStmt id] -> [Located id] +collectLStmtsBinders = concatMap collectLStmtBinders +collectStmtsBinders :: [Stmt id] -> [Located id] +collectStmtsBinders = concatMap collectStmtBinders + +collectLStmtBinders :: LStmt id -> [Located id] collectLStmtBinders = collectStmtBinders . unLoc collectStmtBinders :: Stmt id -> [Located id] -- Id Binders for a Stmt... [but what about pattern-sig type vars]? -collectStmtBinders (BindStmt pat _) = collectLocatedPatBinders pat -collectStmtBinders (LetStmt binds) = collectGroupBinders binds -collectStmtBinders (ExprStmt _ _) = [] -collectStmtBinders (ResultStmt _) = [] -collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss -collectStmtBinders other = panic "collectStmtBinders" +collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat +collectStmtBinders (LetStmt binds) = collectLocalBinders binds +collectStmtBinders (ExprStmt _ _ _) = [] +collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss +collectStmtBinders other = panic "collectStmtBinders" \end{code} @@ -378,37 +386,34 @@ collectLocatedPatsBinders :: [LPat a] -> [Located a] collectLocatedPatsBinders pats = foldr collectl [] pats --------------------- -collectl (L l (VarPat var)) bndrs = L l var : bndrs -collectl (L l (VarPatOut var bs)) bndrs = L l var : collectHsBindLocatedBinders bs - ++ bndrs -collectl (L l pat) bndrs = collect pat bndrs - ---------------------- -collect (WildPat _) bndrs = bndrs -collect (LazyPat pat) bndrs = collectl pat bndrs -collect (AsPat a pat) bndrs = a : collectl pat bndrs -collect (ParPat pat) bndrs = collectl pat bndrs - -collect (ListPat pats _) bndrs = foldr collectl bndrs pats -collect (PArrPat pats _) bndrs = foldr collectl bndrs pats -collect (TuplePat pats _) bndrs = foldr collectl bndrs pats - -collect (ConPatIn c ps) bndrs = foldr collectl bndrs (hsConArgs ps) -collect (ConPatOut c _ ds bs ps _) bndrs = map noLoc ds - ++ collectHsBindLocatedBinders bs - ++ foldr collectl bndrs (hsConArgs ps) -collect (LitPat _) bndrs = bndrs -collect (NPatIn _ _) bndrs = bndrs -collect (NPatOut _ _ _) bndrs = bndrs - -collect (NPlusKPatIn n _ _) bndrs = n : bndrs -collect (NPlusKPatOut n _ _ _) bndrs = n : bndrs - -collect (SigPatIn pat _) bndrs = collectl pat bndrs -collect (SigPatOut pat _) bndrs = collectl pat bndrs -collect (TypePat ty) bndrs = bndrs -collect (DictPat ids1 ids2) bndrs = map noLoc ids1 ++ map noLoc ids2 - ++ bndrs +collectl (L l pat) bndrs + = go pat + where + go (VarPat var) = L l var : bndrs + go (VarPatOut var bs) = L l var : collectHsBindLocatedBinders bs + ++ bndrs + go (WildPat _) = bndrs + go (LazyPat pat) = collectl pat bndrs + go (AsPat a pat) = a : collectl pat bndrs + go (ParPat pat) = collectl pat bndrs + + go (ListPat pats _) = foldr collectl bndrs pats + go (PArrPat pats _) = foldr collectl bndrs pats + go (TuplePat pats _) = foldr collectl bndrs pats + + go (ConPatIn c ps) = foldr collectl bndrs (hsConArgs ps) + go (ConPatOut c _ ds bs ps _) = map noLoc ds + ++ collectHsBindLocatedBinders bs + ++ foldr collectl bndrs (hsConArgs ps) + go (LitPat _) = bndrs + go (NPat _ _ _ _) = bndrs + go (NPlusKPat n _ _ _) = n : bndrs + + go (SigPatIn pat _) = collectl pat bndrs + go (SigPatOut pat _) = collectl pat bndrs + go (TypePat ty) = bndrs + go (DictPat ids1 ids2) = map noLoc ids1 ++ map noLoc ids2 + ++ bndrs \end{code} \begin{code}