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

Instead of tracking Origin in LHsBindsLR, track it in MatchGroup

parent 7fa0b435
...@@ -117,7 +117,7 @@ guessSourceFile :: LHsBinds Id -> FilePath -> FilePath ...@@ -117,7 +117,7 @@ guessSourceFile :: LHsBinds Id -> FilePath -> FilePath
guessSourceFile binds orig_file = guessSourceFile binds orig_file =
-- Try look for a file generated from a .hsc file to a -- Try look for a file generated from a .hsc file to a
-- .hs file, by peeking ahead. -- .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 srcSpanFileName_maybe pos : rest) [] binds
in in
case top_pos of case top_pos of
...@@ -229,11 +229,7 @@ shouldTickPatBind density top_lev ...@@ -229,11 +229,7 @@ shouldTickPatBind density top_lev
-- Adding ticks to bindings -- Adding ticks to bindings
addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id) addTickLHsBinds :: LHsBinds Id -> TM (LHsBinds Id)
addTickLHsBinds binds = mapBagM addTick binds addTickLHsBinds = mapBagM addTickLHsBind
where
addTick (origin, bind) = do
bind' <- addTickLHsBind bind
return (origin, bind')
addTickLHsBind :: LHsBind Id -> TM (LHsBind Id) addTickLHsBind :: LHsBind Id -> TM (LHsBind Id)
addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds, addTickLHsBind (L pos bind@(AbsBinds { abs_binds = binds,
......
...@@ -517,7 +517,7 @@ case bodies, containing the following fields: ...@@ -517,7 +517,7 @@ case bodies, containing the following fields:
\begin{code} \begin{code}
dsCmd ids local_vars stack_ty res_ty 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 env_ids = do
stack_id <- newSysLocalDs stack_ty stack_id <- newSysLocalDs stack_ty
...@@ -561,7 +561,7 @@ dsCmd ids local_vars stack_ty res_ty ...@@ -561,7 +561,7 @@ dsCmd ids local_vars stack_ty res_ty
in_ty = envStackType env_ids stack_ty in_ty = envStackType env_ids stack_ty
core_body <- dsExpr (HsCase exp (MG { mg_alts = matches', mg_arg_tys = arg_tys 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, -- Note that we replace the HsCase result type by sum_ty,
-- which is the type of matches' -- which is the type of matches'
......
...@@ -95,13 +95,8 @@ ds_lhs_binds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr)) ...@@ -95,13 +95,8 @@ ds_lhs_binds :: LHsBinds Id -> DsM (OrdList (Id,CoreExpr))
ds_lhs_binds binds = do { ds_bs <- mapBagM dsLHsBind binds ds_lhs_binds binds = do { ds_bs <- mapBagM dsLHsBind binds
; return (foldBag appOL id nilOL ds_bs) } ; return (foldBag appOL id nilOL ds_bs) }
dsLHsBind :: (Origin, LHsBind Id) -> DsM (OrdList (Id,CoreExpr)) dsLHsBind :: LHsBind Id -> DsM (OrdList (Id,CoreExpr))
dsLHsBind (origin, L loc bind) dsLHsBind (L loc bind) = putSrcSpanDs loc $ dsHsBind bind
= handleWarnings $ putSrcSpanDs loc $ dsHsBind bind
where
handleWarnings = if isGenerated origin
then discardWarningsDs
else id
dsHsBind :: HsBind Id -> DsM (OrdList (Id,CoreExpr)) dsHsBind :: HsBind Id -> DsM (OrdList (Id,CoreExpr))
......
...@@ -99,7 +99,7 @@ ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr ...@@ -99,7 +99,7 @@ ds_val_bind :: (RecFlag, LHsBinds Id) -> CoreExpr -> DsM CoreExpr
-- a tuple and doing selections. -- a tuple and doing selections.
-- Silently ignore INLINE and SPECIALISE pragmas... -- Silently ignore INLINE and SPECIALISE pragmas...
ds_val_bind (NonRecursive, hsbinds) body 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 -- Non-recursive, non-overloaded bindings only come in ones
-- ToDo: in some bizarre case it's conceivable that there -- ToDo: in some bizarre case it's conceivable that there
-- could be dict binds in the 'binds'. (See the notes -- could be dict binds in the 'binds'. (See the notes
...@@ -130,11 +130,11 @@ dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr ...@@ -130,11 +130,11 @@ dsStrictBind :: HsBind Id -> CoreExpr -> DsM CoreExpr
dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = [] dsStrictBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
, abs_exports = exports , abs_exports = exports
, abs_ev_binds = ev_binds , abs_ev_binds = ev_binds
, abs_binds = binds }) body , abs_binds = lbinds }) body
= do { let body1 = foldr bind_export body exports = do { let body1 = foldr bind_export body exports
bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
; body2 <- foldlBagM (\body (_, bind) -> dsStrictBind (unLoc bind) body) ; body2 <- foldlBagM (\body lbind -> dsStrictBind (unLoc lbind) body)
body1 binds body1 lbinds
; ds_binds <- dsTcEvBinds ev_binds ; ds_binds <- dsTcEvBinds ev_binds
; return (mkCoreLets ds_binds body2) } ; return (mkCoreLets ds_binds body2) }
...@@ -163,8 +163,8 @@ dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) ...@@ -163,8 +163,8 @@ dsStrictBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
---------------------- ----------------------
strictMatchOnly :: HsBind Id -> Bool strictMatchOnly :: HsBind Id -> Bool
strictMatchOnly (AbsBinds { abs_binds = binds }) strictMatchOnly (AbsBinds { abs_binds = lbinds })
= anyBag (strictMatchOnly . unLoc . snd) binds = anyBag (strictMatchOnly . unLoc) lbinds
strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty }) strictMatchOnly (PatBind { pat_lhs = lpat, pat_rhs_ty = rhs_ty })
= isUnLiftedType rhs_ty = isUnLiftedType rhs_ty
|| isStrictLPat lpat || isStrictLPat lpat
...@@ -488,7 +488,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) ...@@ -488,7 +488,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
-- constructor aguments. -- constructor aguments.
; alts <- mapM (mk_alt upd_fld_env) cons_to_upd ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
; ([discrim_var], matching_code) ; ([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' $ ; return (add_field_binds field_binds' $
bindNonRec discrim_var record_expr' matching_code) } bindNonRec discrim_var record_expr' matching_code) }
...@@ -789,7 +789,8 @@ dsDo stmts ...@@ -789,7 +789,8 @@ dsDo stmts
rets = map noLoc rec_rets rets = map noLoc rec_rets
mfix_app = nlHsApp (noLoc mfix_op) mfix_arg mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
mfix_arg = noLoc $ HsLam (MG { mg_alts = [mkSimpleMatch [mfix_pat] body] 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 mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTup rec_tup_pats
body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
ret_app = nlHsApp (noLoc return_op) (mkBigLHsTup rets) ret_app = nlHsApp (noLoc return_op) (mkBigLHsTup rets)
......
...@@ -1180,7 +1180,7 @@ rep_binds binds = do { binds_w_locs <- rep_binds' binds ...@@ -1180,7 +1180,7 @@ rep_binds binds = do { binds_w_locs <- rep_binds' binds
; return (de_loc (sort_by_loc binds_w_locs)) } ; return (de_loc (sort_by_loc binds_w_locs)) }
rep_binds' :: LHsBinds Name -> DsM [(SrcSpan, Core TH.DecQ)] 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) rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
-- Assumes: all the binders of the binding are alrady in the meta-env -- Assumes: all the binders of the binding are alrady in the meta-env
......
...@@ -40,7 +40,7 @@ import Maybes ...@@ -40,7 +40,7 @@ import Maybes
import Util import Util
import Name import Name
import Outputable import Outputable
import BasicTypes ( boxityNormalTupleSort ) import BasicTypes ( boxityNormalTupleSort, isGenerated )
import FastString import FastString
import Control.Monad( when ) import Control.Monad( when )
...@@ -752,12 +752,14 @@ JJQC 30-Nov-1997 ...@@ -752,12 +752,14 @@ JJQC 30-Nov-1997
\begin{code} \begin{code}
matchWrapper ctxt (MG { mg_alts = matches matchWrapper ctxt (MG { mg_alts = matches
, mg_arg_tys = arg_tys , 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 = do { eqns_info <- mapM mk_eqn_info matches
; new_vars <- case matches of ; new_vars <- case matches of
[] -> mapM newSysLocalDs arg_tys [] -> mapM newSysLocalDs arg_tys
(m:_) -> selectMatchVars (map unLoc (hsLMatchPats m)) (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) } ; return (new_vars, result_expr) }
where where
mk_eqn_info (L _ (Match pats _ grhss)) mk_eqn_info (L _ (Match pats _ grhss))
...@@ -765,6 +767,10 @@ matchWrapper ctxt (MG { mg_alts = matches ...@@ -765,6 +767,10 @@ matchWrapper ctxt (MG { mg_alts = matches
; match_result <- dsGRHSs ctxt upats grhss rhs_ty ; match_result <- dsGRHSs ctxt upats grhss rhs_ty
; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) } ; return (EqnInfo { eqn_pats = upats, eqn_rhs = match_result}) }
handleWarnings = if isGenerated origin
then discardWarningsDs
else id
matchEquations :: HsMatchContext Name matchEquations :: HsMatchContext Name
-> [Id] -> [EquationInfo] -> Type -> [Id] -> [EquationInfo] -> Type
......
...@@ -301,7 +301,7 @@ cvt_ci_decs doc decs ...@@ -301,7 +301,7 @@ cvt_ci_decs doc decs
; unless (null bads) (failWith (mkBadDecMsg doc bads)) ; unless (null bads) (failWith (mkBadDecMsg doc bads))
--We use FromSource as the origin of the bind --We use FromSource as the origin of the bind
-- because the TH declaration is user-written -- 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] cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
...@@ -536,9 +536,7 @@ cvtLocalDecs doc ds ...@@ -536,9 +536,7 @@ cvtLocalDecs doc ds
; let (binds, prob_sigs) = partitionWith is_bind ds' ; let (binds, prob_sigs) = partitionWith is_bind ds'
; let (sigs, bads) = partitionWith is_sig prob_sigs ; let (sigs, bads) = partitionWith is_sig prob_sigs
; unless (null bads) (failWith (mkBadDecMsg doc bads)) ; unless (null bads) (failWith (mkBadDecMsg doc bads))
; return (HsValBinds (ValBindsIn (toBindBag binds) sigs)) } ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
where
toBindBag = listToBag . map (\bind -> (FromSource, bind))
cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName)) cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
cvtClause (Clause ps body wheres) cvtClause (Clause ps body wheres)
...@@ -563,10 +561,10 @@ cvtl e = wrapL (cvt e) ...@@ -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 (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 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 cvt (LamCaseE ms) = do { ms' <- mapM cvtMatch ms
; return $ HsLamCase placeHolderType ; return $ HsLamCase placeHolderType
(mkMatchGroup ms') (mkMatchGroup FromSource ms')
} }
cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' } cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' }
-- Note [Dropping constructors] -- Note [Dropping constructors]
...@@ -582,7 +580,7 @@ cvtl e = wrapL (cvt e) ...@@ -582,7 +580,7 @@ cvtl e = wrapL (cvt e)
cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
; e' <- cvtl e; return $ HsLet ds' e' } ; e' <- cvtl e; return $ HsLet ds' e' }
cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM cvtMatch ms 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 (DoE ss) = cvtHsDo DoExpr ss
cvt (CompE ss) = cvtHsDo ListComp ss cvt (CompE ss) = cvtHsDo ListComp ss
cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' } cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' }
......
...@@ -89,7 +89,7 @@ type LHsBind id = LHsBindLR id id ...@@ -89,7 +89,7 @@ type LHsBind id = LHsBindLR id id
type LHsBinds id = LHsBindsLR id id type LHsBinds id = LHsBindsLR id id
type HsBind id = HsBindLR 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) type LHsBindLR idL idR = Located (HsBindLR idL idR)
data HsBindLR idL idR data HsBindLR idL idR
...@@ -322,7 +322,7 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR id ...@@ -322,7 +322,7 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR id
pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc
pprLHsBinds binds pprLHsBinds binds
| isEmptyLHsBinds binds = empty | isEmptyLHsBinds binds = empty
| otherwise = pprDeclList (map (ppr . snd) (bagToList binds)) | otherwise = pprDeclList (map ppr (bagToList binds))
pprLHsBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2) pprLHsBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2)
=> LHsBindsLR idL idR -> [LSig id2] -> [SDoc] => LHsBindsLR idL idR -> [LSig id2] -> [SDoc]
...@@ -338,7 +338,7 @@ pprLHsBindsForUser binds sigs ...@@ -338,7 +338,7 @@ pprLHsBindsForUser binds sigs
decls :: [(SrcSpan, SDoc)] decls :: [(SrcSpan, SDoc)]
decls = [(loc, ppr sig) | L loc sig <- sigs] ++ 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 sort_by_loc decls = sortBy (comparing fst) decls
......
...@@ -909,7 +909,8 @@ patterns in each equation. ...@@ -909,7 +909,8 @@ patterns in each equation.
data MatchGroup id body data MatchGroup id body
= MG { mg_alts :: [LMatch id body] -- The alternatives = MG { mg_alts :: [LMatch id body] -- The alternatives
, mg_arg_tys :: [PostTcType] -- Types of the arguments, t1..tn , 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 -- The type is the type of the entire group
-- t1 -> ... -> tn -> tr -- t1 -> ... -> tn -> tr
-- where there are n patterns -- where there are n patterns
......
...@@ -132,8 +132,8 @@ unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds ...@@ -132,8 +132,8 @@ unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds
unguardedRHS :: Located (body id) -> [LGRHS id (Located (body id))] unguardedRHS :: Located (body id) -> [LGRHS id (Located (body id))]
unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)] unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
mkMatchGroup :: [LMatch id (Located (body id))] -> MatchGroup id (Located (body id)) mkMatchGroup :: Origin -> [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 matches = MG { mg_alts = matches, mg_arg_tys = [], mg_res_ty = placeHolderType, mg_origin = origin }
mkHsAppTy :: LHsType name -> LHsType name -> LHsType name mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2) mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
...@@ -144,7 +144,7 @@ mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2) ...@@ -144,7 +144,7 @@ mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
where where
matches = mkMatchGroup [mkSimpleMatch pats body] matches = mkMatchGroup Generated [mkSimpleMatch pats body]
mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id
mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr
...@@ -351,11 +351,11 @@ nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id ...@@ -351,11 +351,11 @@ nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
nlHsCase :: LHsExpr id -> [LMatch id (LHsExpr id)] -> LHsExpr id nlHsCase :: LHsExpr id -> [LMatch id (LHsExpr id)] -> LHsExpr id
nlList :: [LHsExpr id] -> LHsExpr id nlList :: [LHsExpr id] -> LHsExpr id
nlHsLam match = noLoc (HsLam (mkMatchGroup [match])) nlHsLam match = noLoc (HsLam (mkMatchGroup Generated [match]))
nlHsPar e = noLoc (HsPar e) nlHsPar e = noLoc (HsPar e)
nlHsIf cond true false = noLoc (mkHsIf cond true false) nlHsIf cond true false = noLoc (mkHsIf cond true false)
nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches)) nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup Generated matches))
nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs) nlList exprs = noLoc (ExplicitList placeHolderType Nothing exprs)
nlHsAppTy :: LHsType name -> LHsType name -> LHsType name nlHsAppTy :: LHsType name -> LHsType name -> LHsType name
nlHsTyVar :: name -> LHsType name nlHsTyVar :: name -> LHsType name
...@@ -478,20 +478,20 @@ l ...@@ -478,20 +478,20 @@ l
mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> HsBind RdrName mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> HsBind RdrName
-- Not infix, with place holders for coercion and free vars -- Not infix, with place holders for coercion and free vars
mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False
, fun_matches = mkMatchGroup ms , fun_matches = mkMatchGroup Generated ms
, fun_co_fn = idHsWrapper , fun_co_fn = idHsWrapper
, bind_fvs = placeHolderNames , 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 -- In Name-land, with empty bind_fvs
mkTopFunBind fn ms = FunBind { fun_id = fn, fun_infix = False mkTopFunBind origin fn ms = FunBind { fun_id = fn, fun_infix = False
, fun_matches = mkMatchGroup ms , fun_matches = mkMatchGroup origin ms
, fun_co_fn = idHsWrapper , fun_co_fn = idHsWrapper
, bind_fvs = emptyNameSet -- NB: closed binding , bind_fvs = emptyNameSet -- NB: closed binding
, fun_tick = Nothing } , 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 mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
mkVarBind :: id -> LHsExpr id -> LHsBind id mkVarBind :: id -> LHsExpr id -> LHsBind id
...@@ -507,9 +507,9 @@ mkPatSynBind name details lpat dir = PatSynBind{ patsyn_id = name ...@@ -507,9 +507,9 @@ mkPatSynBind name details lpat dir = PatSynBind{ patsyn_id = name
------------ ------------
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName] mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
-> LHsExpr RdrName -> (Origin, LHsBind RdrName) -> LHsExpr RdrName -> LHsBind RdrName
mk_easy_FunBind loc fun pats expr 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) mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id (LHsExpr id)
...@@ -580,11 +580,11 @@ collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL] ...@@ -580,11 +580,11 @@ collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
collectHsBindListBinders = foldr (collect_bind . unLoc) [] collectHsBindListBinders = foldr (collect_bind . unLoc) []
collect_binds :: LHsBindsLR idL idR -> [idL] -> [idL] 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] collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
-- Used exclusively for the bindings of an instance decl which are all FunBinds -- 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 where
get (FunBind { fun_id = f }) fs = f : fs get (FunBind { fun_id = f }) fs = f : fs
get _ fs = fs get _ fs = fs
...@@ -808,7 +808,7 @@ hsValBindsImplicits (ValBindsIn binds _) ...@@ -808,7 +808,7 @@ hsValBindsImplicits (ValBindsIn binds _)
= lhsBindsImplicits binds = lhsBindsImplicits binds
lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet
lhsBindsImplicits = foldBag unionNameSets (lhs_bind . unLoc . snd) emptyNameSet lhsBindsImplicits = foldBag unionNameSets (lhs_bind . unLoc) emptyNameSet
where where
lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
lhs_bind _ = emptyNameSet lhs_bind _ = emptyNameSet
......
...@@ -132,7 +132,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) ...@@ -132,7 +132,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
class_info decl@(ClassDecl {}) class_info decl@(ClassDecl {})
= (classops, addpr (sum3 (map count_bind methods))) = (classops, addpr (sum3 (map count_bind methods)))
where where
methods = map (unLoc . snd) $ bagToList (tcdMeths decl) methods = map unLoc $ bagToList (tcdMeths decl)
(_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl)) (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl))
class_info _ = (0,0) class_info _ = (0,0)
...@@ -147,7 +147,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _)) ...@@ -147,7 +147,7 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
(addpr (sum3 (map count_bind methods)), (addpr (sum3 (map count_bind methods)),
ss, is, length ats, length adts) ss, is, length ats, length adts)
where where
methods = map (unLoc . snd) $ bagToList inst_meths methods = map unLoc $ bagToList inst_meths
-- TODO: use Sum monoid -- TODO: use Sum monoid
addpr :: (Int,Int,Int) -> Int addpr :: (Int,Int,Int) -> Int
......
...@@ -1476,18 +1476,18 @@ infixexp :: { LHsExpr RdrName } ...@@ -1476,18 +1476,18 @@ infixexp :: { LHsExpr RdrName }
exp10 :: { LHsExpr RdrName } exp10 :: { LHsExpr RdrName }
: '\\' apat apats opt_asig '->' exp : '\\' apat apats opt_asig '->' exp
{ LL $ HsLam (mkMatchGroup [LL $ Match ($2:$3) $4 { LL $ HsLam (mkMatchGroup FromSource [LL $ Match ($2:$3) $4
(unguardedGRHSs $6) (unguardedGRHSs $6)
]) } ]) }
| 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 } | 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 }
| '\\' 'lcase' altslist | '\\' 'lcase' altslist
{ LL $ HsLamCase placeHolderType (mkMatchGroup (unLoc $3)) } { LL $ HsLamCase placeHolderType (mkMatchGroup FromSource (unLoc $3)) }
| 'if' exp optSemi 'then' exp optSemi 'else' exp | 'if' exp optSemi 'then' exp optSemi 'else' exp
{% checkDoAndIfThenElse $2 $3 $5 $6 $8 >> {% checkDoAndIfThenElse $2 $3 $5 $6 $8 >>
return (LL $ mkHsIf $2 $5 $8) } return (LL $ mkHsIf $2 $5 $8) }
| 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >> | 'if' ifgdpats {% hintMultiWayIf (getLoc $1) >>
return (LL $ HsMultiIf placeHolderType (reverse $ unLoc $2)) } 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 } | '-' fexp { LL $ NegApp $2 noSyntaxExpr }
| 'do' stmtlist { L (comb2 $1 $2) (mkHsDo DoExpr (unLoc $2)) } | 'do' stmtlist { L (comb2 $1 $2) (mkHsDo DoExpr (unLoc $2)) }
......
...@@ -315,7 +315,7 @@ cvBindsAndSigs fb = go (fromOL fb) ...@@ -315,7 +315,7 @@ cvBindsAndSigs fb = go (fromOL fb)
go [] = (emptyBag, [], [], [], [], []) go [] = (emptyBag, [], [], [], [], [])
go (L l (SigD s) : ds) = (bs, L l s : ss, ts, tfis, dfis, docs) go (L l (SigD s) : ds) = (bs, L l s : ss, ts, tfis, dfis, docs)
where (bs, ss, ts, tfis, dfis, docs) = go ds 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 where (b', ds') = getMonoBind (L l b) ds
(bs, ss, ts, tfis, dfis, docs) = go 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) 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) ...@@ -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 makeFunBind :: Located id -> Bool -> [LMatch id (LHsExpr id)] -> HsBind id
-- Like HsUtils.mkFunBind, but we need to be able to set the fixity too -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
makeFunBind fn is_infix ms 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 } fun_co_fn = idHsWrapper, bind_fvs = placeHolderNames, fun_tick = Nothing }
checkPatBind :: SDoc checkPatBind :: SDoc
......
...@@ -47,7 +47,7 @@ import NameSet ...@@ -47,7 +47,7 @@ import NameSet
import RdrName ( RdrName, rdrNameOcc ) import RdrName ( RdrName, rdrNameOcc )
import SrcLoc import SrcLoc
import ListSetOps ( findDupsEq ) import ListSetOps ( findDupsEq )
import BasicTypes ( RecFlag(..), Origin ) import BasicTypes ( RecFlag(..) )
import Digraph ( SCC(..) ) import Digraph ( SCC(..) )
import Bag import Bag
import Outputable import Outputable
...@@ -275,7 +275,7 @@ rnValBindsLHS :: NameMaker ...@@ -275,7 +275,7 @@ rnValBindsLHS :: NameMaker
-> HsValBinds RdrName -> HsValBinds RdrName
-> RnM (HsValBindsLR Name RdrName) -> RnM (HsValBindsLR Name RdrName)
rnValBindsLHS topP (ValBindsIn mbinds sigs) 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 } ; return $ ValBindsIn mbinds' sigs }
where where
bndrs = collectHsBindsBinders mbinds bndrs = collectHsBindsBinders mbinds
...@@ -448,12 +448,12 @@ rnBindLHS name_maker _ bind@(PatSynBind{ patsyn_id = rdrname@(L nameLoc _) }) ...@@ -448,12 +448,12 @@ rnBindLHS name_maker _ bind@(PatSynBind{ patsyn_id = rdrname@(L nameLoc _) })
rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b) rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b)
rnLBind :: (Name -> [Name]) -- Signature tyvar function rnLBind :: (Name -> [Name]) -- Signature tyvar function
-> (Origin, LHsBindLR Name RdrName) -> LHsBindLR Name RdrName
-> RnM ((Origin, LHsBind Name), [Name], Uses) -> RnM (LHsBind Name, [Name], Uses)
rnLBind sig_fn (origin, (L loc bind)) rnLBind sig_fn (L loc bind)
= setSrcSpan loc $ = setSrcSpan loc $
do { (bind', bndrs, dus) <- rnBind sig_fn bind 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 -- assumes the left-hands-side vars are in scope
rnBind :: (Name -> [Name]) -- Signature tyvar function rnBind :: (Name -> [Name]) -- Signature tyvar function
...@@ -581,7 +581,7 @@ trac ticket #1136. ...@@ -581,7 +581,7 @@ trac ticket #1136.
-} -}
---------------------