Commit eeaea2df authored by cactus's avatar cactus

Instead of tracking Origin in LHsBindsLR, track it in MatchGroup

parent 7fa0b435
......@@ -117,7 +117,7 @@ guessSourceFile :: LHsBinds Id -> FilePath -> FilePath
guessSourceFile binds orig_file =
-- Try look for a file generated from a .hsc file to a
-- .hs file, by peeking ahead.
let top_pos = catMaybes $ foldrBag (\ (_, (L pos _)) rest ->
let top_pos = catMaybes $ foldrBag (\ (L pos _) rest ->
srcSpanFileName_maybe pos : rest) [] binds
in
case top_pos of
......@@ -229,11 +229,7 @@ shouldTickPatBind density top_lev
-- Adding ticks to bindings
addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
addTickLHsBinds binds = mapBagM addTick binds
where
addTick (origin, bind) = do
bind' <- addTickLHsBind bind
return (origin, bind')
addTickLHsBinds = mapBagM addTickLHsBind
addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds,
......
......@@ -517,7 +517,7 @@ case bodies, containing the following fields:
\begin{code}
dsCmd ids local_vars stack_ty res_ty
(HsCmdCase exp (MG { mg_alts = matches, mg_arg_tys = arg_tys }))
(HsCmdCase exp (MG { mg_alts = matches, mg_arg_tys = arg_tys, mg_origin = origin }))
env_ids = do
stack_id <- newSysLocalDs stack_ty
......@@ -561,7 +561,7 @@ dsCmd ids local_vars stack_ty res_ty
in_ty = envStackType env_ids stack_ty
core_body <- dsExpr (HsCase exp (MG { mg_alts = matches', mg_arg_tys = arg_tys
, mg_res_ty = sum_ty }))
, mg_res_ty = sum_ty, mg_origin = origin }))
-- Note that we replace the HsCase result type by sum_ty,
-- which is the type of matches'
......
......@@ -95,13 +95,8 @@ ds_lhs_binds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
ds_lhs_binds binds = do { ds_bs <- mapBagM dsLHsBind binds
; return (foldBag appOL id nilOL ds_bs) }
dsLHsBind :: (Origin, LHsBind Id) -> DsM (OrdList (Id,CoreExpr))
dsLHsBind (origin, L loc bind)
= handleWarnings $ putSrcSpanDs loc $ dsHsBind bind
where
handleWarnings = if isGenerated origin
then discardWarningsDs
else id
dsLHsBind :: LHsBind Id -> DsM (OrdList (Id,CoreExpr))
dsLHsBind (L loc bind) = putSrcSpanDs loc $ dsHsBind bind
dsHsBind :: HsBind Id -> DsM (OrdList (Id,CoreExpr))
......
......@@ -99,7 +99,7 @@ ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
-- a tuple and doing selections.
-- Silently ignore INLINE and SPECIALISE pragmas...
ds_val_bind (NonRecursive, hsbinds) body
| [(_, L loc bind)] <- bagToList hsbinds,
| [L loc bind] <- bagToList hsbinds,
-- Non-recursive, non-overloaded bindings only come in ones
-- ToDo: in some bizarre case it's conceivable that there
-- could be dict binds in the 'binds'. (See the notes
......@@ -130,11 +130,11 @@ dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
, abs_exports = exports
, abs_ev_binds = ev_binds
, abs_binds = binds }) body
, abs_binds = lbinds }) body
= do { let body1 = foldr bind_export body exports
bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
; body2 <- foldlBagM (\body (_, bind) -> dsStrictBind (unLoc bind) body)
body1 binds
; body2 <- foldlBagM (\body lbind -> dsStrictBind (unLoc lbind) body)
body1 lbinds
; ds_binds <- dsTcEvBinds ev_binds
; return (mkCoreLets ds_binds body2) }
......@@ -163,8 +163,8 @@ dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
----------------------
strictMatchOnly :: HsBind Id -> Bool
strictMatchOnly (AbsBinds { abs_binds = binds })
= anyBag (strictMatchOnly . unLoc . snd) binds
strictMatchOnly (AbsBinds { abs_binds = lbinds })
= anyBag (strictMatchOnly . unLoc) lbinds
strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty })
= isUnLiftedType rhs_ty
|| isStrictLPat lpat
......@@ -488,7 +488,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
-- constructor aguments.
; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
; ([discrim_var], matching_code)
<- matchWrapper RecUpd (MG { mg_alts = alts, mg_arg_tys = [in_ty], mg_res_ty = out_ty })
<- matchWrapper RecUpd (MG { mg_alts = alts, mg_arg_tys = [in_ty], mg_res_ty = out_ty, mg_origin = Generated })
; return (add_field_binds field_binds' $
bindNonRec discrim_var record_expr' matching_code) }
......@@ -789,7 +789,8 @@ dsDo stmts
rets = map noLoc rec_rets
mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
mfix_arg = noLoc $ HsLam (MG { mg_alts = [mkSimpleMatch [mfix_pat] body]
, mg_arg_tys = [tup_ty], mg_res_ty = body_ty })
, mg_arg_tys = [tup_ty], mg_res_ty = body_ty
, mg_origin = Generated })
mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTup rec_tup_pats
body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
ret_app = nlHsApp (noLoc return_op) (mkBigLHsTup rets)
......
......@@ -1180,7 +1180,7 @@ rep_binds binds = do { binds_w_locs <- rep_binds' binds
; return (de_loc (sort_by_loc binds_w_locs)) }
rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)]
rep_binds' binds = mapM (rep_bind . snd) (bagToList binds)
rep_binds' = mapM rep_bind . bagToList
rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
-- Assumes: all the binders of the binding are alrady in the meta-env
......
......@@ -40,7 +40,7 @@ import Maybes
import Util
import Name
import Outputable
import BasicTypes ( boxityNormalTupleSort )
import BasicTypes ( boxityNormalTupleSort, isGenerated )
import FastString
import Control.Monad( when )
......@@ -752,12 +752,14 @@ JJQC 30-Nov-1997
\begin{code}
matchWrapper ctxt (MG { mg_alts = matches
, mg_arg_tys = arg_tys
, mg_res_ty = rhs_ty })
, mg_res_ty = rhs_ty
, mg_origin = origin })
= do { eqns_info <- mapM mk_eqn_info matches
; new_vars <- case matches of
[] -> mapM newSysLocalDs arg_tys
(m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))
; result_expr <- matchEquations ctxt new_vars eqns_info rhs_ty
; result_expr <- handleWarnings $
matchEquations ctxt new_vars eqns_info rhs_ty
; return (new_vars, result_expr) }
where
mk_eqn_info (L _ (Match pats _ grhss))
......@@ -765,6 +767,10 @@ matchWrapper ctxt (MG { mg_alts = matches
; match_result <- dsGRHSs ctxt upats grhss rhs_ty
; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) }
handleWarnings = if isGenerated origin
then discardWarningsDs
else id
matchEquations :: HsMatchContext Name
-> [Id] -> [EquationInfo] -> Type
......
......@@ -301,7 +301,7 @@ cvt_ci_decs doc decs
; unless (null bads) (failWith (mkBadDecMsg doc bads))
--We use FromSource as the origin of the bind
-- because the TH declaration is user-written
; return (listToBag (map (\bind -> (FromSource, bind)) binds'), sigs', fams', ats', adts') }
; return (listToBag binds', sigs', fams', ats', adts') }
----------------
cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
......@@ -536,9 +536,7 @@ cvtLocalDecs doc ds
; let (binds, prob_sigs) = partitionWith is_bind ds'
; let (sigs, bads) = partitionWith is_sig prob_sigs
; unless (null bads) (failWith (mkBadDecMsg doc bads))
; return (HsValBinds (ValBindsIn (toBindBag binds) sigs)) }
where
toBindBag = listToBag . map (\bind -> (FromSource, bind))
; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
cvtClause (Clause ps body wheres)
......@@ -563,10 +561,10 @@ cvtl e = wrapL (cvt e)
cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' }
cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
; return $ HsLam (mkMatchGroup FromSource [mkSimpleMatch ps' e']) }
cvt (LamCaseE ms) = do { ms' <- mapM cvtMatch ms
; return $ HsLamCase placeHolderType
(mkMatchGroup ms')
(mkMatchGroup FromSource ms')
}
cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' }
-- Note [Dropping constructors]
......@@ -582,7 +580,7 @@ cvtl e = wrapL (cvt e)
cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
; e' <- cvtl e; return $ HsLet ds' e' }
cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
; return $ HsCase e' (mkMatchGroup ms') }
; return $ HsCase e' (mkMatchGroup FromSource ms') }
cvt (DoE ss) = cvtHsDo DoExpr ss
cvt (CompE ss) = cvtHsDo ListComp ss
cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' }
......
......@@ -89,7 +89,7 @@ type LHsBind id = LHsBindLR id id
type LHsBinds id = LHsBindsLR id id
type HsBind id = HsBindLR id id
type LHsBindsLR idL idR = Bag (Origin, LHsBindLR idL idR)
type LHsBindsLR idL idR = Bag (LHsBindLR idL idR)
type LHsBindLR idL idR = Located (HsBindLR idL idR)
data HsBindLR idL idR
......@@ -322,7 +322,7 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR id
pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc
pprLHsBinds binds
| isEmptyLHsBinds binds = empty
| otherwise = pprDeclList (map (ppr . snd) (bagToList binds))
| otherwise = pprDeclList (map ppr (bagToList binds))
pprLHsBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2)
=> LHsBindsLR idL idR -> [LSig id2] -> [SDoc]
......@@ -338,7 +338,7 @@ pprLHsBindsForUser binds sigs
decls :: [(SrcSpan, SDoc)]
decls = [(loc, ppr sig) | L loc sig <- sigs] ++
[(loc, ppr bind) | (_, L loc bind) <- bagToList binds]
[(loc, ppr bind) | L loc bind <- bagToList binds]
sort_by_loc decls = sortBy (comparing fst) decls
......
......@@ -909,7 +909,8 @@ patterns in each equation.
data MatchGroup id body
= MG { mg_alts :: [LMatch id body] -- The alternatives
, mg_arg_tys :: [PostTcType] -- Types of the arguments, t1..tn
, mg_res_ty :: PostTcType } -- Type of the result, tr
, mg_res_ty :: PostTcType -- Type of the result, tr
, mg_origin :: Origin }
-- The type is the type of the entire group
-- t1 -> ... -> tn -> tr
-- where there are n patterns
......
......@@ -132,8 +132,8 @@ unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds
unguardedRHS :: Located (body id) -> [LGRHS id (Located (body id))]
unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
mkMatchGroup :: [LMatch id (Located (body id))] -> MatchGroup id (Located (body id))
mkMatchGroup matches = MG { mg_alts = matches, mg_arg_tys = [], mg_res_ty = placeHolderType }
mkMatchGroup :: Origin -> [LMatch id (Located (body id))] -> MatchGroup id (Located (body id))
mkMatchGroup origin matches = MG { mg_alts = matches, mg_arg_tys = [], mg_res_ty = placeHolderType, mg_origin = origin }
mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
......@@ -144,7 +144,7 @@ mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
where
matches = mkMatchGroup [mkSimpleMatch pats body]
matches = mkMatchGroup Generated [mkSimpleMatch pats body]
mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id
mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr
......@@ -351,11 +351,11 @@ nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
nlHsCase :: LHsExpr id -> [LMatch id (LHsExpr id)] -> LHsExpr id
nlList :: [LHsExpr id] -> LHsExpr id
nlHsLam match = noLoc (HsLam (mkMatchGroup [match]))
nlHsPar e = noLoc (HsPar e)
nlHsIf cond true false = noLoc (mkHsIf cond true false)
nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches))
nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs)
nlHsLam match = noLoc (HsLam (mkMatchGroup Generated [match]))
nlHsPar e = noLoc (HsPar e)
nlHsIf cond true false = noLoc (mkHsIf cond true false)
nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup Generated matches))
nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs)
nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
nlHsTyVar :: name -> LHsType name
......@@ -478,20 +478,20 @@ l
mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> HsBind RdrName
-- 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 = idHsWrapper
, fun_matches = mkMatchGroup Generated ms
, fun_co_fn = idHsWrapper
, bind_fvs = placeHolderNames
, fun_tick = Nothing }
, fun_tick = Nothing }
mkTopFunBind :: Located Name -> [LMatch Name (LHsExpr Name)] -> HsBind Name
mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)] -> HsBind Name
-- In Name-land, with empty bind_fvs
mkTopFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
, fun_matches = mkMatchGroup ms
, fun_co_fn = idHsWrapper
, bind_fvs = emptyNameSet -- NB: closed binding
, fun_tick = Nothing }
mkTopFunBind origin fn ms = FunBind { fun_id = fn, fun_infix = False
, fun_matches = mkMatchGroup origin ms
, fun_co_fn = idHsWrapper
, bind_fvs = emptyNameSet -- NB: closed binding
, fun_tick = Nothing }
mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> (Origin, LHsBind RdrName)
mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
mkVarBind :: id -> LHsExpr id -> LHsBind id
......@@ -507,9 +507,9 @@ mkPatSynBind name details lpat dir = PatSynBind{ patsyn_id = name
------------
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
-> LHsExpr RdrName -> (Origin, LHsBind RdrName)
-> LHsExpr RdrName -> LHsBind RdrName
mk_easy_FunBind loc fun pats expr
= (Generated, L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds])
= L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
------------
mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id)
......@@ -580,11 +580,11 @@ collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
collectHsBindListBinders = foldr (collect_bind . unLoc) []
collect_binds :: LHsBindsLR idL idR -> [idL] -> [idL]
collect_binds binds acc = foldrBag (collect_bind . unLoc . snd) acc binds
collect_binds binds acc = foldrBag (collect_bind . unLoc) acc binds
collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
-- Used exclusively for the bindings of an instance decl which are all FunBinds
collectMethodBinders binds = foldrBag (get . unLoc . snd) [] binds
collectMethodBinders binds = foldrBag (get . unLoc) [] binds
where
get (FunBind { fun_id = f }) fs = f : fs
get _ fs = fs
......@@ -808,7 +808,7 @@ hsValBindsImplicits (ValBindsIn binds _)
= lhsBindsImplicits binds
lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet
lhsBindsImplicits = foldBag unionNameSets (lhs_bind . unLoc . snd) emptyNameSet
lhsBindsImplicits = foldBag unionNameSets (lhs_bind . unLoc) emptyNameSet
where
lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
lhs_bind _ = emptyNameSet
......
......@@ -132,7 +132,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
class_info decl@(ClassDecl {})
= (classops, addpr (sum3 (map count_bind methods)))
where
methods = map (unLoc . snd) $ bagToList (tcdMeths decl)
methods = map unLoc $ bagToList (tcdMeths decl)
(_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl))
class_info _ = (0,0)
......@@ -147,7 +147,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
(addpr (sum3 (map count_bind methods)),
ss, is, length ats, length adts)
where
methods = map (unLoc . snd) $ bagToList inst_meths
methods = map unLoc $ bagToList inst_meths
-- TODO: use Sum monoid
addpr :: (Int,Int,Int) -> Int
......
......@@ -1476,18 +1476,18 @@ infixexp :: { LHsExpr RdrName }
exp10 :: { LHsExpr RdrName }
: '\\' apat apats opt_asig '->' exp
{ LL $ HsLam (mkMatchGroup [LL $ Match ($2:$3) $4
{ LL $ HsLam (mkMatchGroup FromSource [LL $ Match ($2:$3) $4
(unguardedGRHSs $6)
]) }
]) }
| 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 }
| '\\' 'lcase' altslist
{ LL $ HsLamCase placeHolderType (mkMatchGroup (unLoc $3)) }
{ LL $ HsLamCase placeHolderType (mkMatchGroup FromSource (unLoc $3)) }
| 'if' exp optSemi 'then' exp optSemi 'else' exp
{% checkDoAndIfThenElse $2 $3 $5 $6 $8 >>
return (LL $ mkHsIf $2 $5 $8) }
| 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >>
return (LL $ HsMultiIf placeHolderType (reverse $ unLoc $2)) }
| 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) }
| 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup FromSource (unLoc $4)) }
| '-' fexp { LL $ NegApp $2 noSyntaxExpr }
| 'do' stmtlist { L (comb2 $1 $2) (mkHsDo DoExpr (unLoc $2)) }
......
......@@ -315,7 +315,7 @@ cvBindsAndSigs fb = go (fromOL fb)
go [] = (emptyBag, [], [], [], [], [])
go (L l (SigD s) : ds) = (bs, L l s : ss, ts, tfis, dfis, docs)
where (bs, ss, ts, tfis, dfis, docs) = go ds
go (L l (ValD b) : ds) = ((FromSource, b') `consBag` bs, ss, ts, tfis, dfis, docs)
go (L l (ValD b) : ds) = (b' `consBag` bs, ss, ts, tfis, dfis, docs)
where (b', ds') = getMonoBind (L l b) ds
(bs, ss, ts, tfis, dfis, docs) = go ds'
go (L l (TyClD (FamDecl t)) : ds) = (bs, ss, L l t : ts, tfis, dfis, docs)
......@@ -735,7 +735,7 @@ checkFunBind msg lhs_loc fun is_infix pats opt_sig (L rhs_span grhss)
makeFunBind :: Located id -> Bool -> [LMatch id (LHsExpr id)] -> HsBind id
-- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
makeFunBind fn is_infix ms
= FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup ms,
= FunBind { fun_id = fn, fun_infix = is_infix, fun_matches = mkMatchGroup FromSource ms,
fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
checkPatBind :: SDoc
......
......@@ -47,7 +47,7 @@ import NameSet
import RdrName ( RdrName, rdrNameOcc )
import SrcLoc
import ListSetOps ( findDupsEq )
import BasicTypes ( RecFlag(..), Origin )
import BasicTypes ( RecFlag(..) )
import Digraph ( SCC(..) )
import Bag
import Outputable
......@@ -275,7 +275,7 @@ rnValBindsLHS :: NameMaker
-> HsValBinds RdrName
-> RnM (HsValBindsLR Name RdrName)
rnValBindsLHS topP (ValBindsIn mbinds sigs)
= do { mbinds' <- mapBagM (wrapOriginLocM (rnBindLHS topP doc)) mbinds
= do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds
; return $ ValBindsIn mbinds' sigs }
where
bndrs = collectHsBindsBinders mbinds
......@@ -448,12 +448,12 @@ rnBindLHS name_maker _ bind@(PatSynBind{ patsyn_id = rdrname@(L nameLoc _) })
rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b)
rnLBind :: (Name -> [Name]) -- Signature tyvar function
-> (Origin, LHsBindLR Name RdrName)
-> RnM ((Origin, LHsBind Name), [Name], Uses)
rnLBind sig_fn (origin, (L loc bind))
-> LHsBindLR Name RdrName
-> RnM (LHsBind Name, [Name], Uses)
rnLBind sig_fn (L loc bind)
= setSrcSpan loc $
do { (bind', bndrs, dus) <- rnBind sig_fn bind
; return ((origin, L loc bind'), bndrs, dus) }
; return (L loc bind', bndrs, dus) }
-- assumes the left-hands-side vars are in scope
rnBind :: (Name -> [Name]) -- Signature tyvar function
......@@ -581,7 +581,7 @@ trac ticket #1136.
-}
---------------------
depAnalBinds :: Bag ((Origin, LHsBind Name), [Name], Uses)
depAnalBinds :: Bag (LHsBind Name, [Name], Uses)
-> ([(RecFlag, LHsBinds Name)], DefUses)
-- Dependency analysis; this is important so that
-- unused-binding reporting is accurate
......@@ -666,10 +666,9 @@ rnMethodBinds cls sig_fn binds
; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) }
where
meth_names = collectMethodBinders binds
do_one (binds,fvs) (origin,bind)
do_one (binds,fvs) bind
= do { (bind', fvs_bind) <- rnMethodBind cls sig_fn bind
; let bind'' = mapBag (\bind -> (origin,bind)) bind'
; return (binds `unionBags` bind'', fvs_bind `plusFV` fvs) }
; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) }
rnMethodBind :: Name
-> (Name -> [Name])
......@@ -677,7 +676,7 @@ rnMethodBind :: Name
-> RnM (Bag (LHsBindLR Name Name), FreeVars)
rnMethodBind cls sig_fn
(L loc bind@(FunBind { fun_id = name, fun_infix = is_infix
, fun_matches = MG { mg_alts = matches } }))
, fun_matches = MG { mg_alts = matches, mg_origin = origin } }))
= setSrcSpan loc $ do
sel_name <- wrapLocM (lookupInstDeclBndr cls (ptext (sLit "method"))) name
let plain_name = unLoc sel_name
......@@ -685,7 +684,7 @@ rnMethodBind cls sig_fn
(new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $
mapFvRn (rnMatch (FunRhs plain_name is_infix) rnLExpr) matches
let new_group = mkMatchGroup new_matches
let new_group = mkMatchGroup origin new_matches
when is_infix $ checkPrecMatch plain_name new_group
return (unitBag (L loc (bind { fun_id = sel_name
......@@ -889,11 +888,11 @@ rnMatchGroup :: Outputable (body RdrName) => HsMatchContext Name
-> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
-> MatchGroup RdrName (Located (body RdrName))
-> RnM (MatchGroup Name (Located (body Name)), FreeVars)
rnMatchGroup ctxt rnBody (MG { mg_alts = ms })
rnMatchGroup ctxt rnBody (MG { mg_alts = ms, mg_origin = origin })
= do { empty_case_ok <- xoptM Opt_EmptyCase
; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))
; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms
; return (mkMatchGroup new_ms, ms_fvs) }
; return (mkMatchGroup origin new_ms, ms_fvs) }
rnMatch :: Outputable (body RdrName) => HsMatchContext Name
-> (Located (body RdrName) -> RnM (Located (body Name), FreeVars))
......
......@@ -35,7 +35,7 @@ import NameEnv
import Avail
import Outputable
import Bag
import BasicTypes ( RuleName, Origin(..) )
import BasicTypes ( RuleName )
import FastString
import SrcLoc
import DynFlags
......@@ -1518,7 +1518,7 @@ add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)
= tycls { group_roles = d : roles } : rest
add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a
add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` (FromSource, b)) sigs
add_bind b (ValBindsIn bs sigs) = ValBindsIn (bs `snocBag` b) sigs
add_bind _ (ValBindsOut {}) = panic "RdrHsSyn:add_bind"
add_sig :: LSig a -> HsValBinds a -> HsValBinds a
......
......@@ -241,7 +241,7 @@ tc_cmd env cmd@(HsCmdApp fun arg) (cmd_stk, res_ty)
-- D;G |-a (\x.cmd) : (t,stk) --> res
tc_cmd env
(HsCmdLam (MG { mg_alts = [L mtch_loc (match@(Match pats _maybe_rhs_sig grhss))] }))
(HsCmdLam (MG { mg_alts = [L mtch_loc (match@(Match pats _maybe_rhs_sig grhss))], mg_origin = origin }))
(cmd_stk, res_ty)
= addErrCtxt (pprMatchInCtxt match_ctxt match) $
do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk
......@@ -254,7 +254,7 @@ tc_cmd env
; let match' = L mtch_loc (Match pats' Nothing grhss')
arg_tys = map hsLPatType pats'
cmd' = HsCmdLam (MG { mg_alts = [match'], mg_arg_tys = arg_tys
, mg_res_ty = res_ty })
, mg_res_ty = res_ty, mg_origin = origin })
; return (mkHsCmdCast co cmd') }
where
n_pats = length pats
......
This diff is collapsed.
......@@ -121,7 +121,7 @@ tcClassSigs clas sigs def_methods
vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig nm ty) <- sigs]
gen_sigs = [L loc (nm,ty) | L loc (GenericSig nm ty) <- sigs]
dm_bind_names :: [Name] -- These ones have a value binding in the class decl
dm_bind_names = [op | (_, L _ (FunBind {fun_id = L _ op})) <- bagToList def_methods]
dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
tc_sig genop_env (op_names, op_hs_ty)
= do { traceTc "ClsSig 1" (ppr op_names)
......@@ -238,18 +238,18 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn (sel_id, dm_info)
---------------
tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
-> Id -> TcSigInfo
-> TcSpecPrags -> (Origin, LHsBind Name)
-> TcM (Origin, LHsBind Id)
-> TcSpecPrags -> LHsBind Name
-> TcM (LHsBind Id)
tcInstanceMethodBody skol_info tyvars dfun_ev_vars
meth_id local_meth_sig
specs (origin, (L loc bind))
specs (L loc bind)
= do { let local_meth_id = sig_id local_meth_sig
lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
-- Substitute the local_meth_name for the binder
-- NB: the binding is always a FunBind
; (ev_binds, (tc_bind, _, _))
<- checkConstraints skol_info tyvars dfun_ev_vars $
tcPolyCheck NonRecursive no_prag_fn local_meth_sig (origin, lm_bind)
tcPolyCheck NonRecursive no_prag_fn local_meth_sig lm_bind
; let export = ABE { abe_wrap = idHsWrapper, abe_poly = meth_id
, abe_mono = local_meth_id, abe_prags = specs }
......@@ -258,7 +258,7 @@ tcInstanceMethodBody skol_info tyvars dfun_ev_vars
, abs_ev_binds = ev_binds
, abs_binds = tc_bind }
; return (origin, L loc full_bind) }
; return (L loc full_bind) }
where
no_prag_fn _ = [] -- No pragmas for local_meth_id;
-- they are all for meth_id
......@@ -326,14 +326,14 @@ lookupHsSig = lookupNameEnv
---------------------------
findMethodBind :: Name -- Selector name
-> LHsBinds Name -- A group of bindings
-> Maybe ((Origin, LHsBind Name), SrcSpan)
-> Maybe (LHsBind Name, SrcSpan)
-- Returns the binding, and the binding
-- site of the method binder
findMethodBind sel_name binds
= foldlBag mplus Nothing (mapBag f binds)
where
f bind@(_, L _ (FunBind { fun_id = L bndr_loc op_name }))
| op_name == sel_name
where
f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))
| op_name == sel_name
= Just (bind, bndr_loc)
f _other = Nothing
......
......@@ -60,7 +60,6 @@ import Outputable
import FastString
import Bag
import Pair
import BasicTypes (Origin(..))
import Control.Monad
import Data.List
......@@ -441,7 +440,7 @@ commonAuxiliaries = foldM snoc ([], emptyBag) where
renameDeriv :: Bool
-> [InstInfo RdrName]
-> Bag ((Origin, LHsBind RdrName), LSig RdrName)
-> Bag (LHsBind RdrName, LSig RdrName)
-> TcM (Bag (InstInfo Name), HsValBinds Name, DefUses)
renameDeriv is_boot inst_infos bagBinds
| is_boot -- If we are compiling a hs-boot file, don't generate any derived bindings
......
......@@ -58,7 +58,6 @@ import SrcLoc
import Bag
import FastString
import Hooks
import BasicTypes (Origin(..))
import Control.Monad
\end{code}
......@@ -351,7 +350,7 @@ tcForeignExports' decls
where
combine (binds, fs, gres1) (L loc fe) = do
(b, f, gres2) <- setSrcSpan loc (tcFExport fe)
return ((FromSource, b) `consBag` binds, L loc f : fs, gres1 `unionBags` gres2)
return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2)
tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id, Bag GlobalRdrElt)
tcFExport fo@(ForeignExport (L loc nm) hs_ty _ spec)
......
......@@ -97,7 +97,7 @@ data DerivStuff -- Please add this auxiliary stuff
| DerivFamInst (FamInst) -- New type family instances
-- New top-level auxiliary bindings
| DerivHsBind ((Origin, LHsBind RdrName), LSig RdrName) -- Also used for SYB
| DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB
| DerivInst (InstInfo RdrName) -- New, auxiliary instances
\end{code}
......@@ -360,7 +360,7 @@ gen_Ord_binds loc tycon
(nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
mkOrdOp :: OrdOp -> (Origin, LHsBind RdrName)
mkOrdOp :: OrdOp -> LHsBind RdrName
-- Returns a binding op a b = ... compares a and b according to op ....
mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op)
......@@ -1352,7 +1352,7 @@ gen_Data_binds dflags loc tycon
n_cons = length data_cons
one_constr = n_cons == 1
genDataTyCon :: ((Origin, LHsBind RdrName), LSig RdrName)
genDataTyCon :: (LHsBind RdrName, LSig RdrName)
genDataTyCon -- $dT
= (mkHsVarBind loc rdr_name rhs,
L loc (TypeSig [L loc rdr_name] sig_ty))
......@@ -1364,7 +1364,7 @@ gen_Data_binds dflags loc tycon
`nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr tycon)))
`nlHsApp` nlList constrs
genDataDataCon :: DataCon -> ((Origin, LHsBind RdrName), LSig RdrName)
genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName)
genDataDataCon dc -- $cT1 etc
= (mkHsVarBind loc rdr_name rhs,
L loc (TypeSig [L loc rdr_name] sig_ty))
......@@ -1943,7 +1943,7 @@ gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty
(map (mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty) (classMethods cls))
where
coerce_RDR = getRdrName coerceId
mk_bind :: Id -> Pair Type -> (Origin, LHsBind RdrName)
mk_bind :: Id -> Pair Type -> LHsBind RdrName
mk_bind id (Pair tau_ty user_ty)
= mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch [] rhs_expr]
where
......@@ -1978,7 +1978,7 @@ The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
fiddling around.
\begin{code}
genAuxBindSpec :: SrcSpan -> AuxBindSpec -> ((Origin, LHsBind RdrName), LSig RdrName)
genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName)
genAuxBindSpec loc (DerivCon2Tag tycon)
= (mk_FunBind loc rdr_name eqns,
L loc (TypeSig [L loc rdr_name] (L loc sig_ty)))
......@@ -2024,7 +2024,7 @@ genAuxBindSpec loc (DerivMaxTag tycon)
data_cons -> toInteger ((length data_cons) - fIRST_TAG)
type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings
( Bag ((Origin, LHsBind RdrName), LSig RdrName)
( Bag (LHsBind RdrName, LSig RdrName)
-- Extra bindings (used by Generic only)
, Bag TyCon -- Extra top-level datatypes
, Bag (FamInst) -- Extra family instances
......@@ -2079,14 +2079,14 @@ mkParentType tc
\begin{code}
mk_FunBind :: SrcSpan -> RdrName
-> [([LPat RdrName], LHsExpr RdrName)]
-> (Origin, LHsBind RdrName)
-> LHsBind RdrName
mk_FunBind loc fun pats_and_exprs
= mkRdrFunBind (L loc fun) matches
where
matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> (Origin, LHsBind RdrName)
mkRdrFunBind fun@(L loc fun_rdr) matches = (Generated, L loc (mkFunBind fun matches'))
mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
mkRdrFunBind fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
where
-- Catch-all eqn looks like
-- fmap = error "Void fmap"
......
......@@ -405,10 +405,8 @@ warnMissingSig msg id
zonkMonoBinds :: ZonkEnv -> SigWarn -> LHsBinds TcId -> TcM (LHsBinds Id)
zonkMonoBinds env sig_warn binds = mapBagM (zonk_lbind env sig_warn) binds
zonk_lbind :: ZonkEnv -> SigWarn -> (Origin, LHsBind TcId) -> TcM (Origin, LHsBind Id)
zonk_lbind env sig_warn (origin, lbind)
= do { lbind' <- wrapLocM (zonk_bind env sig_warn) lbind
; return (origin, lbind') }
zonk_lbind :: ZonkEnv -> SigWarn -> LHsBind TcId -> TcM (LHsBind Id)
zonk_lbind env sig_warn = wrapLocM (zonk_bind env sig_warn)
zonk_bind :: ZonkEnv -> SigWarn -> HsBind TcId -> TcM (HsBind Id)
zonk_bind env sig_warn bind@(PatBind { pat_lhs = pat, pat_rhs = grhss, pat_rhs_ty = ty})
......@@ -506,11 +504,11 @@ zonkLTcSpecPrags env ps
zonkMatchGroup :: ZonkEnv
-> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
-> MatchGroup TcId (Located (body TcId)) -> TcM (MatchGroup Id (Located (body Id)))
zonkMatchGroup env zBody (MG { mg_alts = ms, mg_arg_tys = arg_tys, mg_res_ty = res_ty })
zonkMatchGroup env zBody (MG { mg_alts = ms, mg_arg_tys = arg_tys, mg_res_ty = res_ty, mg_origin = origin })
= do { ms' <- mapM (zonkMatch env zBody) ms
; arg_tys' <- zonkTcTypeToTypes env arg_tys
; res_ty' <- zonkTcTypeToType env res_ty
; return (MG { mg_alts = ms', mg_arg_tys = arg_tys', mg_res_ty = res_ty' }) }
; return (MG { mg_alts = ms', mg_arg_tys = arg_tys', mg_res_ty = res_ty', mg_origin = origin }) }
zonkMatch :: ZonkEnv
-> (ZonkEnv -> Located (body TcId) -> TcM (Located (body Id)))
......
......@@ -888,9 +888,9 @@ tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
, abs_ev_vars = dfun_ev_vars
, abs_exports = [export]
, abs_ev_binds = sc_binds
, abs_binds = unitBag (Generated, dict_bind) }
, abs_binds = unitBag dict_bind }
; return (unitBag (Generated, L loc main_bind) `unionBags`
; return (unitBag (L loc main_bind) `unionBags`
listToBag meth_binds)
}
where
......@@ -1169,7 +1169,7 @@ tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
-> ([Located TcSpecPrag], PragFun)
-> [(Id, DefMeth)]
-> InstBindings Name
-> TcM ([Id], [(Origin, LHsBind Id)])
-> TcM ([Id], [LHsBind Id])
-- The returned inst_meth_ids all have types starting
-- forall tvs. theta => ...
tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
......@@ -1188,7 +1188,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
set_exts es thing = foldr setXOptM thing es
----------------------
tc_item :: HsSigFun -> (Id, DefMeth) ->