diff options
| author | Dr. ERDI Gergo <gergo@erdi.hu> | 2014-04-12 19:36:31 +0800 |
|---|---|---|
| committer | Dr. ERDI Gergo <gergo@erdi.hu> | 2014-04-13 16:40:59 +0800 |
| commit | eeaea2df3fa585db503034f419c6e4331a4d8a84 (patch) | |
| tree | 707a2ccc7ca5b189a1b45c6e6b3688098ba31d09 | |
| parent | 7fa0b43593644fba8a3a60e5503a55268578d3c0 (diff) | |
| download | haskell-eeaea2df3fa585db503034f419c6e4331a4d8a84.tar.gz | |
Instead of tracking Origin in LHsBindsLR, track it in MatchGroup
29 files changed, 186 insertions, 200 deletions
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 0ac7de8022..6bdc61d9c2 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 763106f2b3..f87877681c 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 4833e8090a..1dbf530123 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 d1ef24070c..859309d592 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 6df92af517..73c1adfdc8 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -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 diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs index e0a5d4af0c..b42a720c32 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 69d2bd012d..bcea29bea2 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -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' } diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs index e904633eec..2261a89741 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 4c0c955cdd..f5ba1903ee 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 558c104fad..eff67df3cf 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 715ee8130c..4f901b1849 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 8e4da8ce2b..4f4ec0b123 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 b1e177a3a9..03ec622223 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 ba94a390f4..7251492ccf 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 c726d554fc..fbc22c0c28 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 b427dd5409..407e1725ff 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 8b2928c8c8..d46e441130 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 @@ -993,12 +990,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 @@ -1016,17 +1013,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.) @@ -1034,7 +1030,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) } ------------------------ @@ -1266,7 +1262,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 @@ -1280,7 +1276,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 @@ -1289,7 +1285,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 @@ -1330,7 +1326,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) @@ -1352,7 +1348,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 @@ -1391,31 +1387,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 6fc2213cbc..187aea5083 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 ce200b23ad..71fd25c557 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 @@ -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 diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 26af2c5ebf..63eb020ff1 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 581cebc9c4..7031e54f6f 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 1c9ac57e80..59b42ea673 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 f701b30db8..fc1842908d 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -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) -> 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) @@ -1197,10 +1197,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 @@ -1216,12 +1216,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) @@ -1229,8 +1229,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 @@ -1272,13 +1272,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 @@ -1329,7 +1329,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 08ce7745d3..5859e7b810 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 fdbee92648..0b3b4e4858 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 90d7151c69..12eb96f19d 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 b3d37f6178..27ec52fe9c 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -49,7 +49,7 @@ import FastString import Panic import Util import Annotations -import BasicTypes( TopLevelFlag, Origin ) +import BasicTypes( TopLevelFlag ) import Control.Exception import Data.IORef @@ -588,11 +588,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 3a589a9ce1..f11295a7d0 100644 --- a/compiler/typecheck/TcTyClsDecls.lhs +++ b/compiler/typecheck/TcTyClsDecls.lhs @@ -1835,7 +1835,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 @@ -1864,8 +1864,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 9fffd52464..9bf1a2d0c3 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)) |