X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsUtils.lhs;h=f8efa6cfb94f206e7047953e32c87d6b486eacac;hb=9d7da331989abcd1844e9d03b8d1e4163796fa85;hp=6134d5043c531adf7d46e52c526cdb805fdc87ca;hpb=d551dbfef0b710f5ede21ee0c54ee7e80dd53b64;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsUtils.lhs b/ghc/compiler/hsSyn/HsUtils.lhs index 6134d50..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,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 @@ -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,10 +114,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 +136,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} @@ -222,36 +226,32 @@ nlHsFunTy a b = noLoc (HsFunTy a b) \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 - -mk_easy_FunBind loc fun pats binds expr - = L loc (FunBind (L loc fun) False{-not infix-} - (mkMatchGroup [mk_easy_Match pats binds expr])) + -> 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 (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 @@ -277,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} @@ -313,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} %************************************************************************ @@ -348,7 +352,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"