Commit 70b59eb3 authored by simonpj's avatar simonpj

[project @ 2005-07-25 11:10:33 by simonpj]

Wibbles to the big HsBinds reorg
parent e79d44f1
...@@ -221,18 +221,17 @@ nlHsFunTy a b = noLoc (HsFunTy a b) ...@@ -221,18 +221,17 @@ nlHsFunTy a b = noLoc (HsFunTy a b)
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
mkVarBind :: SrcSpan -> name -> LHsExpr name -> LHsBind name 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 -> name -> [LPat name] mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
-> LHsBinds name -> LHsExpr name -> LHsExpr RdrName -> LHsBind RdrName
-> LHsBind name
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) = L loc (FunBind (L loc fun) False{-not infix-} matches placeHolderNames)
where where
matches = mkMatchGroup [mk_easy_Match pats binds expr] matches = mkMatchGroup [mkMatch pats expr emptyLocalBinds]
------------ ------------
mk_FunBind :: SrcSpan -> RdrName mk_FunBind :: SrcSpan -> RdrName
...@@ -245,10 +244,6 @@ mk_FunBind loc fun pats_and_exprs ...@@ -245,10 +244,6 @@ mk_FunBind loc fun pats_and_exprs
where where
matches = mkMatchGroup [mkMatch p e emptyLocalBinds | (p,e) <-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 :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
mkMatch pats expr binds mkMatch pats expr binds
...@@ -285,7 +280,9 @@ collectLocalBinders EmptyLocalBinds = [] ...@@ -285,7 +280,9 @@ collectLocalBinders EmptyLocalBinds = []
collectHsValBinders :: HsValBinds name -> [Located name] collectHsValBinders :: HsValBinds name -> [Located name]
collectHsValBinders (ValBindsIn binds sigs) = collectHsBindLocatedBinders binds 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 :: HsBind name -> [Located name] -> [Located name]
collectAcc (PatBind pat _ _ _) acc = collectLocatedPatBinders pat ++ acc collectAcc (PatBind pat _ _ _) acc = collectLocatedPatBinders pat ++ acc
......
...@@ -167,7 +167,7 @@ gen_Eq_binds tycon ...@@ -167,7 +167,7 @@ gen_Eq_binds tycon
in in
listToBag [ listToBag [
mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest), 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]))) nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
] ]
where where
...@@ -298,8 +298,10 @@ gen_Ord_binds tycon ...@@ -298,8 +298,10 @@ gen_Ord_binds tycon
tycon_loc = getSrcSpan tycon tycon_loc = getSrcSpan tycon
-------------------------------------------------------------------- --------------------------------------------------------------------
compare = mk_easy_FunBind tycon_loc compare_RDR compare = L tycon_loc (FunBind (L tycon_loc compare_RDR) False compare_matches placeHolderNames)
[a_Pat, b_Pat] (unitBag cmp_eq) compare_rhs compare_matches = mkMatchGroup [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
cmp_eq_binds = HsValBinds (ValBindsIn (unitBag cmp_eq) [])
compare_rhs compare_rhs
| single_con_type = cmp_eq_Expr a_Expr b_Expr | single_con_type = cmp_eq_Expr a_Expr b_Expr
| otherwise | otherwise
...@@ -417,7 +419,7 @@ gen_Enum_binds tycon ...@@ -417,7 +419,7 @@ gen_Enum_binds tycon
occ_nm = getOccString tycon occ_nm = getOccString tycon
succ_enum 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)] $ untag_Expr tycon [(a_RDR, ah_RDR)] $
nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon), nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
nlHsVarApps intDataCon_RDR [ah_RDR]]) nlHsVarApps intDataCon_RDR [ah_RDR]])
...@@ -427,7 +429,7 @@ gen_Enum_binds tycon ...@@ -427,7 +429,7 @@ gen_Enum_binds tycon
nlHsIntLit 1])) nlHsIntLit 1]))
pred_enum 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)] $ untag_Expr tycon [(a_RDR, ah_RDR)] $
nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
nlHsVarApps intDataCon_RDR [ah_RDR]]) nlHsVarApps intDataCon_RDR [ah_RDR]])
...@@ -437,7 +439,7 @@ gen_Enum_binds tycon ...@@ -437,7 +439,7 @@ gen_Enum_binds tycon
nlHsLit (HsInt (-1))])) nlHsLit (HsInt (-1))]))
to_enum 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 nlHsIf (nlHsApps and_RDR
[nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0], [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]]) nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
...@@ -445,7 +447,7 @@ gen_Enum_binds tycon ...@@ -445,7 +447,7 @@ gen_Enum_binds tycon
(illegal_toEnum_tag occ_nm (maxtag_RDR tycon)) (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
enum_from 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)] $ untag_Expr tycon [(a_RDR, ah_RDR)] $
nlHsApps map_RDR nlHsApps map_RDR
[nlHsVar (tag2con_RDR tycon), [nlHsVar (tag2con_RDR tycon),
...@@ -454,7 +456,7 @@ gen_Enum_binds tycon ...@@ -454,7 +456,7 @@ gen_Enum_binds tycon
(nlHsVar (maxtag_RDR tycon)))] (nlHsVar (maxtag_RDR tycon)))]
enum_from_then 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)] $ untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
nlHsPar (enum_from_then_to_Expr nlHsPar (enum_from_then_to_Expr
...@@ -467,7 +469,7 @@ gen_Enum_binds tycon ...@@ -467,7 +469,7 @@ gen_Enum_binds tycon
)) ))
from_enum 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)] $ untag_Expr tycon [(a_RDR, ah_RDR)] $
(nlHsVarApps intDataCon_RDR [ah_RDR]) (nlHsVarApps intDataCon_RDR [ah_RDR])
\end{code} \end{code}
...@@ -579,8 +581,7 @@ gen_Ix_binds tycon ...@@ -579,8 +581,7 @@ gen_Ix_binds tycon
enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ] enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
enum_range enum_range
= mk_easy_FunBind tycon_loc range_RDR = mk_easy_FunBind tycon_loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
[nlTuplePat [a_Pat, b_Pat] Boxed] emptyLHsBinds $
untag_Expr tycon [(a_RDR, ah_RDR)] $ untag_Expr tycon [(a_RDR, ah_RDR)] $
untag_Expr tycon [(b_RDR, bh_RDR)] $ untag_Expr tycon [(b_RDR, bh_RDR)] $
nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $ nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
...@@ -592,7 +593,7 @@ gen_Ix_binds tycon ...@@ -592,7 +593,7 @@ gen_Ix_binds tycon
= mk_easy_FunBind tycon_loc unsafeIndex_RDR = mk_easy_FunBind tycon_loc unsafeIndex_RDR
[noLoc (AsPat (noLoc c_RDR) [noLoc (AsPat (noLoc c_RDR)
(nlTuplePat [a_Pat, nlWildPat] Boxed)), (nlTuplePat [a_Pat, nlWildPat] Boxed)),
d_Pat] emptyLHsBinds ( d_Pat] (
untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(d_RDR, dh_RDR)] ( untag_Expr tycon [(d_RDR, dh_RDR)] (
let let
...@@ -605,8 +606,7 @@ gen_Ix_binds tycon ...@@ -605,8 +606,7 @@ gen_Ix_binds tycon
) )
enum_inRange enum_inRange
= mk_easy_FunBind tycon_loc inRange_RDR = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
[nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] emptyLHsBinds (
untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(b_RDR, bh_RDR)] ( untag_Expr tycon [(b_RDR, bh_RDR)] (
untag_Expr tycon [(c_RDR, ch_RDR)] ( untag_Expr tycon [(c_RDR, ch_RDR)] (
...@@ -614,7 +614,7 @@ gen_Ix_binds tycon ...@@ -614,7 +614,7 @@ gen_Ix_binds tycon
(genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR)) (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
) {-else-} ( ) {-else-} (
false_Expr false_Expr
))))) ))))
-------------------------------------------------------------- --------------------------------------------------------------
single_con_ixes single_con_ixes
...@@ -640,7 +640,7 @@ gen_Ix_binds tycon ...@@ -640,7 +640,7 @@ gen_Ix_binds tycon
-------------------------------------------------------------- --------------------------------------------------------------
single_con_range single_con_range
= mk_easy_FunBind tycon_loc range_RDR = 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 nlHsDo ListComp stmts con_expr
where where
stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
...@@ -653,7 +653,7 @@ gen_Ix_binds tycon ...@@ -653,7 +653,7 @@ gen_Ix_binds tycon
single_con_index single_con_index
= mk_easy_FunBind tycon_loc unsafeIndex_RDR = mk_easy_FunBind tycon_loc unsafeIndex_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, [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)) (mk_index (zip3 as_needed bs_needed cs_needed))
where where
-- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...) -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
...@@ -675,9 +675,8 @@ gen_Ix_binds tycon ...@@ -675,9 +675,8 @@ gen_Ix_binds tycon
single_con_inRange single_con_inRange
= mk_easy_FunBind tycon_loc inRange_RDR = mk_easy_FunBind tycon_loc inRange_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
con_pat cs_needed] con_pat cs_needed] $
emptyLHsBinds ( foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
where where
in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed, in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
nlHsVar c] nlHsVar c]
...@@ -994,7 +993,7 @@ gen_Typeable_binds tycon ...@@ -994,7 +993,7 @@ gen_Typeable_binds tycon
= unitBag $ = unitBag $
mk_easy_FunBind tycon_loc mk_easy_FunBind tycon_loc
(mk_typeOf_RDR tycon) -- Name of appropriate type0f function (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
[nlWildPat] emptyLHsBinds [nlWildPat]
(nlHsApps mkTypeRep_RDR [tycon_rep, nlList []]) (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
where where
tycon_loc = getSrcSpan tycon tycon_loc = getSrcSpan tycon
...@@ -1100,7 +1099,6 @@ gen_Data_binds fix_env tycon ...@@ -1100,7 +1099,6 @@ gen_Data_binds fix_env tycon
tycon_loc tycon_loc
dataTypeOf_RDR dataTypeOf_RDR
[nlWildPat] [nlWildPat]
emptyLHsBinds
(nlHsVar data_type_name) (nlHsVar data_type_name)
------------ $dT ------------ $dT
......
...@@ -84,7 +84,7 @@ import Outputable ...@@ -84,7 +84,7 @@ import Outputable
#ifdef GHCI #ifdef GHCI
import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..),
HsLocalBinds(..), HsValBinds(..), HsLocalBinds(..), HsValBinds(..),
LStmt, LHsExpr, LHsType, mkVarBind, LStmt, LHsExpr, LHsType, mkMatchGroup, mkMatch, emptyLocalBinds,
collectLStmtsBinders, collectLStmtBinders, nlVarPat, collectLStmtsBinders, collectLStmtBinders, nlVarPat,
placeHolderType, noSyntaxExpr ) placeHolderType, noSyntaxExpr )
import RdrName ( GlobalRdrElt(..), globalRdrEnvElts, import RdrName ( GlobalRdrElt(..), globalRdrEnvElts,
...@@ -122,7 +122,7 @@ import HscTypes ( InteractiveContext(..), ...@@ -122,7 +122,7 @@ import HscTypes ( InteractiveContext(..),
ModIface(..), icPrintUnqual, ModIface(..), icPrintUnqual,
Dependencies(..) ) Dependencies(..) )
import BasicTypes ( Fixity ) import BasicTypes ( Fixity )
import SrcLoc ( unLoc, noSrcSpan ) import SrcLoc ( unLoc )
#endif #endif
import FastString ( mkFastString ) import FastString ( mkFastString )
...@@ -950,7 +950,8 @@ mkPlan :: LStmt Name -> TcM PlanResult ...@@ -950,7 +950,8 @@ mkPlan :: LStmt Name -> TcM PlanResult
mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt
= do { uniq <- newUnique -- is treated very specially = do { uniq <- newUnique -- is treated very specially
; let fresh_it = itName uniq ; 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) [])) let_stmt = L loc $ LetStmt (HsValBinds (ValBindsIn (unitBag the_bind) []))
bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
(HsVar bindIOName) noSyntaxExpr (HsVar bindIOName) noSyntaxExpr
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment