From 70b59eb3397c68f10ce429c0ffcf5ed63d86d3d3 Mon Sep 17 00:00:00 2001 From: simonpj Date: Mon, 25 Jul 2005 11:10:34 +0000 Subject: [PATCH] [project @ 2005-07-25 11:10:33 by simonpj] Wibbles to the big HsBinds reorg --- ghc/compiler/hsSyn/HsUtils.lhs | 21 +++++++---------- ghc/compiler/typecheck/TcGenDeriv.lhs | 42 ++++++++++++++++----------------- ghc/compiler/typecheck/TcRnDriver.lhs | 7 +++--- 3 files changed, 33 insertions(+), 37 deletions(-) diff --git a/ghc/compiler/hsSyn/HsUtils.lhs b/ghc/compiler/hsSyn/HsUtils.lhs index 8019f36..2e33d4e 100644 --- a/ghc/compiler/hsSyn/HsUtils.lhs +++ b/ghc/compiler/hsSyn/HsUtils.lhs @@ -221,18 +221,17 @@ 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 +mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName +mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs ------------ -mk_easy_FunBind :: SrcSpan -> name -> [LPat name] - -> LHsBinds name -> LHsExpr name - -> LHsBind name +mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName] + -> LHsExpr RdrName -> LHsBind RdrName -mk_easy_FunBind loc fun pats binds expr +mk_easy_FunBind loc fun pats expr = L loc (FunBind (L loc fun) False{-not infix-} matches placeHolderNames) where - matches = mkMatchGroup [mk_easy_Match pats binds expr] + matches = mkMatchGroup [mkMatch pats expr emptyLocalBinds] ------------ mk_FunBind :: SrcSpan -> RdrName @@ -246,10 +245,6 @@ mk_FunBind loc fun pats_and_exprs matches = mkMatchGroup [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs] ------------ -mk_easy_Match pats binds expr - = mkMatch pats expr (HsValBinds (ValBindsIn binds [])) - ------------- mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id mkMatch pats expr binds = noLoc (Match (map paren pats) Nothing @@ -285,7 +280,9 @@ collectLocalBinders EmptyLocalBinds = [] collectHsValBinders :: HsValBinds name -> [Located name] collectHsValBinders (ValBindsIn binds sigs) = collectHsBindLocatedBinders binds -collectHsValBinders (ValBindsOut binds) = panic "collectHsValBinders" +collectHsValBinders (ValBindsOut binds) = 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 diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index b184513..a0d1c85 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -167,7 +167,7 @@ gen_Eq_binds tycon in listToBag [ mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest), - mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] emptyLHsBinds ( + mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] ( nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR]))) ] where @@ -298,8 +298,10 @@ gen_Ord_binds tycon tycon_loc = getSrcSpan tycon -------------------------------------------------------------------- - compare = mk_easy_FunBind tycon_loc compare_RDR - [a_Pat, b_Pat] (unitBag cmp_eq) compare_rhs + compare = L tycon_loc (FunBind (L tycon_loc compare_RDR) False compare_matches placeHolderNames) + compare_matches = mkMatchGroup [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds] + cmp_eq_binds = HsValBinds (ValBindsIn (unitBag cmp_eq) []) + compare_rhs | single_con_type = cmp_eq_Expr a_Expr b_Expr | otherwise @@ -417,7 +419,7 @@ gen_Enum_binds tycon occ_nm = getOccString tycon succ_enum - = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] emptyLHsBinds $ + = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon), nlHsVarApps intDataCon_RDR [ah_RDR]]) @@ -427,7 +429,7 @@ gen_Enum_binds tycon nlHsIntLit 1])) pred_enum - = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] emptyLHsBinds $ + = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, nlHsVarApps intDataCon_RDR [ah_RDR]]) @@ -437,7 +439,7 @@ gen_Enum_binds tycon nlHsLit (HsInt (-1))])) to_enum - = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] emptyLHsBinds $ + = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] $ nlHsIf (nlHsApps and_RDR [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0], nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]]) @@ -445,7 +447,7 @@ gen_Enum_binds tycon (illegal_toEnum_tag occ_nm (maxtag_RDR tycon)) enum_from - = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] emptyLHsBinds $ + = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ nlHsApps map_RDR [nlHsVar (tag2con_RDR tycon), @@ -454,7 +456,7 @@ gen_Enum_binds tycon (nlHsVar (maxtag_RDR tycon)))] enum_from_then - = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] emptyLHsBinds $ + = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $ nlHsPar (enum_from_then_to_Expr @@ -467,7 +469,7 @@ gen_Enum_binds tycon )) from_enum - = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] emptyLHsBinds $ + = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ (nlHsVarApps intDataCon_RDR [ah_RDR]) \end{code} @@ -579,8 +581,7 @@ gen_Ix_binds tycon enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ] enum_range - = mk_easy_FunBind tycon_loc range_RDR - [nlTuplePat [a_Pat, b_Pat] Boxed] emptyLHsBinds $ + = mk_easy_FunBind tycon_loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ untag_Expr tycon [(b_RDR, bh_RDR)] $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $ @@ -592,7 +593,7 @@ gen_Ix_binds tycon = mk_easy_FunBind tycon_loc unsafeIndex_RDR [noLoc (AsPat (noLoc c_RDR) (nlTuplePat [a_Pat, nlWildPat] Boxed)), - d_Pat] emptyLHsBinds ( + d_Pat] ( untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(d_RDR, dh_RDR)] ( let @@ -605,8 +606,7 @@ gen_Ix_binds tycon ) enum_inRange - = mk_easy_FunBind tycon_loc inRange_RDR - [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] emptyLHsBinds ( + = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $ untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(b_RDR, bh_RDR)] ( untag_Expr tycon [(c_RDR, ch_RDR)] ( @@ -614,7 +614,7 @@ gen_Ix_binds tycon (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR)) ) {-else-} ( false_Expr - ))))) + )))) -------------------------------------------------------------- single_con_ixes @@ -640,7 +640,7 @@ gen_Ix_binds tycon -------------------------------------------------------------- single_con_range = mk_easy_FunBind tycon_loc range_RDR - [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] emptyLHsBinds $ + [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ nlHsDo ListComp stmts con_expr where stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed @@ -653,7 +653,7 @@ gen_Ix_binds tycon single_con_index = mk_easy_FunBind tycon_loc unsafeIndex_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, - con_pat cs_needed] emptyBag + con_pat cs_needed] (mk_index (zip3 as_needed bs_needed cs_needed)) where -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...) @@ -675,9 +675,8 @@ gen_Ix_binds tycon single_con_inRange = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, - con_pat cs_needed] - emptyLHsBinds ( - foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)) + con_pat cs_needed] $ + foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed) where in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed, nlHsVar c] @@ -994,7 +993,7 @@ gen_Typeable_binds tycon = unitBag $ mk_easy_FunBind tycon_loc (mk_typeOf_RDR tycon) -- Name of appropriate type0f function - [nlWildPat] emptyLHsBinds + [nlWildPat] (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []]) where tycon_loc = getSrcSpan tycon @@ -1100,7 +1099,6 @@ gen_Data_binds fix_env tycon tycon_loc dataTypeOf_RDR [nlWildPat] - emptyLHsBinds (nlHsVar data_type_name) ------------ $dT diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index c9f03c3..fb7f803 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -84,7 +84,7 @@ import Outputable #ifdef GHCI import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsLocalBinds(..), HsValBinds(..), - LStmt, LHsExpr, LHsType, mkVarBind, + LStmt, LHsExpr, LHsType, mkMatchGroup, mkMatch, emptyLocalBinds, collectLStmtsBinders, collectLStmtBinders, nlVarPat, placeHolderType, noSyntaxExpr ) import RdrName ( GlobalRdrElt(..), globalRdrEnvElts, @@ -122,7 +122,7 @@ import HscTypes ( InteractiveContext(..), ModIface(..), icPrintUnqual, Dependencies(..) ) import BasicTypes ( Fixity ) -import SrcLoc ( unLoc, noSrcSpan ) +import SrcLoc ( unLoc ) #endif import FastString ( mkFastString ) @@ -950,7 +950,8 @@ mkPlan :: LStmt Name -> TcM PlanResult mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt = do { uniq <- newUnique -- is treated very specially ; let fresh_it = itName uniq - the_bind = mkVarBind noSrcSpan fresh_it expr + the_bind = L loc $ FunBind (L loc fresh_it) False matches emptyNameSet + matches = mkMatchGroup [mkMatch [] expr emptyLocalBinds] let_stmt = L loc $ LetStmt (HsValBinds (ValBindsIn (unitBag the_bind) [])) bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr (HsVar bindIOName) noSyntaxExpr -- 1.7.10.4