Commit eeaea2df authored by Gergő Érdi's avatar Gergő Érdi
Browse files

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
......
......@@ -345,14 +345,14 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
; return ([(Recursive, binds1)], thing) }
-- Rec them all together
where
hasPatSyn = anyBag (isPatSyn . unLoc . snd) binds
hasPatSyn = anyBag (isPatSyn . unLoc) binds
isPatSyn PatSynBind{} = True
isPatSyn _ = False
sccs :: [SCC (Origin, LHsBind Name)]
sccs :: [SCC (LHsBind Name)]
sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)
go :: [SCC (Origin, LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing)
go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing)
go (scc:sccs) = do { (binds1, ids1, closed) <- tc_scc scc
; (binds2, ids2, thing) <- tcExtendLetEnv top_lvl closed ids1 $
go sccs
......@@ -368,7 +368,7 @@ recursivePatSynErr :: OutputableBndr name => LHsBinds name -> TcM a
recursivePatSynErr binds
= failWithTc $
hang (ptext (sLit "Recursive pattern synonym definition with following bindings:"))
2 (vcat $ map (pprLBind . snd) . bagToList $ binds)
2 (vcat $ map pprLBind . bagToList $ binds)
where
pprLoc loc = parens (ptext (sLit "defined at") <+> ppr loc)
pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders bind) <+>
......@@ -376,9 +376,9 @@ recursivePatSynErr binds
tc_single :: forall thing.
TopLevelFlag -> TcSigFun -> PragFun
-> (Origin, LHsBind Name) -> TcM thing
-> LHsBind Name -> TcM thing
-> TcM (LHsBinds TcId, thing)
tc_single _top_lvl _sig_fn _prag_fn (_, (L _ ps@PatSynBind{})) thing_inside
tc_single _top_lvl _sig_fn _prag_fn (L _ ps@PatSynBind{}) thing_inside
= do { (pat_syn, aux_binds) <-
tcPatSynDecl (patsyn_id ps) (patsyn_args ps) (patsyn_def ps) (patsyn_dir ps)
......@@ -400,12 +400,12 @@ tc_single top_lvl sig_fn prag_fn lbind thing_inside
------------------------
mkEdges :: TcSigFun -> LHsBinds Name
-> [((Origin, LHsBind Name), BKey, [BKey])]
-> [(LHsBind Name, BKey, [BKey])]
type BKey = Int -- Just number off the bindings
mkEdges sig_fn binds
= [ (bind, key, [key | n <- nameSetToList (bind_fvs (unLoc . snd $ bind)),
= [ (bind, key, [key | n <- nameSetToList (bind_fvs (unLoc bind)),
Just key <- [lookupNameEnv key_map n], no_sig n ])
| (bind, key) <- keyd_binds
]
......@@ -416,7 +416,7 @@ mkEdges sig_fn binds
keyd_binds = bagToList binds `zip` [0::BKey ..]
key_map :: NameEnv BKey -- Which binding it comes from
key_map = mkNameEnv [(bndr, key) | ((_, L _ bind), key) <- keyd_binds
key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
, bndr <- bindersOfHsBind bind ]
bindersOfHsBind :: HsBind Name -> [Name]
......@@ -431,7 +431,7 @@ tcPolyBinds :: TopLevelFlag -> TcSigFun -> PragFun
-> RecFlag -- Whether the group is really recursive
-> RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
-> [(Origin, LHsBind Name)]
-> [LHsBind Name]
-> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
-- Typechecks a single bunch of bindings all together,
......@@ -471,9 +471,8 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
; return result }
where
bind_list' = map snd bind_list
binder_names = collectHsBindListBinders bind_list'
loc = foldr1 combineSrcSpans (map getLoc bind_list')
binder_names = collectHsBindListBinders bind_list
loc = foldr1 combineSrcSpans (map getLoc bind_list)
-- The mbinds have been dependency analysed and
-- may no longer be adjacent; so find the narrowest
-- span that includes them all
......@@ -483,7 +482,7 @@ tcPolyNoGen -- No generalisation whatsoever
:: RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
-> PragFun -> TcSigFun
-> [(Origin, LHsBind Name)]
-> [LHsBind Name]
-> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
......@@ -508,7 +507,7 @@ tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list
tcPolyCheck :: RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
-> PragFun -> TcSigInfo
-> (Origin, LHsBind Name)
-> LHsBind Name
-> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
-- There is just one binding,
-- it binds a single variable,
......@@ -516,7 +515,7 @@ tcPolyCheck :: RecFlag -- Whether it's recursive after breaking
tcPolyCheck rec_tc prag_fn
sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs_w_scoped
, sig_theta = theta, sig_tau = tau, sig_loc = loc })
bind@(origin, _)
bind
= do { ev_vars <- newEvVars theta
; let skol_info = SigSkol (FunSigCtxt (idName poly_id)) (mkPhiTy theta tau)
prag_sigs = prag_fn (idName poly_id)
......@@ -541,7 +540,7 @@ tcPolyCheck rec_tc prag_fn
, abs_exports = [export], abs_binds = binds' }
closed | isEmptyVarSet (tyVarsOfType (idType poly_id)) = TopLevel
| otherwise = NotTopLevel
; return (unitBag (origin, abs_bind), [poly_id], closed) }
; return (unitBag abs_bind, [poly_id], closed) }
------------------
tcPolyInfer
......@@ -550,7 +549,7 @@ tcPolyInfer
-> PragFun -> TcSigFun
-> Bool -- True <=> apply the monomorphism restriction
-> Bool -- True <=> free vars have closed types