Commit 306ecad5 authored by Alan Zimmerman's avatar Alan Zimmerman
Browse files

Merge MatchFixity and HsMatchContext

Summary:
MatchFixity was introduced to facilitate use of API Annotations.

HsMatchContext does the same thing with more detail, but is chased
through all over the place to provide context when processing a Match.

Since we already have MatchFixity in the Match, it may as well provide
the full context.

updates submodule haddock

Test Plan: ./validate

Reviewers: austin, goldfire, bgamari

Subscribers: thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D2271

GHC Trac Issues: #12105
parent 1937ef1c
...@@ -1328,8 +1328,9 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun ...@@ -1328,8 +1328,9 @@ pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun
(ppr_match, pref) (ppr_match, pref)
= case kind of = case kind of
FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) FunRhs (L _ fun) _ -> (pprMatchContext kind,
_ -> (pprMatchContext kind, \ pp -> pp) \ pp -> ppr fun <+> pp)
_ -> (pprMatchContext kind, \ pp -> pp)
ppr_pats :: HsMatchContext Name -> [Pat Id] -> SDoc ppr_pats :: HsMatchContext Name -> [Pat Id] -> SDoc
ppr_pats kind pats ppr_pats kind pats
......
...@@ -124,7 +124,9 @@ dsHsBind dflags ...@@ -124,7 +124,9 @@ dsHsBind dflags
dsHsBind dflags dsHsBind dflags
(FunBind { fun_id = L _ fun, fun_matches = matches (FunBind { fun_id = L _ fun, fun_matches = matches
, fun_co_fn = co_fn, fun_tick = tick }) , fun_co_fn = co_fn, fun_tick = tick })
= do { (args, body) <- matchWrapper (FunRhs (idName fun)) Nothing matches = do { (args, body) <- matchWrapper
(FunRhs (noLoc $ idName fun) Prefix)
Nothing matches
; let body' = mkOptTickBox tick body ; let body' = mkOptTickBox tick body
; rhs <- dsHsWrapper co_fn (mkLams args body') ; rhs <- dsHsWrapper co_fn (mkLams args body')
; let core_binds@(id,_) = makeCorePair dflags fun False 0 rhs ; let core_binds@(id,_) = makeCorePair dflags fun False 0 rhs
...@@ -313,7 +315,9 @@ dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts ...@@ -313,7 +315,9 @@ dsHsBind dflags (AbsBindsSig { abs_tvs = tyvars, abs_ev_vars = dicts
= putSrcSpanDs bind_loc $ = putSrcSpanDs bind_loc $
addDictsDs (toTcTypeBag (listToBag dicts)) $ addDictsDs (toTcTypeBag (listToBag dicts)) $
-- addDictsDs: push type constraints deeper for pattern match check -- addDictsDs: push type constraints deeper for pattern match check
do { (args, body) <- matchWrapper (FunRhs (idName global)) Nothing matches do { (args, body) <- matchWrapper
(FunRhs (noLoc $ idName global) Prefix)
Nothing matches
; let body' = mkOptTickBox tick body ; let body' = mkOptTickBox tick body
; fun_rhs <- dsHsWrapper co_fn $ ; fun_rhs <- dsHsWrapper co_fn $
mkLams args body' mkLams args body'
......
...@@ -149,13 +149,14 @@ dsUnliftedBind (AbsBindsSig { abs_tvs = [] ...@@ -149,13 +149,14 @@ dsUnliftedBind (AbsBindsSig { abs_tvs = []
; body' <- dsUnliftedBind (bind { fun_id = noLoc poly }) body ; body' <- dsUnliftedBind (bind { fun_id = noLoc poly }) body
; return (mkCoreLets ds_binds body') } ; return (mkCoreLets ds_binds body') }
dsUnliftedBind (FunBind { fun_id = L _ fun dsUnliftedBind (FunBind { fun_id = L l fun
, fun_matches = matches , fun_matches = matches
, fun_co_fn = co_fn , fun_co_fn = co_fn
, fun_tick = tick }) body , fun_tick = tick }) body
-- Can't be a bang pattern (that looks like a PatBind) -- Can't be a bang pattern (that looks like a PatBind)
-- so must be simply unboxed -- so must be simply unboxed
= do { (args, rhs) <- matchWrapper (FunRhs (idName fun)) Nothing matches = do { (args, rhs) <- matchWrapper (FunRhs (L l $ idName fun) Prefix)
Nothing matches
; MASSERT( null args ) -- Functions aren't lifted ; MASSERT( null args ) -- Functions aren't lifted
; MASSERT( isIdHsWrapper co_fn ) ; MASSERT( isIdHsWrapper co_fn )
; let rhs' = mkOptTickBox tick rhs ; let rhs' = mkOptTickBox tick rhs
...@@ -685,7 +686,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields ...@@ -685,7 +686,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
, pat_args = PrefixCon $ map nlVarPat arg_ids , pat_args = PrefixCon $ map nlVarPat arg_ids
, pat_arg_tys = in_inst_tys , pat_arg_tys = in_inst_tys
, pat_wrap = req_wrap } , pat_wrap = req_wrap }
; return (mkSimpleMatch [pat] wrapped_rhs) } ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }
-- Here is where we desugar the Template Haskell brackets and escapes -- Here is where we desugar the Template Haskell brackets and escapes
...@@ -909,7 +910,8 @@ dsDo stmts ...@@ -909,7 +910,8 @@ dsDo stmts
; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty ; let body' = noLoc $ HsDo DoExpr (noLoc stmts) body_ty
; let fun = L noSrcSpan $ HsLam $ ; let fun = L noSrcSpan $ HsLam $
MG { mg_alts = noLoc [mkSimpleMatch pats body'] MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats
body']
, mg_arg_tys = arg_tys , mg_arg_tys = arg_tys
, mg_res_ty = body_ty , mg_res_ty = body_ty
, mg_origin = Generated } , mg_origin = Generated }
...@@ -940,7 +942,9 @@ dsDo stmts ...@@ -940,7 +942,9 @@ dsDo stmts
rets = map noLoc rec_rets rets = map noLoc rec_rets
mfix_app = nlHsSyntaxApps mfix_op [mfix_arg] mfix_app = nlHsSyntaxApps mfix_op [mfix_arg]
mfix_arg = noLoc $ HsLam mfix_arg = noLoc $ HsLam
(MG { mg_alts = noLoc [mkSimpleMatch [mfix_pat] body] (MG { mg_alts = noLoc [mkSimpleMatch
LambdaExpr
[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 }) , mg_origin = Generated })
mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTupId rec_tup_pats
......
...@@ -1553,7 +1553,7 @@ repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds)))) ...@@ -1553,7 +1553,7 @@ repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds))))
do { xs <- repLPs ps; body <- repLE e; repLam xs body }) do { xs <- repLPs ps; body <- repLE e; repLam xs body })
; wrapGenSyms ss lam } ; wrapGenSyms ss lam }
repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch (LambdaExpr :: HsMatchContext Name) m) repLambda (L _ m) = notHandled "Guarded labmdas" (pprMatch m)
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
......
...@@ -142,7 +142,7 @@ cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl RdrName)) ...@@ -142,7 +142,7 @@ cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl RdrName))
cvtDec (TH.ValD pat body ds) cvtDec (TH.ValD pat body ds)
| TH.VarP s <- pat | TH.VarP s <- pat
= do { s' <- vNameL s = do { s' <- vNameL s
; cl' <- cvtClause (Clause [] body ds) ; cl' <- cvtClause (FunRhs s' Prefix) (Clause [] body ds)
; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] } ; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] }
| otherwise | otherwise
...@@ -161,7 +161,7 @@ cvtDec (TH.FunD nm cls) ...@@ -161,7 +161,7 @@ cvtDec (TH.FunD nm cls)
<+> text "has no equations") <+> text "has no equations")
| otherwise | otherwise
= do { nm' <- vNameL nm = do { nm' <- vNameL nm
; cls' <- mapM cvtClause cls ; cls' <- mapM (cvtClause (FunRhs nm' Prefix)) cls
; returnJustL $ Hs.ValD $ mkFunBind nm' cls' } ; returnJustL $ Hs.ValD $ mkFunBind nm' cls' }
cvtDec (TH.SigD nm typ) cvtDec (TH.SigD nm typ)
...@@ -354,7 +354,7 @@ cvtDec (TH.DefaultSigD nm typ) ...@@ -354,7 +354,7 @@ cvtDec (TH.DefaultSigD nm typ)
cvtDec (TH.PatSynD nm args dir pat) cvtDec (TH.PatSynD nm args dir pat)
= do { nm' <- cNameL nm = do { nm' <- cNameL nm
; args' <- cvtArgs args ; args' <- cvtArgs args
; dir' <- cvtDir dir ; dir' <- cvtDir nm' dir
; pat' <- cvtPat pat ; pat' <- cvtPat pat
; returnJustL $ Hs.ValD $ PatSynBind $ ; returnJustL $ Hs.ValD $ PatSynBind $
PSB nm' placeHolderType args' pat' dir' } PSB nm' placeHolderType args' pat' dir' }
...@@ -366,10 +366,10 @@ cvtDec (TH.PatSynD nm args dir pat) ...@@ -366,10 +366,10 @@ cvtDec (TH.PatSynD nm args dir pat)
; vars' <- mapM (vNameL . mkNameS . nameBase) sels ; vars' <- mapM (vNameL . mkNameS . nameBase) sels
; return $ Hs.RecordPatSyn $ zipWith RecordPatSynField sels' vars' } ; return $ Hs.RecordPatSyn $ zipWith RecordPatSynField sels' vars' }
cvtDir Unidir = return Unidirectional cvtDir _ Unidir = return Unidirectional
cvtDir ImplBidir = return ImplicitBidirectional cvtDir _ ImplBidir = return ImplicitBidirectional
cvtDir (ExplBidir cls) = cvtDir n (ExplBidir cls) =
do { ms <- mapM cvtClause cls do { ms <- mapM (cvtClause (FunRhs n Prefix)) cls
; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms } ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }
cvtDec (TH.PatSynSigD nm ty) cvtDec (TH.PatSynSigD nm ty)
...@@ -730,12 +730,13 @@ cvtLocalDecs doc ds ...@@ -730,12 +730,13 @@ cvtLocalDecs doc ds
; unless (null bads) (failWith (mkBadDecMsg doc bads)) ; unless (null bads) (failWith (mkBadDecMsg doc bads))
; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) } ; return (HsValBinds (ValBindsIn (listToBag binds) sigs)) }
cvtClause :: TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName)) cvtClause :: HsMatchContext RdrName
cvtClause (Clause ps body wheres) -> TH.Clause -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
cvtClause ctxt (Clause ps body wheres)
= do { ps' <- cvtPats ps = do { ps' <- cvtPats ps
; g' <- cvtGuard body ; g' <- cvtGuard body
; ds' <- cvtLocalDecs (text "a where clause") wheres ; ds' <- cvtLocalDecs (text "a where clause") wheres
; returnL $ Hs.Match NonFunBindMatch ps' Nothing ; returnL $ Hs.Match ctxt ps' Nothing
(GRHSs g' (noLoc ds')) } (GRHSs g' (noLoc ds')) }
...@@ -756,8 +757,9 @@ cvtl e = wrapL (cvt e) ...@@ -756,8 +757,9 @@ cvtl e = wrapL (cvt e)
cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y
; return $ HsApp x' 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 FromSource [mkSimpleMatch ps' e']) } ; return $ HsLam (mkMatchGroup FromSource
cvt (LamCaseE ms) = do { ms' <- mapM cvtMatch ms [mkSimpleMatch LambdaExpr ps' e'])}
cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch LambdaExpr) ms
; return $ HsLamCase (mkMatchGroup FromSource ms') ; return $ HsLamCase (mkMatchGroup FromSource ms')
} }
cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' } cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' }
...@@ -777,7 +779,7 @@ cvtl e = wrapL (cvt e) ...@@ -777,7 +779,7 @@ cvtl e = wrapL (cvt e)
; return $ HsMultiIf placeHolderType alts' } ; return $ HsMultiIf placeHolderType alts' }
cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds
; e' <- cvtl e; return $ HsLet (noLoc ds') e' } ; e' <- cvtl e; return $ HsLet (noLoc 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 CaseAlt) ms
; return $ HsCase e' (mkMatchGroup FromSource 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
...@@ -950,12 +952,13 @@ cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' n ...@@ -950,12 +952,13 @@ cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' n
where where
cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) } cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) }
cvtMatch :: TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName)) cvtMatch :: HsMatchContext RdrName
cvtMatch (TH.Match p body decs) -> TH.Match -> CvtM (Hs.LMatch RdrName (LHsExpr RdrName))
cvtMatch ctxt (TH.Match p body decs)
= do { p' <- cvtPat p = do { p' <- cvtPat p
; g' <- cvtGuard body ; g' <- cvtGuard body
; decs' <- cvtLocalDecs (text "a where clause") decs ; decs' <- cvtLocalDecs (text "a where clause") decs
; returnL $ Hs.Match NonFunBindMatch [p'] Nothing ; returnL $ Hs.Match ctxt [p'] Nothing
(GRHSs g' (noLoc decs')) } (GRHSs g' (noLoc decs')) }
cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)] cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)]
......
...@@ -22,7 +22,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr, ...@@ -22,7 +22,7 @@ import {-# SOURCE #-} HsExpr ( pprExpr, LHsExpr,
GRHSs, pprPatBind ) GRHSs, pprPatBind )
import {-# SOURCE #-} HsPat ( LPat ) import {-# SOURCE #-} HsPat ( LPat )
import PlaceHolder ( PostTc,PostRn,DataId ) import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId )
import HsTypes import HsTypes
import PprCore () import PprCore ()
import CoreSyn import CoreSyn
...@@ -405,12 +405,14 @@ Specifically, ...@@ -405,12 +405,14 @@ Specifically,
it's just an error thunk it's just an error thunk
-} -}
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsLocalBindsLR idL idR) where instance (OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsLocalBindsLR idL idR) where
ppr (HsValBinds bs) = ppr bs ppr (HsValBinds bs) = ppr bs
ppr (HsIPBinds bs) = ppr bs ppr (HsIPBinds bs) = ppr bs
ppr EmptyLocalBinds = empty ppr EmptyLocalBinds = empty
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR idL idR) where instance (OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsValBindsLR idL idR) where
ppr (ValBindsIn binds sigs) ppr (ValBindsIn binds sigs)
= pprDeclList (pprLHsBindsForUser binds sigs) = pprDeclList (pprLHsBindsForUser binds sigs)
...@@ -425,12 +427,14 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR id ...@@ -425,12 +427,14 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsValBindsLR id
pp_rec Recursive = text "rec" pp_rec Recursive = text "rec"
pp_rec NonRecursive = text "nonrec" pp_rec NonRecursive = text "nonrec"
pprLHsBinds :: (OutputableBndr idL, OutputableBndr idR) => LHsBindsLR idL idR -> SDoc pprLHsBinds :: (OutputableBndrId idL, OutputableBndrId idR)
=> LHsBindsLR idL idR -> SDoc
pprLHsBinds binds pprLHsBinds binds
| isEmptyLHsBinds binds = empty | isEmptyLHsBinds binds = empty
| otherwise = pprDeclList (map ppr (bagToList binds)) | otherwise = pprDeclList (map ppr (bagToList binds))
pprLHsBindsForUser :: (OutputableBndr idL, OutputableBndr idR, OutputableBndr id2) pprLHsBindsForUser :: (OutputableBndrId idL, OutputableBndrId idR,
OutputableBndrId id2)
=> LHsBindsLR idL idR -> [LSig id2] -> [SDoc] => LHsBindsLR idL idR -> [LSig id2] -> [SDoc]
-- pprLHsBindsForUser is different to pprLHsBinds because -- pprLHsBindsForUser is different to pprLHsBinds because
-- a) No braces: 'let' and 'where' include a list of HsBindGroups -- a) No braces: 'let' and 'where' include a list of HsBindGroups
...@@ -491,7 +495,6 @@ plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2) ...@@ -491,7 +495,6 @@ plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
plusHsValBinds _ _ plusHsValBinds _ _
= panic "HsBinds.plusHsValBinds" = panic "HsBinds.plusHsValBinds"
{- {-
What AbsBinds means What AbsBinds means
~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~
...@@ -518,10 +521,12 @@ So the desugarer tries to do a better job: ...@@ -518,10 +521,12 @@ So the desugarer tries to do a better job:
in (fm,gm) in (fm,gm)
-} -}
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (HsBindLR idL idR) where instance (OutputableBndrId idL, OutputableBndrId idR)
=> Outputable (HsBindLR idL idR) where
ppr mbind = ppr_monobind mbind ppr mbind = ppr_monobind mbind
ppr_monobind :: (OutputableBndr idL, OutputableBndr idR) => HsBindLR idL idR -> SDoc ppr_monobind :: (OutputableBndrId idL, OutputableBndrId idR)
=> HsBindLR idL idR -> SDoc
ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss }) ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })
= pprPatBind pat grhss = pprPatBind pat grhss
...@@ -534,7 +539,7 @@ ppr_monobind (FunBind { fun_id = fun, ...@@ -534,7 +539,7 @@ ppr_monobind (FunBind { fun_id = fun,
= pprTicks empty (if null ticks then empty = pprTicks empty (if null ticks then empty
else text "-- ticks = " <> ppr ticks) else text "-- ticks = " <> ppr ticks)
$$ ifPprDebug (pprBndr LetBind (unLoc fun)) $$ ifPprDebug (pprBndr LetBind (unLoc fun))
$$ pprFunBind (unLoc fun) matches $$ pprFunBind matches
$$ ifPprDebug (ppr wrap) $$ ifPprDebug (ppr wrap)
ppr_monobind (PatSynBind psb) = ppr psb ppr_monobind (PatSynBind psb) = ppr psb
ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
...@@ -574,8 +579,10 @@ instance (OutputableBndr id) => Outputable (ABExport id) where ...@@ -574,8 +579,10 @@ instance (OutputableBndr id) => Outputable (ABExport id) where
, nest 2 (pprTcSpecPrags prags) , nest 2 (pprTcSpecPrags prags)
, nest 2 (text "wrap:" <+> ppr wrap)] , nest 2 (text "wrap:" <+> ppr wrap)]
instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL idR) where instance (OutputableBndr idL, OutputableBndrId idR)
ppr (PSB{ psb_id = L _ psyn, psb_args = details, psb_def = pat, psb_dir = dir }) => Outputable (PatSynBind idL idR) where
ppr (PSB{ psb_id = (L _ psyn), psb_args = details, psb_def = pat,
psb_dir = dir })
= ppr_lhs <+> ppr_rhs = ppr_lhs <+> ppr_rhs
where where
ppr_lhs = text "pattern" <+> ppr_details ppr_lhs = text "pattern" <+> ppr_details
...@@ -592,7 +599,7 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL ...@@ -592,7 +599,7 @@ instance (OutputableBndr idL, OutputableBndr idR) => Outputable (PatSynBind idL
Unidirectional -> ppr_simple (text "<-") Unidirectional -> ppr_simple (text "<-")
ImplicitBidirectional -> ppr_simple equals ImplicitBidirectional -> ppr_simple equals
ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$ ExplicitBidirectional mg -> ppr_simple (text "<-") <+> ptext (sLit "where") $$
(nest 2 $ pprFunBind psyn mg) (nest 2 $ pprFunBind mg)
pprTicks :: SDoc -> SDoc -> SDoc pprTicks :: SDoc -> SDoc -> SDoc
-- Print stuff about ticks only when -dppr-debug is on, to avoid -- Print stuff about ticks only when -dppr-debug is on, to avoid
...@@ -642,11 +649,11 @@ data IPBind id ...@@ -642,11 +649,11 @@ data IPBind id
= IPBind (Either (Located HsIPName) id) (LHsExpr id) = IPBind (Either (Located HsIPName) id) (LHsExpr id)
deriving instance (DataId name) => Data (IPBind name) deriving instance (DataId name) => Data (IPBind name)
instance (OutputableBndr id) => Outputable (HsIPBinds id) where instance (OutputableBndrId id) => Outputable (HsIPBinds id) where
ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs)
$$ ifPprDebug (ppr ds) $$ ifPprDebug (ppr ds)
instance (OutputableBndr id) => Outputable (IPBind id) where instance (OutputableBndrId id) => Outputable (IPBind id) where
ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs)
where name = case lr of where name = case lr of
Left (L _ ip) -> pprBndr LetBind ip Left (L _ ip) -> pprBndr LetBind ip
...@@ -878,10 +885,10 @@ signatures. Since some of the signatures contain a list of names, testing for ...@@ -878,10 +885,10 @@ signatures. Since some of the signatures contain a list of names, testing for
equality is not enough -- we have to check if they overlap. equality is not enough -- we have to check if they overlap.
-} -}
instance (OutputableBndr name) => Outputable (Sig name) where instance (OutputableBndrId name) => Outputable (Sig name) where
ppr sig = ppr_sig sig ppr sig = ppr_sig sig
ppr_sig :: OutputableBndr name => Sig name -> SDoc ppr_sig :: (OutputableBndrId name) => Sig name -> SDoc
ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty) ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty)
ppr_sig (ClassOpSig is_deflt vars ty) ppr_sig (ClassOpSig is_deflt vars ty)
| is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty)
......
...@@ -96,7 +96,7 @@ import Name ...@@ -96,7 +96,7 @@ import Name
import BasicTypes import BasicTypes
import Coercion import Coercion
import ForeignCall import ForeignCall
import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId ) import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId, OutputableBndrId )
import NameSet import NameSet
-- others: -- others:
...@@ -246,7 +246,7 @@ appendGroups ...@@ -246,7 +246,7 @@ appendGroups
hs_vects = vects1 ++ vects2, hs_vects = vects1 ++ vects2,
hs_docs = docs1 ++ docs2 } hs_docs = docs1 ++ docs2 }
instance OutputableBndr name => Outputable (HsDecl name) where instance (OutputableBndrId name) => Outputable (HsDecl name) where
ppr (TyClD dcl) = ppr dcl ppr (TyClD dcl) = ppr dcl
ppr (ValD binds) = ppr binds ppr (ValD binds) = ppr binds
ppr (DefD def) = ppr def ppr (DefD def) = ppr def
...@@ -262,7 +262,7 @@ instance OutputableBndr name => Outputable (HsDecl name) where ...@@ -262,7 +262,7 @@ instance OutputableBndr name => Outputable (HsDecl name) where
ppr (DocD doc) = ppr doc ppr (DocD doc) = ppr doc
ppr (RoleAnnotD ra) = ppr ra ppr (RoleAnnotD ra) = ppr ra
instance OutputableBndr name => Outputable (HsGroup name) where instance (OutputableBndrId name) => Outputable (HsGroup name) where
ppr (HsGroup { hs_valds = val_decls, ppr (HsGroup { hs_valds = val_decls,
hs_tyclds = tycl_decls, hs_tyclds = tycl_decls,
hs_derivds = deriv_decls, hs_derivds = deriv_decls,
...@@ -307,7 +307,7 @@ data SpliceDecl id ...@@ -307,7 +307,7 @@ data SpliceDecl id
SpliceExplicitFlag SpliceExplicitFlag
deriving instance (DataId id) => Data (SpliceDecl id) deriving instance (DataId id) => Data (SpliceDecl id)
instance OutputableBndr name => Outputable (SpliceDecl name) where instance (OutputableBndrId name) => Outputable (SpliceDecl name) where
ppr (SpliceDecl (L _ e) _) = pprSplice e ppr (SpliceDecl (L _ e) _) = pprSplice e
{- {-
...@@ -623,8 +623,7 @@ hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars ...@@ -623,8 +623,7 @@ hsDeclHasCusk (ClassDecl { tcdTyVars = tyvars }) = hsTvbAllKinded tyvars
-- Pretty-printing TyClDecl -- Pretty-printing TyClDecl
-- ~~~~~~~~~~~~~~~~~~~~~~~~ -- ~~~~~~~~~~~~~~~~~~~~~~~~
instance OutputableBndr name instance (OutputableBndrId name) => Outputable (TyClDecl name) where
=> Outputable (TyClDecl name) where
ppr (FamDecl { tcdFam = decl }) = ppr decl ppr (FamDecl { tcdFam = decl }) = ppr decl
ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdRhs = rhs }) ppr (SynDecl { tcdLName = ltycon, tcdTyVars = tyvars, tcdRhs = rhs })
...@@ -652,7 +651,7 @@ instance OutputableBndr name ...@@ -652,7 +651,7 @@ instance OutputableBndr name
<+> pp_vanilla_decl_head lclas tyvars (unLoc context) <+> pp_vanilla_decl_head lclas tyvars (unLoc context)
<+> pprFundeps (map unLoc fds) <+> pprFundeps (map unLoc fds)
instance OutputableBndr name => Outputable (TyClGroup name) where instance (OutputableBndrId name) => Outputable (TyClGroup name) where
ppr (TyClGroup { group_tyclds = tyclds ppr (TyClGroup { group_tyclds = tyclds
, group_roles = roles , group_roles = roles
, group_instds = instds , group_instds = instds
...@@ -662,7 +661,7 @@ instance OutputableBndr name => Outputable (TyClGroup name) where ...@@ -662,7 +661,7 @@ instance OutputableBndr name => Outputable (TyClGroup name) where
ppr roles $$ ppr roles $$
ppr instds ppr instds
pp_vanilla_decl_head :: OutputableBndr name pp_vanilla_decl_head :: (OutputableBndrId name)
=> Located name => Located name
-> LHsQTyVars name -> LHsQTyVars name
-> HsContext name -> HsContext name
...@@ -928,10 +927,11 @@ resultVariableName :: FamilyResultSig a -> Maybe a ...@@ -928,10 +927,11 @@ resultVariableName :: FamilyResultSig a -> Maybe a
resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig resultVariableName (TyVarSig sig) = Just $ hsLTyVarName sig
resultVariableName _ = Nothing resultVariableName _ = Nothing
instance (OutputableBndr name) => Outputable (FamilyDecl name) where instance (OutputableBndrId name) => Outputable (FamilyDecl name) where
ppr = pprFamilyDecl TopLevel ppr = pprFamilyDecl TopLevel
pprFamilyDecl :: OutputableBndr name => TopLevelFlag -> FamilyDecl name -> SDoc pprFamilyDecl :: (OutputableBndrId name)
=> TopLevelFlag -> FamilyDecl name -> SDoc
pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
, fdTyVars = tyvars , fdTyVars = tyvars
, fdResultSig = L _ result , fdResultSig = L _ result
...@@ -1126,7 +1126,7 @@ hsConDeclArgTys (PrefixCon tys) = tys ...@@ -1126,7 +1126,7 @@ hsConDeclArgTys (PrefixCon tys) = tys
hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2]
hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds)
pp_data_defn :: OutputableBndr name pp_data_defn :: (OutputableBndrId name)
=> (HsContext name -> SDoc) -- Printing the header => (HsContext name -> SDoc) -- Printing the header
-> HsDataDefn name -> HsDataDefn name
-> SDoc -> SDoc
...@@ -1148,23 +1148,23 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context ...@@ -1148,23 +1148,23 @@ pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
Just (L _ ds) -> hsep [ text "deriving" Just (L _ ds) -> hsep [ text "deriving"
, parens (interpp'SP ds)] , parens (interpp'SP ds)]
instance OutputableBndr name => Outputable (HsDataDefn name) where instance (OutputableBndrId name) => Outputable (HsDataDefn name) where
ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d ppr d = pp_data_defn (\_ -> text "Naked HsDataDefn") d