Commit c61759d5 authored by msosn's avatar msosn Committed by Ben Gamari

Fix inconsistent pretty-printing of type families

After the changes, the three functions used to print type families
were identical, so they are refactored into one.

Original RHSs of data instance declarations are recreated and
printed in user error messages.

RHSs containing representation TyCons are printed in the
Coercion Axioms section in a typechecker dump.

Add vbar to the list of SDocs exported by Outputable.
Replace all text "|" docs with it.

Fixes #10839

Reviewers: goldfire, jstolarek, austin, bgamari

Reviewed By: jstolarek

Subscribers: jstolarek, thomie

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

GHC Trac Issues: #10839
parent 07eb258d
...@@ -17,6 +17,8 @@ dataConSourceArity :: DataCon -> Arity ...@@ -17,6 +17,8 @@ dataConSourceArity :: DataCon -> Arity
dataConFieldLabels :: DataCon -> [FieldLabel] dataConFieldLabels :: DataCon -> [FieldLabel]
dataConInstOrigArgTys :: DataCon -> [Type] -> [Type] dataConInstOrigArgTys :: DataCon -> [Type] -> [Type]
dataConStupidTheta :: DataCon -> ThetaType dataConStupidTheta :: DataCon -> ThetaType
dataConFullSig :: DataCon
-> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type], Type)
instance Eq DataCon instance Eq DataCon
instance Ord DataCon instance Ord DataCon
......
...@@ -1350,13 +1350,13 @@ lintCoercion (InstCo co arg_ty) ...@@ -1350,13 +1350,13 @@ lintCoercion (InstCo co arg_ty)
lintCoercion co@(AxiomInstCo con ind cos) lintCoercion co@(AxiomInstCo con ind cos)
= do { unless (0 <= ind && ind < numBranches (coAxiomBranches con)) = do { unless (0 <= ind && ind < numBranches (coAxiomBranches con))
(bad_ax (ptext (sLit "index out of range"))) (bad_ax (text "index out of range"))
-- See Note [Kind instantiation in coercions] -- See Note [Kind instantiation in coercions]
; let CoAxBranch { cab_tvs = ktvs ; let CoAxBranch { cab_tvs = ktvs
, cab_roles = roles , cab_roles = roles
, cab_lhs = lhs , cab_lhs = lhs
, cab_rhs = rhs } = coAxiomNthBranch con ind , cab_rhs = rhs } = coAxiomNthBranch con ind
; unless (equalLength ktvs cos) (bad_ax (ptext (sLit "lengths"))) ; unless (equalLength ktvs cos) (bad_ax (text "lengths"))
; in_scope <- getInScope ; in_scope <- getInScope
; let empty_subst = mkTvSubst in_scope emptyTvSubstEnv ; let empty_subst = mkTvSubst in_scope emptyTvSubstEnv
; (subst_l, subst_r) <- foldlM check_ki ; (subst_l, subst_r) <- foldlM check_ki
...@@ -1365,11 +1365,12 @@ lintCoercion co@(AxiomInstCo con ind cos) ...@@ -1365,11 +1365,12 @@ lintCoercion co@(AxiomInstCo con ind cos)
; let lhs' = Type.substTys subst_l lhs ; let lhs' = Type.substTys subst_l lhs
rhs' = Type.substTy subst_r rhs rhs' = Type.substTy subst_r rhs
; case checkAxInstCo co of ; case checkAxInstCo co of
Just bad_branch -> bad_ax $ ptext (sLit "inconsistent with") <+> (pprCoAxBranch (coAxiomTyCon con) bad_branch) Just bad_branch -> bad_ax $ text "inconsistent with" <+>
pprCoAxBranch con bad_branch
Nothing -> return () Nothing -> return ()
; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs', coAxiomRole con) } ; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs', coAxiomRole con) }
where where
bad_ax what = addErrL (hang (ptext (sLit "Bad axiom application") <+> parens what) bad_ax what = addErrL (hang (text "Bad axiom application" <+> parens what)
2 (ppr co)) 2 (ppr co))
check_ki (subst_l, subst_r) (ktv, role, co) check_ki (subst_l, subst_r) (ktv, role, co)
...@@ -1379,7 +1380,8 @@ lintCoercion co@(AxiomInstCo con ind cos) ...@@ -1379,7 +1380,8 @@ lintCoercion co@(AxiomInstCo con ind cos)
-- Using subst_l is ok, because subst_l and subst_r -- Using subst_l is ok, because subst_l and subst_r
-- must agree on kind equalities -- must agree on kind equalities
; unless (k `isSubKind` ktv_kind) ; unless (k `isSubKind` ktv_kind)
(bad_ax (ptext (sLit "check_ki2") <+> vcat [ ppr co, ppr k, ppr ktv, ppr ktv_kind ] )) (bad_ax (text "check_ki2" <+>
vcat [ ppr co, ppr k, ppr ktv, ppr ktv_kind ] ))
; return (Type.extendTvSubst subst_l ktv t1, ; return (Type.extendTvSubst subst_l ktv t1,
Type.extendTvSubst subst_r ktv t2) } Type.extendTvSubst subst_r ktv t2) }
......
...@@ -463,7 +463,7 @@ mkErrorAppDs err_id ty msg = do ...@@ -463,7 +463,7 @@ mkErrorAppDs err_id ty msg = do
src_loc <- getSrcSpanDs src_loc <- getSrcSpanDs
dflags <- getDynFlags dflags <- getDynFlags
let let
full_msg = showSDoc dflags (hcat [ppr src_loc, text "|", msg]) full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])
core_msg = Lit (mkMachString full_msg) core_msg = Lit (mkMachString full_msg)
-- mkMachString returns a result of type String# -- mkMachString returns a result of type String#
return (mkApps (Var err_id) [Type ty, core_msg]) return (mkApps (Var err_id) [Type ty, core_msg])
......
...@@ -906,7 +906,7 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon ...@@ -906,7 +906,7 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
TyVarSig tv_bndr -> text "=" <+> ppr tv_bndr TyVarSig tv_bndr -> text "=" <+> ppr tv_bndr
pp_inj = case mb_inj of pp_inj = case mb_inj of
Just (L _ (InjectivityAnn lhs rhs)) -> Just (L _ (InjectivityAnn lhs rhs)) ->
hsep [ text "|", ppr lhs, text "->", hsep (map ppr rhs) ] hsep [ vbar, ppr lhs, text "->", hsep (map ppr rhs) ]
Nothing -> empty Nothing -> empty
(pp_where, pp_eqns) = case info of (pp_where, pp_eqns) = case info of
ClosedTypeFamily mb_eqns -> ClosedTypeFamily mb_eqns ->
......
...@@ -713,7 +713,7 @@ ppr_expr (HsIf _ e1 e2 e3) ...@@ -713,7 +713,7 @@ ppr_expr (HsIf _ e1 e2 e3)
ppr_expr (HsMultiIf _ alts) ppr_expr (HsMultiIf _ alts)
= sep $ ptext (sLit "if") : map ppr_alt alts = sep $ ptext (sLit "if") : map ppr_alt alts
where ppr_alt (L _ (GRHS guards expr)) = where ppr_alt (L _ (GRHS guards expr)) =
sep [ char '|' <+> interpp'SP guards sep [ vbar <+> interpp'SP guards
, ptext (sLit "->") <+> pprDeeper (ppr expr) ] , ptext (sLit "->") <+> pprDeeper (ppr expr) ]
-- special case: let ... in let ... -- special case: let ... in let ...
...@@ -1283,7 +1283,7 @@ pprGRHS ctxt (GRHS [] body) ...@@ -1283,7 +1283,7 @@ pprGRHS ctxt (GRHS [] body)
= pp_rhs ctxt body = pp_rhs ctxt body
pprGRHS ctxt (GRHS guards body) pprGRHS ctxt (GRHS guards body)
= sep [char '|' <+> interpp'SP guards, pp_rhs ctxt body] = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body]
pp_rhs :: Outputable body => HsMatchContext idL -> body -> SDoc pp_rhs :: Outputable body => HsMatchContext idL -> body -> SDoc
pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
...@@ -1707,7 +1707,7 @@ pprComp :: (OutputableBndr id, Outputable body) ...@@ -1707,7 +1707,7 @@ pprComp :: (OutputableBndr id, Outputable body)
pprComp quals -- Prints: body | qual1, ..., qualn pprComp quals -- Prints: body | qual1, ..., qualn
| not (null quals) | not (null quals)
, L _ (LastStmt body _ _) <- last quals , L _ (LastStmt body _ _) <- last quals
= hang (ppr body <+> char '|') 2 (pprQuals (dropTail 1 quals)) = hang (ppr body <+> vbar) 2 (pprQuals (dropTail 1 quals))
| otherwise | otherwise
= pprPanic "pprComp" (pprQuals quals) = pprPanic "pprComp" (pprQuals quals)
...@@ -1842,7 +1842,7 @@ pprSplice (HsQuasiQuote n q _ s) = ppr_quasi n q s ...@@ -1842,7 +1842,7 @@ pprSplice (HsQuasiQuote n q _ s) = ppr_quasi n q s
ppr_quasi :: OutputableBndr id => id -> id -> FastString -> SDoc ppr_quasi :: OutputableBndr id => id -> id -> FastString -> SDoc
ppr_quasi n quoter quote = ifPprDebug (brackets (ppr n)) <> ppr_quasi n quoter quote = ifPprDebug (brackets (ppr n)) <>
char '[' <> ppr quoter <> ptext (sLit "|") <> char '[' <> ppr quoter <> vbar <>
ppr quote <> ptext (sLit "|]") ppr quote <> ptext (sLit "|]")
ppr_splice :: OutputableBndr id => SDoc -> id -> LHsExpr id -> SDoc ppr_splice :: OutputableBndr id => SDoc -> id -> LHsExpr id -> SDoc
...@@ -1888,7 +1888,7 @@ pprHsBracket (VarBr False n) = ptext (sLit "''") <> ppr n ...@@ -1888,7 +1888,7 @@ pprHsBracket (VarBr False n) = ptext (sLit "''") <> ppr n
pprHsBracket (TExpBr e) = thTyBrackets (ppr e) pprHsBracket (TExpBr e) = thTyBrackets (ppr e)
thBrackets :: SDoc -> SDoc -> SDoc thBrackets :: SDoc -> SDoc -> SDoc
thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+> thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>
pp_body <+> ptext (sLit "|]") pp_body <+> ptext (sLit "|]")
thTyBrackets :: SDoc -> SDoc thTyBrackets :: SDoc -> SDoc
......
...@@ -643,7 +643,7 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype, ...@@ -643,7 +643,7 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
-- See discussion on Trac #8672. -- See discussion on Trac #8672.
add_bars [] = Outputable.empty add_bars [] = Outputable.empty
add_bars (c:cs) = sep ((equals <+> c) : map (char '|' <+>) cs) add_bars (c:cs) = sep ((equals <+> c) : map (vbar <+>) cs)
ok_con dc = showSub ss dc || any (showSub ss) (ifConFields dc) ok_con dc = showSub ss dc || any (showSub ss) (ifConFields dc)
...@@ -741,7 +741,7 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars ...@@ -741,7 +741,7 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
pp_inj_cond res inj = case filterByList inj tyvars of pp_inj_cond res inj = case filterByList inj tyvars of
[] -> empty [] -> empty
tvs -> hsep [text "|", ppr res, text "->", interppSP (map fst tvs)] tvs -> hsep [vbar, ppr res, text "->", interppSP (map fst tvs)]
pp_rhs IfaceDataFamilyTyCon pp_rhs IfaceDataFamilyTyCon
= ppShowIface ss (ptext (sLit "data")) = ppShowIface ss (ptext (sLit "data"))
......
...@@ -910,9 +910,10 @@ When printing export lists, we print like this: ...@@ -910,9 +910,10 @@ When printing export lists, we print like this:
pprExport :: IfaceExport -> SDoc pprExport :: IfaceExport -> SDoc
pprExport (Avail _ n) = ppr n pprExport (Avail _ n) = ppr n
pprExport (AvailTC _ [] []) = Outputable.empty pprExport (AvailTC _ [] []) = Outputable.empty
pprExport (AvailTC n ns0 fs) = case ns0 of pprExport (AvailTC n ns0 fs)
(n':ns) | n==n' -> ppr n <> pp_export ns fs = case ns0 of
_ -> ppr n <> char '|' <> pp_export ns0 fs (n':ns) | n==n' -> ppr n <> pp_export ns fs
_ -> ppr n <> vbar <> pp_export ns0 fs
where where
pp_export [] [] = Outputable.empty pp_export [] [] = Outputable.empty
pp_export names fs = braces (hsep (map ppr names ++ map (ppr . flLabel) fs)) pp_export names fs = braces (hsep (map ppr names ++ map (ppr . flLabel) fs))
......
...@@ -135,8 +135,9 @@ instance Uniquable RealReg where ...@@ -135,8 +135,9 @@ instance Uniquable RealReg where
instance Outputable RealReg where instance Outputable RealReg where
ppr reg ppr reg
= case reg of = case reg of
RealRegSingle i -> text "%r" <> int i RealRegSingle i -> text "%r" <> int i
RealRegPair r1 r2 -> text "%r(" <> int r1 <> text "|" <> int r2 <> text ")" RealRegPair r1 r2 -> text "%r(" <> int r1
<> vbar <> int r2 <> text ")"
regNosOfRealReg :: RealReg -> [RegNo] regNosOfRealReg :: RealReg -> [RegNo]
regNosOfRealReg rr regNosOfRealReg rr
......
...@@ -161,7 +161,7 @@ pprReg reg ...@@ -161,7 +161,7 @@ pprReg reg
RealRegPair r1 r2 RealRegPair r1 r2
-> text "(" <> pprReg_ofRegNo r1 -> text "(" <> pprReg_ofRegNo r1
<> text "|" <> pprReg_ofRegNo r2 <> vbar <> pprReg_ofRegNo r2
<> text ")" <> text ")"
......
...@@ -402,10 +402,10 @@ checkForInjectivityConflicts instEnvs famInst ...@@ -402,10 +402,10 @@ checkForInjectivityConflicts instEnvs famInst
| isTypeFamilyTyCon tycon | isTypeFamilyTyCon tycon
-- type family is injective in at least one argument -- type family is injective in at least one argument
, Injective inj <- familyTyConInjectivityInfo tycon = do , Injective inj <- familyTyConInjectivityInfo tycon = do
{ let axiom = coAxiomSingleBranch (fi_axiom famInst) { let axiom = coAxiomSingleBranch fi_ax
conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst
-- see Note [Verifying injectivity annotation] in FamInstEnv -- see Note [Verifying injectivity annotation] in FamInstEnv
errs = makeInjectivityErrors tycon axiom inj conflicts errs = makeInjectivityErrors fi_ax axiom inj conflicts
; mapM_ (\(err, span) -> setSrcSpan span $ addErr err) errs ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err) errs
; return (null errs) ; return (null errs)
} }
...@@ -414,15 +414,16 @@ checkForInjectivityConflicts instEnvs famInst ...@@ -414,15 +414,16 @@ checkForInjectivityConflicts instEnvs famInst
-- type family we report no conflicts -- type family we report no conflicts
| otherwise = return True | otherwise = return True
where tycon = famInstTyCon famInst where tycon = famInstTyCon famInst
fi_ax = fi_axiom famInst
-- | Build a list of injectivity errors together with their source locations. -- | Build a list of injectivity errors together with their source locations.
makeInjectivityErrors makeInjectivityErrors
:: TyCon -- ^ Type family tycon for which we generate errors :: CoAxiom br -- ^ Type family for which we generate errors
-> CoAxBranch -- ^ Currently checked equation (represented by axiom) -> CoAxBranch -- ^ Currently checked equation (represented by axiom)
-> [Bool] -- ^ Injectivity annotation -> [Bool] -- ^ Injectivity annotation
-> [CoAxBranch] -- ^ List of injectivity conflicts -> [CoAxBranch] -- ^ List of injectivity conflicts
-> [(SDoc, SrcSpan)] -> [(SDoc, SrcSpan)]
makeInjectivityErrors tycon axiom inj conflicts makeInjectivityErrors fi_ax axiom inj conflicts
= ASSERT2( any id inj, text "No injective type variables" ) = ASSERT2( any id inj, text "No injective type variables" )
let lhs = coAxBranchLHS axiom let lhs = coAxBranchLHS axiom
rhs = coAxBranchRHS axiom rhs = coAxBranchRHS axiom
...@@ -435,7 +436,8 @@ makeInjectivityErrors tycon axiom inj conflicts ...@@ -435,7 +436,8 @@ makeInjectivityErrors tycon axiom inj conflicts
wrong_bare_rhs = not $ null bare_variables wrong_bare_rhs = not $ null bare_variables
err_builder herald eqns err_builder herald eqns
= ( herald $$ vcat (map (pprCoAxBranch tycon) eqns) = ( hang herald
2 (vcat (map (pprCoAxBranch fi_ax) eqns))
, coAxBranchSpan (head eqns) ) , coAxBranchSpan (head eqns) )
errorIf p f = if p then [f err_builder axiom] else [] errorIf p f = if p then [f err_builder axiom] else []
in errorIf are_conflicts (conflictInjInstErr conflicts ) in errorIf are_conflicts (conflictInjInstErr conflicts )
......
...@@ -1288,7 +1288,8 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys ...@@ -1288,7 +1288,8 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
error_msg dflags = L inst_loc (HsLit (HsStringPrim "" error_msg dflags = L inst_loc (HsLit (HsStringPrim ""
(unsafeMkByteString (error_string dflags)))) (unsafeMkByteString (error_string dflags))))
meth_tau = funResultTy (applyTys (idType sel_id) inst_tys) meth_tau = funResultTy (applyTys (idType sel_id) inst_tys)
error_string dflags = showSDoc dflags (hcat [ppr inst_loc, text "|", ppr sel_id ]) error_string dflags = showSDoc dflags
(hcat [ppr inst_loc, vbar, ppr sel_id ])
lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
tc_default sel_id (DefMeth dm_name) -- A polymorphic default method tc_default sel_id (DefMeth dm_name) -- A polymorphic default method
......
...@@ -35,6 +35,7 @@ import Class ...@@ -35,6 +35,7 @@ import Class
import TyCon import TyCon
-- others: -- others:
import Coercion ( pprCoAxBranch )
import HsSyn -- HsType import HsSyn -- HsType
import TcRnMonad -- TcType, amongst others import TcRnMonad -- TcType, amongst others
import FunDeps import FunDeps
...@@ -1238,7 +1239,7 @@ wrongATArgErr ty instTy = ...@@ -1238,7 +1239,7 @@ wrongATArgErr ty instTy =
-} -}
checkValidCoAxiom :: CoAxiom Branched -> TcM () checkValidCoAxiom :: CoAxiom Branched -> TcM ()
checkValidCoAxiom (CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches }) checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches })
= do { mapM_ (checkValidCoAxBranch Nothing fam_tc) branch_list = do { mapM_ (checkValidCoAxBranch Nothing fam_tc) branch_list
; foldlM_ check_branch_compat [] branch_list } ; foldlM_ check_branch_compat [] branch_list }
where where
...@@ -1254,7 +1255,7 @@ checkValidCoAxiom (CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches }) ...@@ -1254,7 +1255,7 @@ checkValidCoAxiom (CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches })
check_branch_compat prev_branches cur_branch check_branch_compat prev_branches cur_branch
| cur_branch `isDominatedBy` prev_branches | cur_branch `isDominatedBy` prev_branches
= do { addWarnAt (coAxBranchSpan cur_branch) $ = do { addWarnAt (coAxBranchSpan cur_branch) $
inaccessibleCoAxBranch fam_tc cur_branch inaccessibleCoAxBranch ax cur_branch
; return prev_branches } ; return prev_branches }
| otherwise | otherwise
= do { check_injectivity prev_branches cur_branch = do { check_injectivity prev_branches cur_branch
...@@ -1270,7 +1271,7 @@ checkValidCoAxiom (CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches }) ...@@ -1270,7 +1271,7 @@ checkValidCoAxiom (CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches })
fst $ foldl (gather_conflicts inj prev_branches cur_branch) fst $ foldl (gather_conflicts inj prev_branches cur_branch)
([], 0) prev_branches ([], 0) prev_branches
; mapM_ (\(err, span) -> setSrcSpan span $ addErr err) ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err)
(makeInjectivityErrors fam_tc cur_branch inj conflicts) } (makeInjectivityErrors ax cur_branch inj conflicts) }
| otherwise | otherwise
= return () = return ()
...@@ -1388,13 +1389,10 @@ isTyFamFree = null . tcTyFamInsts ...@@ -1388,13 +1389,10 @@ isTyFamFree = null . tcTyFamInsts
-- Error messages -- Error messages
inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc inaccessibleCoAxBranch :: CoAxiom br -> CoAxBranch -> SDoc
inaccessibleCoAxBranch fam_tc (CoAxBranch { cab_tvs = tvs inaccessibleCoAxBranch fi_ax cur_branch
, cab_lhs = lhs
, cab_rhs = rhs })
= ptext (sLit "Type family instance equation is overlapped:") $$ = ptext (sLit "Type family instance equation is overlapped:") $$
hang (pprUserForAll tvs) nest 2 (pprCoAxBranch fi_ax cur_branch)
2 (hang (pprTypeApp fam_tc lhs) 2 (equals <+> (ppr rhs)))
tyFamInstIllegalErr :: Type -> SDoc tyFamInstIllegalErr :: Type -> SDoc
tyFamInstIllegalErr ty tyFamInstIllegalErr ty
......
...@@ -290,7 +290,7 @@ instance Outputable DefMeth where ...@@ -290,7 +290,7 @@ instance Outputable DefMeth where
pprFundeps :: Outputable a => [FunDep a] -> SDoc pprFundeps :: Outputable a => [FunDep a] -> SDoc
pprFundeps [] = empty pprFundeps [] = empty
pprFundeps fds = hsep (ptext (sLit "|") : punctuate comma (map pprFunDep fds)) pprFundeps fds = hsep (vbar : punctuate comma (map pprFunDep fds))
pprFunDep :: Outputable a => FunDep a -> SDoc pprFunDep :: Outputable a => FunDep a -> SDoc
pprFunDep (us, vs) = hsep [interppSP us, ptext (sLit "->"), interppSP vs] pprFunDep (us, vs) = hsep [interppSP us, ptext (sLit "->"), interppSP vs]
......
...@@ -754,29 +754,39 @@ ppr_forall_co p ty ...@@ -754,29 +754,39 @@ ppr_forall_co p ty
split1 tvs ty = (reverse tvs, ty) split1 tvs ty = (reverse tvs, ty)
pprCoAxiom :: CoAxiom br -> SDoc pprCoAxiom :: CoAxiom br -> SDoc
pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches }) pprCoAxiom ax@(CoAxiom { co_ax_branches = branches })
= hang (ptext (sLit "axiom") <+> ppr ax <+> dcolon) = hang (text "axiom" <+> ppr ax <+> dcolon)
2 (vcat (map (pprCoAxBranch tc) $ fromBranches branches)) 2 (vcat (map (ppr_co_ax_branch (const ppr) ax) $ fromBranches branches))
pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc pprCoAxBranch :: CoAxiom br -> CoAxBranch -> SDoc
pprCoAxBranch fam_tc (CoAxBranch { cab_tvs = tvs pprCoAxBranch = ppr_co_ax_branch pprRhs
, cab_lhs = lhs where
, cab_rhs = rhs }) pprRhs fam_tc (TyConApp tycon _)
= hang (pprUserForAll tvs) | isDataFamilyTyCon fam_tc
2 (hang (pprTypeApp fam_tc lhs) 2 (equals <+> (ppr rhs))) = pprDataCons tycon
pprRhs _ rhs = ppr rhs
pprCoAxBranchHdr :: CoAxiom br -> BranchIndex -> SDoc pprCoAxBranchHdr :: CoAxiom br -> BranchIndex -> SDoc
pprCoAxBranchHdr ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_name = name }) index pprCoAxBranchHdr ax index = pprCoAxBranch ax (coAxiomNthBranch ax index)
| CoAxBranch { cab_lhs = tys, cab_loc = loc } <- coAxiomNthBranch ax index
= hang (pprTypeApp fam_tc tys) ppr_co_ax_branch :: (TyCon -> Type -> SDoc) -> CoAxiom br -> CoAxBranch -> SDoc
2 (ptext (sLit "-- Defined") <+> ppr_loc loc) ppr_co_ax_branch ppr_rhs
(CoAxiom { co_ax_tc = fam_tc, co_ax_name = name })
(CoAxBranch { cab_tvs = tvs
, cab_lhs = lhs
, cab_rhs = rhs
, cab_loc = loc })
= foldr1 (flip hangNotEmpty 2)
[ pprUserForAll tvs
, pprTypeApp fam_tc lhs <+> equals <+> ppr_rhs fam_tc rhs
, text "-- Defined" <+> pprLoc loc ]
where where
ppr_loc loc pprLoc loc
| isGoodSrcSpan loc | isGoodSrcSpan loc
= ptext (sLit "at") <+> ppr (srcSpanStart loc) = text "at" <+> ppr (srcSpanStart loc)
| otherwise | otherwise
= ptext (sLit "in") <+> = text "in" <+>
quotes (ppr (nameModule name)) quotes (ppr (nameModule name))
{- {-
......
...@@ -39,6 +39,7 @@ module TypeRep ( ...@@ -39,6 +39,7 @@ module TypeRep (
pprKind, pprParendKind, pprTyLit, suppressKinds, pprKind, pprParendKind, pprTyLit, suppressKinds,
TyPrec(..), maybeParen, pprTcApp, TyPrec(..), maybeParen, pprTcApp,
pprPrefixApp, pprArrowChain, ppr_type, pprPrefixApp, pprArrowChain, ppr_type,
pprDataCons,
-- Free variables -- Free variables
tyVarsOfType, tyVarsOfTypes, closeOverKinds, varSetElemsKvsFirst, tyVarsOfType, tyVarsOfTypes, closeOverKinds, varSetElemsKvsFirst,
...@@ -59,7 +60,7 @@ module TypeRep ( ...@@ -59,7 +60,7 @@ module TypeRep (
#include "HsVersions.h" #include "HsVersions.h"
import {-# SOURCE #-} DataCon( dataConTyCon ) import {-# SOURCE #-} DataCon( DataCon, dataConTyCon, dataConFullSig )
import {-# SOURCE #-} ConLike ( ConLike(..) ) import {-# SOURCE #-} ConLike ( ConLike(..) )
import {-# SOURCE #-} Type( isPredTy ) -- Transitively pulls in a LOT of stuff, better to break the loop import {-# SOURCE #-} Type( isPredTy ) -- Transitively pulls in a LOT of stuff, better to break the loop
...@@ -77,6 +78,7 @@ import CoAxiom ...@@ -77,6 +78,7 @@ import CoAxiom
import PrelNames import PrelNames
import Outputable import Outputable
import FastString import FastString
import ListSetOps
import Util import Util
import DynFlags import DynFlags
import StaticFlags( opt_PprStyle_Debug ) import StaticFlags( opt_PprStyle_Debug )
...@@ -693,6 +695,20 @@ remember to parenthesise the operator, thus ...@@ -693,6 +695,20 @@ remember to parenthesise the operator, thus
See Trac #2766. See Trac #2766.
-} -}
pprDataCons :: TyCon -> SDoc
pprDataCons = sepWithVBars . fmap pprDataConWithArgs . tyConDataCons
where
sepWithVBars [] = empty
sepWithVBars docs = sep (punctuate (space <> vbar) docs)
pprDataConWithArgs :: DataCon -> SDoc
pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc]
where
(univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc
forAllDoc = pprUserForAll ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs)
thetaDoc = pprThetaArrowTy theta
argsDoc = hsep (fmap pprParendType arg_tys)
pprTypeApp :: TyCon -> [Type] -> SDoc pprTypeApp :: TyCon -> [Type] -> SDoc
pprTypeApp tc tys = pprTyTcApp TopPrec tc tys pprTypeApp tc tys = pprTyTcApp TopPrec tc tys
-- We have to use ppr on the TyCon (not its name) -- We have to use ppr on the TyCon (not its name)
......
...@@ -193,7 +193,7 @@ pprBooleanFormula :: (Rational -> a -> SDoc) -> Rational -> BooleanFormula a -> ...@@ -193,7 +193,7 @@ pprBooleanFormula :: (Rational -> a -> SDoc) -> Rational -> BooleanFormula a ->
pprBooleanFormula pprVar = pprBooleanFormula' pprVar pprAnd pprOr pprBooleanFormula pprVar = pprBooleanFormula' pprVar pprAnd pprOr
where where
pprAnd p = cparen (p > 3) . fsep . punctuate comma pprAnd p = cparen (p > 3) . fsep . punctuate comma
pprOr p = cparen (p > 2) . fsep . intersperse (text "|") pprOr p = cparen (p > 2) . fsep . intersperse vbar
-- Pretty print human in readable format, "either `a' or `b' or (`c', `d' and `e')"? -- Pretty print human in readable format, "either `a' or `b' or (`c', `d' and `e')"?
pprBooleanFormulaNice :: Outputable a => BooleanFormula a -> SDoc pprBooleanFormulaNice :: Outputable a => BooleanFormula a -> SDoc
......
...@@ -25,7 +25,7 @@ module Outputable ( ...@@ -25,7 +25,7 @@ module Outputable (
int, intWithCommas, integer, float, double, rational, int, intWithCommas, integer, float, double, rational,
parens, cparen, brackets, braces, quotes, quote, parens, cparen, brackets, braces, quotes, quote,
doubleQuotes, angleBrackets, paBrackets, doubleQuotes, angleBrackets, paBrackets,
semi, comma, colon, dcolon, space, equals, dot, semi, comma, colon, dcolon, space, equals, dot, vbar,
arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt, arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt,
lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
blankLine, forAllLit, blankLine, forAllLit,
...@@ -33,7 +33,7 @@ module Outputable ( ...@@ -33,7 +33,7 @@ module Outputable (
($$), ($+$), vcat, ($$), ($+$), vcat,
sep, cat, sep, cat,
fsep, fcat, fsep, fcat,
hang, punctuate, ppWhen, ppUnless, hang, hangNotEmpty, punctuate, ppWhen, ppUnless,
speakNth, speakN, speakNOf, plural, isOrAre, doOrDoes, speakNth, speakN, speakNOf, plural, isOrAre, doOrDoes,
coloured, PprColour, colType, colCoerc, colDataCon, coloured, PprColour, colType, colCoerc, colDataCon,
...@@ -521,7 +521,7 @@ quotes d = ...@@ -521,7 +521,7 @@ quotes d =
('\'' : _, _) -> pp_d ('\'' : _, _) -> pp_d
_other -> Pretty.quotes pp_d _other -> Pretty.quotes pp_d
semi, comma, colon, equals, space, dcolon, underscore, dot :: SDoc semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc
arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc
lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
...@@ -541,6 +541,7 @@ equals = docToSDoc $ Pretty.equals ...@@ -541,6 +541,7 @@ equals = docToSDoc $ Pretty.equals
space = docToSDoc $ Pretty.space space = docToSDoc $ Pretty.space
underscore = char '_' underscore = char '_'
dot = char '.' dot = char '.'
vbar = char '|'
lparen = docToSDoc $ Pretty.lparen lparen = docToSDoc $ Pretty.lparen
rparen = docToSDoc $ Pretty.rparen rparen = docToSDoc $ Pretty.rparen
lbrack = docToSDoc $ Pretty.lbrack lbrack = docToSDoc $ Pretty.lbrack
...@@ -606,6 +607,12 @@ hang :: SDoc -- ^ The header ...@@ -606,6 +607,12 @@ hang :: SDoc -- ^ The header
-> SDoc -> SDoc
hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty) hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
-- | This behaves like 'hang', but does not indent the second document
-- when the header is empty.
hangNotEmpty :: SDoc -> Int -> SDoc -> SDoc
hangNotEmpty d1 n d2 =
SDoc $ \sty -> Pretty.hangNotEmpty (runSDoc d1 sty) n (runSDoc d2 sty)
punctuate :: SDoc -- ^ The punctuation punctuate :: SDoc -- ^ The punctuation
-> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
-> [SDoc] -- ^ Punctuated list -> [SDoc] -- ^ Punctuated list
......
...@@ -180,7 +180,7 @@ module Pretty ( ...@@ -180,7 +180,7 @@ module Pretty (
sep, cat, sep, cat,
fsep, fcat, fsep, fcat,
nest, nest,
hang, punctuate, hang, hangNotEmpty, punctuate,
-- * Predicates on documents -- * Predicates on documents
isEmpty, isEmpty,
...@@ -563,6 +563,12 @@ nest k p = mkNest k (reduceDoc p) ...@@ -563,6 +563,12 @@ nest k p = mkNest k (reduceDoc p)
hang :: Doc -> Int -> Doc -> Doc hang :: Doc -> Int -> Doc -> Doc
hang d1 n d2 = sep [d1, nest n d2] hang d1 n d2 = sep [d1, nest n d2]
-- | Apply 'hang' to the arguments if the first 'Doc' is not empty.
hangNotEmpty :: Doc -> Int -> Doc -> Doc
hangNotEmpty d1 n d2 = if isEmpty d1
then d2
else hang d1 n d2
-- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@ -- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@
punctuate :: Doc -> [Doc] -> [Doc] punctuate :: Doc -> [Doc] -> [Doc]
punctuate _ [] = [] punctuate _ [] = []
......
<interactive>:10:15: error: <interactive>:10:15: error: