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

18 files changed, 104 insertions, 58 deletions

diff --git a/compiler/basicTypes/DataCon.hs-boot b/compiler/basicTypes/DataCon.hs-boot
index ca20788a84..615ef53d09 100644
--- a/compiler/basicTypes/DataCon.hs-boot
+++ b/compiler/basicTypes/DataCon.hs-boot
@@ -17,6 +17,8 @@ dataConSourceArity  :: DataCon -> Arity
 dataConFieldLabels :: DataCon -> [FieldLabel]
 dataConInstOrigArgTys  :: DataCon -> [Type] -> [Type]
 dataConStupidTheta :: DataCon -> ThetaType
+dataConFullSig :: DataCon
+               -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type], Type)
 
 instance Eq DataCon
 instance Ord DataCon
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 00a7fd0b19..d9116a6f9b 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -1350,13 +1350,13 @@ lintCoercion (InstCo co arg_ty)
 
 lintCoercion co@(AxiomInstCo con ind cos)
   = 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]
        ; let CoAxBranch { cab_tvs   = ktvs
                         , cab_roles = roles
                         , cab_lhs   = lhs
                         , 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
        ; let empty_subst = mkTvSubst in_scope emptyTvSubstEnv
        ; (subst_l, subst_r) <- foldlM check_ki
@@ -1365,11 +1365,12 @@ lintCoercion co@(AxiomInstCo con ind cos)
        ; let lhs' = Type.substTys subst_l lhs
              rhs' = Type.substTy subst_r rhs
        ; 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 ()
        ; return (typeKind rhs', mkTyConApp (coAxiomTyCon con) lhs', rhs', coAxiomRole con) }
   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))
 
     check_ki (subst_l, subst_r) (ktv, role, co)
@@ -1379,7 +1380,8 @@ lintCoercion co@(AxiomInstCo con ind cos)
                   -- Using subst_l is ok, because subst_l and subst_r
                   -- must agree on kind equalities
            ; 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,
                      Type.extendTvSubst subst_r ktv t2) }
 
diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs
index a14c608d1c..98f7f0f051 100644
--- a/compiler/deSugar/DsUtils.hs
+++ b/compiler/deSugar/DsUtils.hs
@@ -463,7 +463,7 @@ mkErrorAppDs err_id ty msg = do
     src_loc <- getSrcSpanDs
     dflags <- getDynFlags
     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)
         -- mkMachString returns a result of type String#
     return (mkApps (Var err_id) [Type ty, core_msg])
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index ec46d0e0f2..91c04fa08c 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -906,7 +906,7 @@ pprFamilyDecl top_level (FamilyDecl { fdInfo = info, fdLName = ltycon
                 TyVarSig tv_bndr -> text "=" <+> ppr tv_bndr
     pp_inj = case mb_inj of
                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
     (pp_where, pp_eqns) = case info of
       ClosedTypeFamily mb_eqns ->
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index d02f2d57d0..e688d18a08 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -713,7 +713,7 @@ ppr_expr (HsIf _ e1 e2 e3)
 ppr_expr (HsMultiIf _ alts)
   = sep $ ptext (sLit "if") : map ppr_alt alts
   where ppr_alt (L _ (GRHS guards expr)) =
-          sep [ char '|' <+> interpp'SP guards
+          sep [ vbar <+> interpp'SP guards
               , ptext (sLit "->") <+> pprDeeper (ppr expr) ]
 
 -- special case: let ... in let ...
@@ -1283,7 +1283,7 @@ pprGRHS ctxt (GRHS [] body)
  =  pp_rhs ctxt 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 ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
@@ -1707,7 +1707,7 @@ pprComp :: (OutputableBndr id, Outputable body)
 pprComp quals     -- Prints:  body | qual1, ..., qualn
   | not (null 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
   = pprPanic "pprComp" (pprQuals quals)
 
@@ -1842,7 +1842,7 @@ pprSplice (HsQuasiQuote n q _ s) = ppr_quasi n q s
 
 ppr_quasi :: OutputableBndr id => id -> id -> FastString -> SDoc
 ppr_quasi n quoter quote = ifPprDebug (brackets (ppr n)) <>
-                           char '[' <> ppr quoter <> ptext (sLit "|") <>
+                           char '[' <> ppr quoter <> vbar <>
                            ppr quote <> ptext (sLit "|]")
 
 ppr_splice :: OutputableBndr id => SDoc -> id -> LHsExpr id -> SDoc
@@ -1888,7 +1888,7 @@ pprHsBracket (VarBr False n) = ptext (sLit "''") <> ppr n
 pprHsBracket (TExpBr e)  = thTyBrackets (ppr e)
 
 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 "|]")
 
 thTyBrackets :: SDoc -> SDoc
diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs
index 3911786594..41d6779785 100644
--- a/compiler/iface/IfaceSyn.hs
+++ b/compiler/iface/IfaceSyn.hs
@@ -643,7 +643,7 @@ pprIfaceDecl ss (IfaceData { ifName = tycon, ifCType = ctype,
             -- See discussion on Trac #8672.
 
     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)
 
@@ -741,7 +741,7 @@ pprIfaceDecl ss (IfaceFamily { ifName = tycon, ifTyVars = tyvars
 
     pp_inj_cond res inj = case filterByList inj tyvars of
        []  -> empty
-       tvs -> hsep [text "|", ppr res, text "->", interppSP (map fst tvs)]
+       tvs -> hsep [vbar, ppr res, text "->", interppSP (map fst tvs)]
 
     pp_rhs IfaceDataFamilyTyCon
       = ppShowIface ss (ptext (sLit "data"))
diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs
index 48acd8dd28..f4a6a3d79d 100644
--- a/compiler/iface/LoadIface.hs
+++ b/compiler/iface/LoadIface.hs
@@ -910,9 +910,10 @@ When printing export lists, we print like this:
 pprExport :: IfaceExport -> SDoc
 pprExport (Avail _ n)         = ppr n
 pprExport (AvailTC _ [] []) = Outputable.empty
-pprExport (AvailTC n ns0 fs) = case ns0 of
-                                 (n':ns) | n==n' -> ppr n <> pp_export ns fs
-                                 _               -> ppr n <> char '|' <> pp_export ns0 fs
+pprExport (AvailTC n ns0 fs)
+  = case ns0 of
+      (n':ns) | n==n' -> ppr n <> pp_export ns fs
+      _               -> ppr n <> vbar <> pp_export ns0 fs
   where
     pp_export []    [] = Outputable.empty
     pp_export names fs = braces (hsep (map ppr names ++ map (ppr . flLabel) fs))
diff --git a/compiler/nativeGen/Reg.hs b/compiler/nativeGen/Reg.hs
index 862306f0bb..e8d0187641 100644
--- a/compiler/nativeGen/Reg.hs
+++ b/compiler/nativeGen/Reg.hs
@@ -135,8 +135,9 @@ instance Uniquable RealReg where
 instance Outputable RealReg where
         ppr reg
          = case reg of
-                RealRegSingle i         -> text "%r"    <> int i
-                RealRegPair r1 r2       -> text "%r(" <> int r1 <> text "|" <> int r2 <> text ")"
+                RealRegSingle i         -> text "%r"  <> int i
+                RealRegPair r1 r2       -> text "%r(" <> int r1
+                                           <> vbar <> int r2 <> text ")"
 
 regNosOfRealReg :: RealReg -> [RegNo]
 regNosOfRealReg rr
diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs
index 93beabef10..eac88f8d0c 100644
--- a/compiler/nativeGen/SPARC/Ppr.hs
+++ b/compiler/nativeGen/SPARC/Ppr.hs
@@ -161,7 +161,7 @@ pprReg reg
 
                 RealRegPair r1 r2
                  -> text "(" <> pprReg_ofRegNo r1
-                 <> text "|" <> pprReg_ofRegNo r2
+                 <> vbar     <> pprReg_ofRegNo r2
                  <> text ")"
 
 
diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs
index 7023a4c1f9..93de5040f0 100644
--- a/compiler/typecheck/FamInst.hs
+++ b/compiler/typecheck/FamInst.hs
@@ -402,10 +402,10 @@ checkForInjectivityConflicts instEnvs famInst
     | isTypeFamilyTyCon tycon
     -- type family is injective in at least one argument
     , Injective inj <- familyTyConInjectivityInfo tycon = do
-    { let axiom = coAxiomSingleBranch (fi_axiom famInst)
+    { let axiom = coAxiomSingleBranch fi_ax
           conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst
           -- 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
     ; return (null errs)
     }
@@ -414,15 +414,16 @@ checkForInjectivityConflicts instEnvs famInst
     -- type family we report no conflicts
     | otherwise = return True
     where tycon = famInstTyCon famInst
+          fi_ax = fi_axiom famInst
 
 -- | Build a list of injectivity errors together with their source locations.
 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)
    -> [Bool]       -- ^ Injectivity annotation
    -> [CoAxBranch] -- ^ List of injectivity conflicts
    -> [(SDoc, SrcSpan)]
-makeInjectivityErrors tycon axiom inj conflicts
+makeInjectivityErrors fi_ax axiom inj conflicts
   = ASSERT2( any id inj, text "No injective type variables" )
     let lhs             = coAxBranchLHS axiom
         rhs             = coAxBranchRHS axiom
@@ -435,7 +436,8 @@ makeInjectivityErrors tycon axiom inj conflicts
         wrong_bare_rhs  = not $ null bare_variables
 
         err_builder herald eqns
-                        = ( herald $$ vcat (map (pprCoAxBranch tycon) eqns)
+                        = ( hang herald
+                               2 (vcat (map (pprCoAxBranch fi_ax) eqns))
                           , coAxBranchSpan (head eqns) )
         errorIf p f     = if p then [f err_builder axiom] else []
      in    errorIf are_conflicts  (conflictInjInstErr     conflicts     )
diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs
index 06cb42715a..51e00159b1 100644
--- a/compiler/typecheck/TcInstDcls.hs
+++ b/compiler/typecheck/TcInstDcls.hs
@@ -1288,7 +1288,8 @@ tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
         error_msg dflags = L inst_loc (HsLit (HsStringPrim ""
                                     (unsafeMkByteString (error_string dflags))))
         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
 
     tc_default sel_id (DefMeth dm_name) -- A polymorphic default method
diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs
index 3b5d206a67..d3f8291881 100644
--- a/compiler/typecheck/TcValidity.hs
+++ b/compiler/typecheck/TcValidity.hs
@@ -35,6 +35,7 @@ import Class
 import TyCon
 
 -- others:
+import Coercion    ( pprCoAxBranch )
 import HsSyn            -- HsType
 import TcRnMonad        -- TcType, amongst others
 import FunDeps
@@ -1238,7 +1239,7 @@ wrongATArgErr ty instTy =
 -}
 
 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
        ; foldlM_ check_branch_compat [] branch_list }
   where
@@ -1254,7 +1255,7 @@ checkValidCoAxiom (CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches })
     check_branch_compat prev_branches cur_branch
       | cur_branch `isDominatedBy` prev_branches
       = do { addWarnAt (coAxBranchSpan cur_branch) $
-             inaccessibleCoAxBranch fam_tc cur_branch
+             inaccessibleCoAxBranch ax cur_branch
            ; return prev_branches }
       | otherwise
       = do { check_injectivity prev_branches cur_branch
@@ -1270,7 +1271,7 @@ checkValidCoAxiom (CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches })
                      fst $ foldl (gather_conflicts inj prev_branches cur_branch)
                                  ([], 0) prev_branches
            ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err)
-                   (makeInjectivityErrors fam_tc cur_branch inj conflicts) }
+                   (makeInjectivityErrors ax cur_branch inj conflicts) }
       | otherwise
       = return ()
 
@@ -1388,13 +1389,10 @@ isTyFamFree = null . tcTyFamInsts
 
 -- Error messages
 
-inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc
-inaccessibleCoAxBranch fam_tc (CoAxBranch { cab_tvs = tvs
-                                          , cab_lhs = lhs
-                                          , cab_rhs = rhs })
+inaccessibleCoAxBranch :: CoAxiom br -> CoAxBranch -> SDoc
+inaccessibleCoAxBranch fi_ax cur_branch
   = ptext (sLit "Type family instance equation is overlapped:") $$
-    hang (pprUserForAll tvs)
-       2 (hang (pprTypeApp fam_tc lhs) 2 (equals <+> (ppr rhs)))
+    nest 2 (pprCoAxBranch fi_ax cur_branch)
 
 tyFamInstIllegalErr :: Type -> SDoc
 tyFamInstIllegalErr ty
diff --git a/compiler/types/Class.hs b/compiler/types/Class.hs
index 9daa3722b8..34f6edbcec 100644
--- a/compiler/types/Class.hs
+++ b/compiler/types/Class.hs
@@ -290,7 +290,7 @@ instance Outputable DefMeth where
 
 pprFundeps :: Outputable a => [FunDep a] -> SDoc
 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 (us, vs) = hsep [interppSP us, ptext (sLit "->"), interppSP vs]
diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs
index b73ca4969b..af05d5c1f8 100644
--- a/compiler/types/Coercion.hs
+++ b/compiler/types/Coercion.hs
@@ -754,29 +754,39 @@ ppr_forall_co p ty
     split1 tvs ty               = (reverse tvs, ty)
 
 pprCoAxiom :: CoAxiom br -> SDoc
-pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches })
-  = hang (ptext (sLit "axiom") <+> ppr ax <+> dcolon)
-       2 (vcat (map (pprCoAxBranch tc) $ fromBranches branches))
+pprCoAxiom ax@(CoAxiom { co_ax_branches = branches })
+  = hang (text "axiom" <+> ppr ax <+> dcolon)
+       2 (vcat (map (ppr_co_ax_branch (const ppr) ax) $ fromBranches branches))
 
-pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc
-pprCoAxBranch fam_tc (CoAxBranch { cab_tvs = tvs
-                                 , cab_lhs = lhs
-                                 , cab_rhs = rhs })
-  = hang (pprUserForAll tvs)
-       2 (hang (pprTypeApp fam_tc lhs) 2 (equals <+> (ppr rhs)))
+pprCoAxBranch :: CoAxiom br -> CoAxBranch -> SDoc
+pprCoAxBranch = ppr_co_ax_branch pprRhs
+  where
+    pprRhs fam_tc (TyConApp tycon _)
+      | isDataFamilyTyCon fam_tc
+      = pprDataCons tycon
+    pprRhs _ rhs = ppr rhs
 
 pprCoAxBranchHdr :: CoAxiom br -> BranchIndex -> SDoc
-pprCoAxBranchHdr ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_name = name }) index
-  | CoAxBranch { cab_lhs = tys, cab_loc = loc } <- coAxiomNthBranch ax index
-  = hang (pprTypeApp fam_tc tys)
-       2 (ptext (sLit "-- Defined") <+> ppr_loc loc)
+pprCoAxBranchHdr ax index = pprCoAxBranch ax (coAxiomNthBranch ax index)
+
+ppr_co_ax_branch :: (TyCon -> Type -> SDoc) -> CoAxiom br -> CoAxBranch -> SDoc
+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
-        ppr_loc loc
+        pprLoc loc
           | isGoodSrcSpan loc
-          = ptext (sLit "at") <+> ppr (srcSpanStart loc)
+          = text "at" <+> ppr (srcSpanStart loc)
 
           | otherwise
-          = ptext (sLit "in") <+>
+          = text "in" <+>
               quotes (ppr (nameModule name))
 
 {-
diff --git a/compiler/types/TypeRep.hs b/compiler/types/TypeRep.hs
index e09c9377b6..574e15367e 100644
--- a/compiler/types/TypeRep.hs
+++ b/compiler/types/TypeRep.hs
@@ -39,6 +39,7 @@ module TypeRep (
         pprKind, pprParendKind, pprTyLit, suppressKinds,
         TyPrec(..), maybeParen, pprTcApp,
         pprPrefixApp, pprArrowChain, ppr_type,
+        pprDataCons,
 
         -- Free variables
         tyVarsOfType, tyVarsOfTypes, closeOverKinds, varSetElemsKvsFirst,
@@ -59,7 +60,7 @@ module TypeRep (
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} DataCon( dataConTyCon )
+import {-# SOURCE #-} DataCon( DataCon, dataConTyCon, dataConFullSig )
 import {-# SOURCE #-} ConLike ( ConLike(..) )
 import {-# SOURCE #-} Type( isPredTy ) -- Transitively pulls in a LOT of stuff, better to break the loop
 
@@ -77,6 +78,7 @@ import CoAxiom
 import PrelNames
 import Outputable
 import FastString
+import ListSetOps
 import Util
 import DynFlags
 import StaticFlags( opt_PprStyle_Debug )
@@ -693,6 +695,20 @@ remember to parenthesise the operator, thus
 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 tc tys = pprTyTcApp TopPrec tc tys
         -- We have to use ppr on the TyCon (not its name)
diff --git a/compiler/utils/BooleanFormula.hs b/compiler/utils/BooleanFormula.hs
index 41ac13963e..382431e549 100644
--- a/compiler/utils/BooleanFormula.hs
+++ b/compiler/utils/BooleanFormula.hs
@@ -193,7 +193,7 @@ pprBooleanFormula :: (Rational -> a -> SDoc) -> Rational -> BooleanFormula a ->
 pprBooleanFormula pprVar = pprBooleanFormula' pprVar pprAnd pprOr
   where
   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')"?
 pprBooleanFormulaNice :: Outputable a => BooleanFormula a -> SDoc
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index 83febd5d04..fbd6760923 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -25,7 +25,7 @@ module Outputable (
         int, intWithCommas, integer, float, double, rational,
         parens, cparen, brackets, braces, quotes, quote,
         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,
         lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
         blankLine, forAllLit,
@@ -33,7 +33,7 @@ module Outputable (
         ($$), ($+$), vcat,
         sep, cat,
         fsep, fcat,
-        hang, punctuate, ppWhen, ppUnless,
+        hang, hangNotEmpty, punctuate, ppWhen, ppUnless,
         speakNth, speakN, speakNOf, plural, isOrAre, doOrDoes,
 
         coloured, PprColour, colType, colCoerc, colDataCon,
@@ -521,7 +521,7 @@ quotes d =
              ('\'' : _, _)       -> 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
 lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
 
@@ -541,6 +541,7 @@ equals     = docToSDoc $ Pretty.equals
 space      = docToSDoc $ Pretty.space
 underscore = char '_'
 dot        = char '.'
+vbar       = char '|'
 lparen     = docToSDoc $ Pretty.lparen
 rparen     = docToSDoc $ Pretty.rparen
 lbrack     = docToSDoc $ Pretty.lbrack
@@ -606,6 +607,12 @@ hang :: SDoc  -- ^ The header
       -> SDoc
 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
           -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
           -> [SDoc] -- ^ Punctuated list
diff --git a/compiler/utils/Pretty.hs b/compiler/utils/Pretty.hs
index 4aae2c8c53..74d69f23d0 100644
--- a/compiler/utils/Pretty.hs
+++ b/compiler/utils/Pretty.hs
@@ -180,7 +180,7 @@ module Pretty (
         sep, cat,
         fsep, fcat,
         nest,
-        hang, punctuate,
+        hang, hangNotEmpty, punctuate,
 
         -- * Predicates on documents
         isEmpty,
@@ -563,6 +563,12 @@ nest k p = mkNest k (reduceDoc p)
 hang :: Doc -> Int -> Doc -> Doc
 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 :: Doc -> [Doc] -> [Doc]
 punctuate _ []     = []