X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsUtils.lhs;h=d9c45e6529c177edea88066958f869a35576627a;hb=5d3051c66796dcf884b052f9e4afc3ed19b9f514;hp=d2e757e37307ed8a85b4f342e1617c66ed36dc39;hpb=02a06a56c6511b19ef411fd3884089ea996cc26b;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsUtils.lhs b/ghc/compiler/hsSyn/HsUtils.lhs index d2e757e..d9c45e6 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,7 +56,7 @@ 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 @@ -79,6 +79,10 @@ mkHsDictApp :: LHsExpr name -> [name] -> LHsExpr name mkHsDictApp expr [] = expr mkHsDictApp expr dict_vars = L (getLoc expr) (DictApp expr dict_vars) +mkHsCoerce :: ExprCoFn -> HsExpr id -> HsExpr id +mkHsCoerce co_fn e | isIdCoercion co_fn = e + | otherwise = HsCoerce co_fn e + mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) where @@ -93,10 +97,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,10 +118,6 @@ mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id mkSimpleHsAlt pat expr = mkSimpleMatch [pat] expr -glueBindsOnGRHSs :: HsBindGroup id -> GRHSs id -> GRHSs id -glueBindsOnGRHSs binds1 (GRHSs grhss binds2) - = GRHSs grhss (binds1 : binds2) - ------------------------------- -- These are the bits of syntax that contain rebindable names -- See RnEnv.lookupSyntaxName @@ -136,11 +140,15 @@ 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} @@ -192,7 +200,7 @@ nlWildConPat :: DataCon -> LPat RdrName nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat))) -nlTuplePat pats box = noLoc (TuplePat pats box) +nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType) nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id @@ -221,37 +229,37 @@ nlHsFunTy a b = noLoc (HsFunTy a b) %************************************************************************ \begin{code} -mkVarBind :: SrcSpan -> name -> LHsExpr name -> LHsBind name -mkVarBind loc var rhs = mk_easy_FunBind loc var [] emptyLHsBinds rhs +mkFunBind :: Located id -> [LMatch id] -> HsBind id +-- Not infix, with place holders for coercion and free vars +mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatchGroup ms, + fun_co_fn = idCoercion, bind_fvs = placeHolderNames } + -mk_easy_FunBind :: SrcSpan -> name -> [LPat name] - -> LHsBinds name -> LHsExpr name - -> LHsBind name +mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName +mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs -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_FunBind :: SrcSpan -> RdrName -> [LPat RdrName] + -> LHsExpr RdrName -> LHsBind RdrName -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 $ mkFunBind (L loc fun) [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 $ mkFunBind (L loc fun) matches + where + matches = [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 @@ -277,60 +285,38 @@ 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_lhs = p }) acc = collectLocatedPatBinders p ++ acc +collectAcc (FunBind { fun_id = f }) acc = f : acc +collectAcc (VarBind { var_id = f }) acc = noLoc f : acc +collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = 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} %************************************************************************ %* * - Getting pattern signatures out of bindings -%* * -%************************************************************************ - -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) - -collectSigTysFromHsBind :: LHsBind name -> [LHsType name] -collectSigTysFromHsBind bind - = go (unLoc bind) - where - go (PatBind pat _ _) - = collectSigTysFromPat pat - 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 -\end{code} - -%************************************************************************ -%* * Getting binders from statements %* * %************************************************************************ @@ -348,7 +334,7 @@ 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 (LetStmt binds) = collectLocalBinders binds collectStmtBinders (ExprStmt _ _ _) = [] collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss collectStmtBinders other = panic "collectStmtBinders" @@ -390,12 +376,13 @@ collectl (L l pat) bndrs ++ bndrs go (WildPat _) = bndrs go (LazyPat pat) = collectl pat bndrs + go (BangPat 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 (TuplePat pats _ _) = foldr collectl bndrs pats go (ConPatIn c ps) = foldr collectl bndrs (hsConArgs ps) go (ConPatOut c _ ds bs ps _) = map noLoc ds @@ -421,15 +408,16 @@ collectSigTysFromPat pat = collect_lpat pat [] collect_lpat pat acc = collect_pat (unLoc pat) acc -collect_pat (SigPatIn pat ty) acc = collect_lpat pat (ty:acc) -collect_pat (TypePat ty) acc = ty:acc - -collect_pat (LazyPat pat) acc = collect_lpat pat acc -collect_pat (AsPat a pat) acc = collect_lpat pat acc -collect_pat (ParPat pat) acc = collect_lpat pat acc -collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats -collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats -collect_pat (TuplePat pats _) acc = foldr collect_lpat acc pats -collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps) -collect_pat other acc = acc -- Literals, vars, wildcard +collect_pat (SigPatIn pat ty) acc = collect_lpat pat (ty:acc) +collect_pat (TypePat ty) acc = ty:acc + +collect_pat (LazyPat pat) acc = collect_lpat pat acc +collect_pat (BangPat pat) acc = collect_lpat pat acc +collect_pat (AsPat a pat) acc = collect_lpat pat acc +collect_pat (ParPat pat) acc = collect_lpat pat acc +collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats +collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats +collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats +collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps) +collect_pat other acc = acc -- Literals, vars, wildcard \end{code}