[commit: ghc] master: Print (non-representational) roles when display TyCon information (67ede55)

[git at git.haskell.org]

Repository : ssh://git at git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/67ede55dcc8cbb225172d2b688b335bae81e20a1/ghc

>---------------------------------------------------------------

commit 67ede55dcc8cbb225172d2b688b335bae81e20a1
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Oct 8 18:07:37 2013 +0100

    Print (non-representational) roles when display TyCon information


>---------------------------------------------------------------

67ede55dcc8cbb225172d2b688b335bae81e20a1
 compiler/main/PprTyThing.hs |   39 +++++++++++++++++++++++++--------------
 1 file changed, 25 insertions(+), 14 deletions(-)

diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
index d8cbc07..1f458f0 100644
--- a/compiler/main/PprTyThing.hs
+++ b/compiler/main/PprTyThing.hs
@@ -181,27 +181,38 @@ pprTyCon :: ShowSub -> TyCon -> SDoc
 pprTyCon ss tyCon
   | Just syn_rhs <- synTyConRhs_maybe tyCon
   = case syn_rhs of
-      OpenSynFamilyTyCon -> pprTyConHdr tyCon <+> dcolon <+>
-                                 pprTypeForUser (synTyConResKind tyCon)
-      ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) ->
-        hang closed_family_header
-           2 (vcat (brListMap (pprCoAxBranch tyCon) branches))
-      AbstractClosedSynFamilyTyCon -> closed_family_header <+> ptext (sLit "..")
-      SynonymTyCon rhs_ty -> hang (pprTyConHdr tyCon <+> equals)
-                                     2 (ppr rhs_ty)   -- Don't suppress foralls on RHS type!
-      BuiltInSynFamTyCon {} -> pprTyConHdr tyCon <+> dcolon <+>
-                             pprTypeForUser (synTyConResKind tyCon)
+      OpenSynFamilyTyCon    -> pp_tc_with_kind
+      BuiltInSynFamTyCon {} -> pp_tc_with_kind
+
+      ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches })
+         -> hang closed_family_header
+              2  (vcat (brListMap (pprCoAxBranch tyCon) branches))
+
+      AbstractClosedSynFamilyTyCon
+         -> closed_family_header <+> ptext (sLit "..")
+
+      SynonymTyCon rhs_ty
+         -> hang (pprTyConHdr tyCon <+> equals)
+               2 (ppr rhs_ty)   -- Don't suppress foralls on RHS type!
 
                                                  -- e.g. type T = forall a. a->a
   | Just cls <- tyConClass_maybe tyCon
-  = pprClass ss cls
+  = pp_roles $$ pprClass ss cls
+
   | otherwise
-  = pprAlgTyCon ss tyCon
+  = pp_roles $$ pprAlgTyCon ss tyCon
 
   where
+    pp_roles = sdocWithDynFlags $ \dflags ->
+               let roles = suppressKinds dflags (tyConKind tyCon) (tyConRoles tyCon)
+               in ppUnless (all (== Representational) roles) $
+                  ptext (sLit "type role") <+> ppr tyCon <+> hsep (map ppr roles)
+
+    pp_tc_with_kind = vcat [ pp_roles
+                           , pprTyConHdr tyCon <+> dcolon
+                             <+> pprTypeForUser (synTyConResKind tyCon) ]
     closed_family_header
-      = pprTyConHdr tyCon <+> dcolon <+>
-        pprTypeForUser (synTyConResKind tyCon) <+> ptext (sLit "where")
+       = pp_tc_with_kind <+> ptext (sLit "where")
 
 pprAlgTyCon :: ShowSub -> TyCon -> SDoc
 pprAlgTyCon ss tyCon