summary |
shortlog |
log |
commit | commitdiff |
tree
raw |
patch |
inline | side by side (from parent 1:
e79d44f)
Wibbles to the big HsBinds reorg
%************************************************************************
\begin{code}
%************************************************************************
\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
= 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
------------
mk_FunBind :: SrcSpan -> RdrName
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 pats expr binds
= noLoc (Match (map paren pats) Nothing
mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id
mkMatch pats expr binds
= noLoc (Match (map paren pats) Nothing
collectHsValBinders :: HsValBinds name -> [Located name]
collectHsValBinders (ValBindsIn binds sigs) = collectHsBindLocatedBinders binds
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
collectAcc :: HsBind name -> [Located name] -> [Located name]
collectAcc (PatBind pat _ _ _) acc = collectLocatedPatBinders pat ++ acc
in
listToBag [
mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
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
nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
]
where
tycon_loc = getSrcSpan 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
compare_rhs
| single_con_type = cmp_eq_Expr a_Expr b_Expr
| otherwise
occ_nm = getOccString tycon
succ_enum
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]])
untag_Expr tycon [(a_RDR, ah_RDR)] $
nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
nlHsVarApps intDataCon_RDR [ah_RDR]])
nlHsIntLit 1]))
pred_enum
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]])
untag_Expr tycon [(a_RDR, ah_RDR)] $
nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
nlHsVarApps intDataCon_RDR [ah_RDR]])
nlHsLit (HsInt (-1))]))
to_enum
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)]])
nlHsIf (nlHsApps and_RDR
[nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
(illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
enum_from
(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),
untag_Expr tycon [(a_RDR, ah_RDR)] $
nlHsApps map_RDR
[nlHsVar (tag2con_RDR tycon),
(nlHsVar (maxtag_RDR tycon)))]
enum_from_then
(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
untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
nlHsPar (enum_from_then_to_Expr
- = 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}
untag_Expr tycon [(a_RDR, ah_RDR)] $
(nlHsVarApps intDataCon_RDR [ah_RDR])
\end{code}
enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
enum_range
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]) $
untag_Expr tycon [(a_RDR, ah_RDR)] $
untag_Expr tycon [(b_RDR, bh_RDR)] $
nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
= mk_easy_FunBind tycon_loc unsafeIndex_RDR
[noLoc (AsPat (noLoc c_RDR)
(nlTuplePat [a_Pat, nlWildPat] Boxed)),
= mk_easy_FunBind tycon_loc unsafeIndex_RDR
[noLoc (AsPat (noLoc c_RDR)
(nlTuplePat [a_Pat, nlWildPat] Boxed)),
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(d_RDR, dh_RDR)] (
let
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(d_RDR, dh_RDR)] (
let
- = 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)] (
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(b_RDR, bh_RDR)] (
untag_Expr tycon [(c_RDR, ch_RDR)] (
(genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
) {-else-} (
false_Expr
(genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
) {-else-} (
false_Expr
--------------------------------------------------------------
single_con_ixes
--------------------------------------------------------------
single_con_ixes
--------------------------------------------------------------
single_con_range
= mk_easy_FunBind tycon_loc range_RDR
--------------------------------------------------------------
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
nlHsDo ListComp stmts con_expr
where
stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
single_con_index
= mk_easy_FunBind tycon_loc unsafeIndex_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
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
(mk_index (zip3 as_needed bs_needed cs_needed))
where
-- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
(mk_index (zip3 as_needed bs_needed cs_needed))
where
-- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
single_con_inRange
= mk_easy_FunBind tycon_loc inRange_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
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]
where
in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
nlHsVar c]
= unitBag $
mk_easy_FunBind tycon_loc
(mk_typeOf_RDR tycon) -- Name of appropriate type0f function
= unitBag $
mk_easy_FunBind tycon_loc
(mk_typeOf_RDR tycon) -- Name of appropriate type0f function
- [nlWildPat] emptyLHsBinds
(nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
where
tycon_loc = getSrcSpan tycon
(nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
where
tycon_loc = getSrcSpan tycon
tycon_loc
dataTypeOf_RDR
[nlWildPat]
tycon_loc
dataTypeOf_RDR
[nlWildPat]
(nlHsVar data_type_name)
------------ $dT
(nlHsVar data_type_name)
------------ $dT
#ifdef GHCI
import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..),
HsLocalBinds(..), HsValBinds(..),
#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,
collectLStmtsBinders, collectLStmtBinders, nlVarPat,
placeHolderType, noSyntaxExpr )
import RdrName ( GlobalRdrElt(..), globalRdrEnvElts,
ModIface(..), icPrintUnqual,
Dependencies(..) )
import BasicTypes ( Fixity )
ModIface(..), icPrintUnqual,
Dependencies(..) )
import BasicTypes ( Fixity )
-import SrcLoc ( unLoc, noSrcSpan )
#endif
import FastString ( mkFastString )
#endif
import FastString ( mkFastString )
mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt
= do { uniq <- newUnique -- is treated very specially
; let fresh_it = itName uniq
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
let_stmt = L loc $ LetStmt (HsValBinds (ValBindsIn (unitBag the_bind) []))
bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
(HsVar bindIOName) noSyntaxExpr