diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs
index 0ac7de80229918c178f869772eb1a69b90406647..6bdc61d9c23baaef0328bac32861eed42c8a4345 100644
--- a/compiler/deSugar/Coverage.lhs
+++ b/compiler/deSugar/Coverage.lhs
@@ -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,
diff --git a/compiler/deSugar/DsArrows.lhs b/compiler/deSugar/DsArrows.lhs
index 763106f2b3f4a865cc82e87a191db6b62506548e..f87877681c08747eda82a45e921426aee9497c70 100644
--- a/compiler/deSugar/DsArrows.lhs
+++ b/compiler/deSugar/DsArrows.lhs
@@ -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'
diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs
index cd683ba3659223b4bf0698cc9cfd28053d292c20..b9264ca40feb65bad82f5e2886e761e2946474ec 100644
--- a/compiler/deSugar/DsBinds.lhs
+++ b/compiler/deSugar/DsBinds.lhs
@@ -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))
diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index d1ef24070c8015f2df3fc077a367db211f911727..859309d5923718a9a83b82c335d748a051c09358 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -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)
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index ad40fc0327c2be6137b5476660c0e6a6f8a37dfa..65bb9358252e65ca5ca4edfefdc4130a3445b9cb 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1198,7 +1198,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
diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index e0a5d4af0cc6908367eecf6a3781b46daf7ee4c0..b42a720c32d84bf9d573290791d7ed598c1d3229 100644
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -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
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 1a821e9485019fe2af450c9f9eb5d98a8f66252d..bd70cd7affe1fe11a0398291fc3da97f2a09db06 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -300,7 +300,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]
@@ -535,9 +535,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)
@@ -562,10 +560,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]
@@ -581,7 +579,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' }
diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index e904633eec6401b7ccd62b611ce3d079a0136e83..2261a89741597d800ad51dc5d4d1057db290f677 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -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
diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs
index 4c0c955cdd93cf534c9d11b6a824904c501687d9..f5ba1903ee7c090bf33a68bf49cce1e309f89b82 100644
--- a/compiler/hsSyn/HsExpr.lhs
+++ b/compiler/hsSyn/HsExpr.lhs
@@ -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
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index 558c104fadd31fff43489640ac3a6b743fad3ffd..eff67df3cfbe4bc61cef0f585957363e44912af9 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -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
diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs
index 715ee8130c91b0dd1b2eb77c14c9f2ddd242038a..4f901b1849c3a3ece8fecaac17f99510a727b5b8 100644
--- a/compiler/main/HscStats.hs
+++ b/compiler/main/HscStats.hs
@@ -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
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 27d6c3839f1ab857f5788122b5d8f08281a34430..83e420d882e46ec16426b88162c21666bc13efe9 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -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)) }
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index b1e177a3a9cb1e27036d6d6f9fe36c50fb79c291..03ec622223050a3b7e66be307da14826ef2139d4 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -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
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index ba94a390f4eb78555ad2b33f481f675986e8b012..7251492ccffb58778724a5b185def77fed32bc1c 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -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))
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index c726d554fcb7f1e3d8044efa18af4a6a2193faab..fbc22c0c28dabda760c5f884c67aabb8936872d3 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -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
diff --git a/compiler/typecheck/TcArrows.lhs b/compiler/typecheck/TcArrows.lhs
index b427dd5409eb9bb881338b7d65762e9428d123c5..407e1725ffb7ef179f07a739d62da66ac1a76415 100644
--- a/compiler/typecheck/TcArrows.lhs
+++ b/compiler/typecheck/TcArrows.lhs
@@ -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
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index 4fe95a4f75595004bc0de48171c683b02521b573..a15d52040b568c70e1c84c00ebc0ce2b043a80d9 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -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
- -> [(Origin, LHsBind Name)]
+ -> [LHsBind Name]
-> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list
= do { ((binds', mono_infos), wanted)
@@ -576,10 +575,8 @@ tcPolyInfer rec_tc prag_fn tc_sig_fn mono closed bind_list
; traceTc "Binding:" (ppr final_closed $$
ppr (poly_ids `zip` map idType poly_ids))
- ; return (unitBag (origin, abs_bind), poly_ids, final_closed) }
+ ; return (unitBag abs_bind, poly_ids, final_closed) }
-- poly_ids are guaranteed zonked by mkExport
- where
- origin = if all isGenerated (map fst bind_list) then Generated else FromSource
--------------
mkExport :: PragFun
@@ -723,7 +720,7 @@ mkPragFun sigs binds = \n -> lookupNameEnv prag_env n `orElse` []
-- ar_env maps a local to the arity of its definition
ar_env :: NameEnv Arity
- ar_env = foldrBag (lhsBindArity . snd) emptyNameEnv binds
+ ar_env = foldrBag lhsBindArity emptyNameEnv binds
lhsBindArity :: LHsBind Name -> NameEnv Arity -> NameEnv Arity
lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env
@@ -992,12 +989,12 @@ tcMonoBinds :: RecFlag -- Whether the binding is recursive for typechecking pur
-- i.e. the binders are mentioned in their RHSs, and
-- we are not rescued by a type signature
-> TcSigFun -> LetBndrSpec
- -> [(Origin, LHsBind Name)]
+ -> [LHsBind Name]
-> TcM (LHsBinds TcId, [MonoBindInfo])
tcMonoBinds is_rec sig_fn no_gen
- [ (origin, L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
- fun_matches = matches, bind_fvs = fvs }))]
+ [ L b_loc (FunBind { fun_id = L nm_loc name, fun_infix = inf,
+ fun_matches = matches, bind_fvs = fvs })]
-- Single function binding,
| NonRecursive <- is_rec -- ...binder isn't mentioned in RHS
, Nothing <- sig_fn name -- ...with no type signature
@@ -1015,17 +1012,16 @@ tcMonoBinds is_rec sig_fn no_gen
-- type of the thing whose rhs we are type checking
tcMatchesFun name inf matches rhs_ty
- ; return (unitBag (origin,
- L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
- fun_matches = matches', bind_fvs = fvs,
- fun_co_fn = co_fn, fun_tick = Nothing })),
+ ; return (unitBag $ L b_loc (FunBind { fun_id = L nm_loc mono_id, fun_infix = inf,
+ fun_matches = matches', bind_fvs = fvs,
+ fun_co_fn = co_fn, fun_tick = Nothing }),
[(name, Nothing, mono_id)]) }
tcMonoBinds _ sig_fn no_gen binds
- = do { tc_binds <- mapM (wrapOriginLocM (tcLhs sig_fn no_gen)) binds
+ = do { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds
-- Bring the monomorphic Ids, into scope for the RHSs
- ; let mono_info = getMonoBindInfo (map snd tc_binds)
+ ; let mono_info = getMonoBindInfo tc_binds
rhs_id_env = [(name,mono_id) | (name, Nothing, mono_id) <- mono_info]
-- A monomorphic binding for each term variable that lacks
-- a type sig. (Ones with a sig are already in scope.)
@@ -1033,7 +1029,7 @@ tcMonoBinds _ sig_fn no_gen binds
; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)
| (n,id) <- rhs_id_env]
; binds' <- tcExtendIdEnv2 rhs_id_env $
- mapM (wrapOriginLocM tcRhs) tc_binds
+ mapM (wrapLocM tcRhs) tc_binds
; return (listToBag binds', mono_info) }
------------------------
@@ -1265,7 +1261,7 @@ data GeneralisationPlan
Bool -- True <=> bindings mention only variables with closed types
-- See Note [Bindings with closed types] in TcRnTypes
- | CheckGen (Origin, LHsBind Name) TcSigInfo
+ | CheckGen (LHsBind Name) TcSigInfo
-- One binding with a signature
-- Explicit generalisation; there is an AbsBinds
@@ -1279,7 +1275,7 @@ instance Outputable GeneralisationPlan where
decideGeneralisationPlan
:: DynFlags -> TcTypeEnv -> [Name]
- -> [(Origin, LHsBind Name)] -> TcSigFun -> GeneralisationPlan
+ -> [LHsBind Name] -> TcSigFun -> GeneralisationPlan
decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
| strict_pat_binds = NoGen
| Just (lbind, sig) <- one_funbind_with_sig lbinds = CheckGen lbind sig
@@ -1288,7 +1284,7 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
where
bndr_set = mkNameSet bndr_names
- binds = map (unLoc . snd) lbinds
+ binds = map unLoc lbinds
strict_pat_binds = any isStrictHsBind binds
-- Strict patterns (top level bang or unboxed tuple) must not
@@ -1329,7 +1325,7 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
-- With OutsideIn, all nested bindings are monomorphic
-- except a single function binding with a signature
- one_funbind_with_sig [lbind@(_, L _ (FunBind { fun_id = v }))]
+ one_funbind_with_sig [lbind@(L _ (FunBind { fun_id = v }))]
= case sig_fn (unLoc v) of
Nothing -> Nothing
Just sig -> Just (lbind, sig)
@@ -1351,7 +1347,7 @@ decideGeneralisationPlan dflags type_env bndr_names lbinds sig_fn
-------------------
checkStrictBinds :: TopLevelFlag -> RecFlag
- -> [(Origin, LHsBind Name)]
+ -> [LHsBind Name]
-> LHsBinds TcId -> [Id]
-> TcM ()
-- Check that non-overloaded unlifted bindings are
@@ -1390,31 +1386,31 @@ checkStrictBinds top_lvl rec_group orig_binds tc_binds poly_ids
return ()
where
unlifted_bndrs = any is_unlifted poly_ids
- any_strict_pat = any (isStrictHsBind . unLoc . snd) orig_binds
- any_pat_looks_lazy = any (looksLazyPatBind . unLoc . snd) orig_binds
+ any_strict_pat = any (isStrictHsBind . unLoc) orig_binds
+ any_pat_looks_lazy = any (looksLazyPatBind . unLoc) orig_binds
is_unlifted id = case tcSplitForAllTys (idType id) of
(_, rho) -> isUnLiftedType rho
- is_monomorphic (_, (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })))
+ is_monomorphic (L _ (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))
= null tvs && null evs
is_monomorphic _ = True
-unliftedMustBeBang :: [(Origin, LHsBind Name)] -> SDoc
+unliftedMustBeBang :: [LHsBind Name] -> SDoc
unliftedMustBeBang binds
= hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:")
- 2 (vcat (map (ppr . snd) binds))
+ 2 (vcat (map ppr binds))
-polyBindErr :: [(Origin, LHsBind Name)] -> SDoc
+polyBindErr :: [LHsBind Name] -> SDoc
polyBindErr binds
= hang (ptext (sLit "You can't mix polymorphic and unlifted bindings"))
- 2 (vcat [vcat (map (ppr . snd) binds),
+ 2 (vcat [vcat (map ppr binds),
ptext (sLit "Probable fix: use a bang pattern")])
-strictBindErr :: String -> Bool -> [(Origin, LHsBind Name)] -> SDoc
+strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc
strictBindErr flavour unlifted_bndrs binds
= hang (text flavour <+> msg <+> ptext (sLit "aren't allowed:"))
- 2 (vcat (map (ppr . snd) binds))
+ 2 (vcat (map ppr binds))
where
msg | unlifted_bndrs = ptext (sLit "bindings for unlifted types")
| otherwise = ptext (sLit "bang-pattern or unboxed-tuple bindings")
diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index f61f48e92aa67faf6d5729198a7ce602b54e268b..bb4822a28421f9bb14dca83b6263db04fae28ff9 100644
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -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
diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs
index 30c57d19861cc19551b971e80fc1ff8a447c073c..a026804d2dd485ce2dabcc3319518b6e15af5eb5 100644
--- a/compiler/typecheck/TcDeriv.lhs
+++ b/compiler/typecheck/TcDeriv.lhs
@@ -60,7 +60,6 @@ import Outputable
import FastString
import Bag
import Pair
-import BasicTypes (Origin(..))
import Control.Monad
import Data.List
@@ -437,7 +436,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
diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 26af2c5ebfe0b52c143dfa8dacbcd8e0d7cd18fd..63eb020ff162aaeafe094927790e059270a87cd0 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -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)
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index 3852106d721818dfa00476d206c7f217f82308fe..b0afa397dc82e6e7d3d3d4e412c39c6e0c204a51 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -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"
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 1c9ac57e80988fc65f97666bb356ee11806c74df..59b42ea6732f5d6a1cc329c297fd6a2c3b96670a 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -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)))
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index 190e4cef4e9e8ecf9bb93548259c5651fe743113..8882f1e5d801e8332acee53dd655b0a0a0f5df49 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -887,9 +887,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
@@ -1168,7 +1168,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
@@ -1187,7 +1187,7 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
set_exts es thing = foldr setXOptM thing es
----------------------
- tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, (Origin, LHsBind Id))
+ tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, LHsBind Id)
tc_item sig_fn (sel_id, dm_info)
= case findMethodBind (idName sel_id) binds of
Just (user_bind, bndr_loc)
@@ -1196,10 +1196,10 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
; tc_default sig_fn sel_id dm_info }
----------------------
- tc_body :: HsSigFun -> Id -> Bool -> (Origin, LHsBind Name)
- -> SrcSpan -> TcM (TcId, (Origin, LHsBind Id))
+ tc_body :: HsSigFun -> Id -> Bool -> LHsBind Name
+ -> SrcSpan -> TcM (TcId, LHsBind Id)
tc_body sig_fn sel_id generated_code rn_bind bndr_loc
- = add_meth_ctxt sel_id generated_code (snd rn_bind) $
+ = add_meth_ctxt sel_id generated_code rn_bind $
do { traceTc "tc_item" (ppr sel_id <+> ppr (idType sel_id))
; (meth_id, local_meth_sig) <- setSrcSpan bndr_loc $
mkMethIds sig_fn clas tyvars dfun_ev_vars
@@ -1215,12 +1215,12 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
; return (meth_id1, bind) }
----------------------
- tc_default :: HsSigFun -> Id -> DefMeth -> TcM (TcId, (Origin, LHsBind Id))
+ tc_default :: HsSigFun -> Id -> DefMeth -> TcM (TcId, LHsBind Id)
tc_default sig_fn sel_id (GenDefMeth dm_name)
= do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
; tc_body sig_fn sel_id False {- Not generated code? -}
- (Generated, meth_bind) inst_loc }
+ meth_bind inst_loc }
tc_default sig_fn sel_id NoDefMeth -- No default method at all
= do { traceTc "tc_def: warn" (ppr sel_id)
@@ -1228,8 +1228,8 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
inst_tys sel_id
; dflags <- getDynFlags
; return (meth_id,
- (Generated, mkVarBind meth_id $
- mkLHsWrap lam_wrapper (error_rhs dflags))) }
+ mkVarBind meth_id $
+ mkLHsWrap lam_wrapper (error_rhs dflags)) }
where
error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags)
error_fun = L inst_loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
@@ -1271,13 +1271,13 @@ tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
, abs_exports = [export]
, abs_ev_binds = EvBinds (unitBag self_ev_bind)
- , abs_binds = unitBag (Generated, meth_bind) }
+ , abs_binds = unitBag meth_bind }
-- Default methods in an instance declaration can't have their own
-- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
-- currently they are rejected with
-- "INLINE pragma lacks an accompanying binding"
- ; return (meth_id1, (Generated, L inst_loc bind)) }
+ ; return (meth_id1, L inst_loc bind) }
----------------------
mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags
@@ -1328,7 +1328,7 @@ mkGenericDefMethBind clas inst_tys sel_id dm_name
(vcat [ppr clas <+> ppr inst_tys,
nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
- ; return (noLoc $ mkTopFunBind (noLoc (idName sel_id))
+ ; return (noLoc $ mkTopFunBind Generated (noLoc (idName sel_id))
[mkSimpleMatch [] rhs]) }
where
rhs = nlHsVar dm_name
diff --git a/compiler/typecheck/TcMatches.lhs b/compiler/typecheck/TcMatches.lhs
index 08ce7745d3c3fa39fc4658daf3f3688668e4a2e8..5859e7b810c47f0b1ff46e3d52116662b3a1f3ea 100644
--- a/compiler/typecheck/TcMatches.lhs
+++ b/compiler/typecheck/TcMatches.lhs
@@ -109,7 +109,7 @@ tcMatchesCase :: (Outputable (body Name)) =>
tcMatchesCase ctxt scrut_ty matches res_ty
| isEmptyMatchGroup matches -- Allow empty case expressions
- = return (MG { mg_alts = [], mg_arg_tys = [scrut_ty], mg_res_ty = res_ty })
+ = return (MG { mg_alts = [], mg_arg_tys = [scrut_ty], mg_res_ty = res_ty, mg_origin = mg_origin matches })
| otherwise
= tcMatches ctxt [scrut_ty] res_ty matches
@@ -180,10 +180,10 @@ data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module
-> TcRhoType
-> TcM (Located (body TcId)) }
-tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = matches })
+tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = matches, mg_origin = origin })
= ASSERT( not (null matches) ) -- Ensure that rhs_ty is filled in
do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
- ; return (MG { mg_alts = matches', mg_arg_tys = pat_tys, mg_res_ty = rhs_ty }) }
+ ; return (MG { mg_alts = matches', mg_arg_tys = pat_tys, mg_res_ty = rhs_ty, mg_origin = origin }) }
-------------
tcMatch :: (Outputable (body Name)) => TcMatchCtxt body
diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs
index fdbee92648d7b6e1c0ce2fea08ba8245ce8c89af..0b3b4e4858215ea34ef12786be1d8cc07b1b3db8 100644
--- a/compiler/typecheck/TcPatSyn.lhs
+++ b/compiler/typecheck/TcPatSyn.lhs
@@ -200,18 +200,21 @@ tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_d
MG{ mg_alts = cases
, mg_arg_tys = [pat_ty]
, mg_res_ty = res_ty
+ , mg_origin = Generated
}
body' = noLoc $
HsLam $
MG{ mg_alts = [mkSimpleMatch args body]
, mg_arg_tys = [pat_ty, cont_ty, res_ty]
, mg_res_ty = res_ty
+ , mg_origin = Generated
}
match = mkMatch [] (mkHsLams (res_tv:univ_tvs) req_dicts body') EmptyLocalBinds
mg = MG{ mg_alts = [match]
, mg_arg_tys = []
, mg_res_ty = res_ty
+ , mg_origin = Generated
}
; let bind = FunBind{ fun_id = matcher_lid
@@ -220,7 +223,7 @@ tcPatSynMatcher (L loc name) lpat args univ_tvs ex_tvs ev_binds prov_dicts req_d
, fun_co_fn = idHsWrapper
, bind_fvs = emptyNameSet
, fun_tick = Nothing }
- matcher_bind = unitBag (Generated, noLoc bind)
+ matcher_bind = unitBag (noLoc bind)
; traceTc "tcPatSynMatcher" (ppr matcher_bind)
@@ -272,7 +275,7 @@ tc_pat_syn_wrapper_from_expr (L loc name) lexpr args univ_tvs ex_tvs theta pat_t
; let wrapper_args = map (noLoc . VarPat . Var.varName) args'
wrapper_match = mkMatch wrapper_args lexpr EmptyLocalBinds
- bind = mkTopFunBind wrapper_lname [wrapper_match]
+ bind = mkTopFunBind Generated wrapper_lname [wrapper_match]
lbind = noLoc bind
; let sig = TcSigInfo{ sig_id = wrapper_id
, sig_tvs = map (\tv -> (Nothing, tv)) wrapper_tvs
@@ -280,7 +283,7 @@ tc_pat_syn_wrapper_from_expr (L loc name) lexpr args univ_tvs ex_tvs theta pat_t
, sig_tau = wrapper_tau
, sig_loc = loc
}
- ; (wrapper_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig (Generated, lbind)
+ ; (wrapper_binds, _, _) <- tcPolyCheck NonRecursive (const []) sig lbind
; traceTc "tcPatSynDecl wrapper" $ ppr wrapper_binds
; traceTc "tcPatSynDecl wrapper type" $ ppr (varType wrapper_id)
; return (wrapper_id, wrapper_binds) }
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 90d7151c69af1611dbf3b9bcbfa7f5587ad7d836..12eb96f19d7c77c3583ab088d65c0bf64b5807e2 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -84,9 +84,7 @@ import Annotations
import Data.List ( sortBy )
import Data.IORef ( readIORef )
import Data.Ord
-#ifndef GHCI
-import BasicTypes ( Origin(..) )
-#else
+#ifdef GHCI
import BasicTypes hiding( SuccessFlag(..) )
import TcType ( isUnitTy, isTauTy )
import TcHsType
@@ -673,7 +671,7 @@ checkHiBootIface
; mb_dfun_prs <- mapM check_inst boot_insts
; let dfun_prs = catMaybes mb_dfun_prs
boot_dfuns = map fst dfun_prs
- dfun_binds = listToBag [ (Generated, mkVarBind boot_dfun (nlHsVar dfun))
+ dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
| (boot_dfun, dfun) <- dfun_prs ]
type_env' = extendTypeEnvWithIds local_type_env boot_dfuns
tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds }
@@ -1371,7 +1369,7 @@ check_main dflags tcg_env
; return (tcg_env { tcg_main = Just main_name,
tcg_binds = tcg_binds tcg_env
- `snocBag` (Generated, main_bind),
+ `snocBag` main_bind,
tcg_dus = tcg_dus tcg_env
`plusDU` usesOnly (unitFV main_name)
-- Record the use of 'main', so that we don't
@@ -1606,14 +1604,14 @@ tcUserStmt (L loc (BodyStmt expr _ _ _))
; let fresh_it = itName uniq loc
matches = [mkMatch [] rn_expr emptyLocalBinds]
-- [it = expr]
- the_bind = L loc $ (mkTopFunBind (L loc fresh_it) matches) { bind_fvs = fvs }
+ the_bind = L loc $ (mkTopFunBind FromSource (L loc fresh_it) matches) { bind_fvs = fvs }
-- Care here! In GHCi the expression might have
-- free variables, and they in turn may have free type variables
-- (if we are at a breakpoint, say). We must put those free vars
-- [let it = expr]
let_stmt = L loc $ LetStmt $ HsValBinds $
- ValBindsOut [(NonRecursive,unitBag (FromSource, the_bind))] []
+ ValBindsOut [(NonRecursive,unitBag the_bind)] []
-- [it <- e]
bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it))
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index b8b1b87e91bcb1d2606c884c1bcc69c04dfa6f28..01c9d36cf3674aaf035860da9d138c6d5efdbe9a 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -48,7 +48,7 @@ import FastString
import Panic
import Util
import Annotations
-import BasicTypes( TopLevelFlag, Origin )
+import BasicTypes( TopLevelFlag )
import Control.Exception
import Data.IORef
@@ -587,11 +587,6 @@ addLocM fn (L loc a) = setSrcSpan loc $ fn a
wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)
wrapLocM fn (L loc a) = setSrcSpan loc $ do b <- fn a; return (L loc b)
-wrapOriginLocM :: (a -> TcM r) -> (Origin, Located a) -> TcM (Origin, Located r)
-wrapOriginLocM fn (origin, lbind)
- = do { lbind' <- wrapLocM fn lbind
- ; return (origin, lbind') }
-
wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c)
wrapLocFstM fn (L loc a) =
setSrcSpan loc $ do
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 1e32847bdf4bf428b3148bde4b0c99679af63c31..51e646462eaf09a29e9593bd60a9ebcd2d499f39 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -1833,7 +1833,7 @@ mkRecSelBinds tycons
mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
mkRecSelBind (tycon, sel_name)
- = (L loc (IdSig sel_id), unitBag (Generated, L loc sel_bind))
+ = (L loc (IdSig sel_id), unitBag (L loc sel_bind))
where
loc = getSrcSpan sel_name
sel_id = Var.mkExportedLocalVar rec_details sel_name
@@ -1862,8 +1862,10 @@ mkRecSelBind (tycon, sel_name)
-- Make the binding: sel (C2 { fld = x }) = x
-- sel (C7 { fld = x }) = x
-- where cons_w_field = [C2,C7]
- sel_bind | is_naughty = mkTopFunBind sel_lname [mkSimpleMatch [] unit_rhs]
- | otherwise = mkTopFunBind sel_lname (map mk_match cons_w_field ++ deflt)
+ sel_bind = mkTopFunBind Generated sel_lname alts
+ where
+ alts | is_naughty = [mkSimpleMatch [] unit_rhs]
+ | otherwise = map mk_match cons_w_field ++ deflt
mk_match con = mkSimpleMatch [L loc (mk_sel_pat con)]
(L loc (HsVar field_var))
mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs
index 9fffd5246474b70ac6d1267a82090c3f088614be..9bf1a2d0c348759f9aa508b42e8c29edf9f03e1e 100644
--- a/utils/ghctags/Main.hs
+++ b/utils/ghctags/Main.hs
@@ -257,7 +257,7 @@ boundValues mod group =
let vals = case hs_valds group of
ValBindsOut nest _sigs ->
[ x | (_rec, binds) <- nest
- , (_, bind) <- bagToList binds
+ , bind <- bagToList binds
, x <- boundThings mod bind ]
_other -> error "boundValues"
tys = [ n | ns <- map hsLTyClDeclBinders (tyClGroupConcat (hs_tyclds group))