Simon's big boxy-type commit

[ghc-hetmet.git] / ghc / compiler / main / PprTyThing.hs

diff --git a/ghc/compiler/main/PprTyThing.hs b/ghc/compiler/main/PprTyThing.hs
index fc53e72..2763b05 100644 (file)
--- a/ghc/compiler/main/PprTyThing.hs
+++ b/ghc/compiler/main/PprTyThing.hs
@@ -11,6 +11,7 @@ module PprTyThing (
        pprTyThingInContext,
        pprTyThingLoc,
        pprTyThingInContextLoc,
+       pprTyThingHdr
   ) where
 
 #include "HsVersions.h"
@@ -53,12 +54,23 @@ pprTyThingInContext exts (AnId id)          = pprIdInContext exts id
 pprTyThingInContext exts (ADataCon dataCon) = pprDataCon exts dataCon
 pprTyThingInContext exts (ATyCon tyCon)     = pprTyCon   exts tyCon
 pprTyThingInContext exts (AClass cls)       = pprClass   exts cls
+
+-- | Pretty-prints the 'TyThing' header. For functions and data constructors
+-- the function is equivalent to 'pprTyThing' but for type constructors
+-- and classes it prints only the header part of the declaration.
+pprTyThingHdr :: Bool -> TyThing -> SDoc
+pprTyThingHdr exts (AnId id)          = pprId         exts id
+pprTyThingHdr exts (ADataCon dataCon) = pprDataConSig exts dataCon
+pprTyThingHdr exts (ATyCon tyCon)     = pprTyConHdr   exts tyCon
+pprTyThingHdr exts (AClass cls)       = pprClassHdr   exts cls
         
 pprTyConHdr exts tyCon =
   ptext keyword <+> ppr_bndr tyCon <+> hsep (map ppr vars)
   where
-    vars = GHC.tyConTyVars tyCon
-    
+    vars | GHC.isPrimTyCon tyCon || 
+          GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars
+        | otherwise = GHC.tyConTyVars tyCon
+
     keyword | GHC.isSynTyCon tyCon = SLIT("type")
             | GHC.isNewTyCon tyCon = SLIT("newtype")
             | otherwise            = SLIT("data")
@@ -95,7 +107,7 @@ pprType False ty = ppr (GHC.dropForAlls ty)
 
 pprTyCon exts tyCon
   | GHC.isSynTyCon tyCon
-  = let (_,rhs_type) = GHC.getSynTyConDefn tyCon
+  = let rhs_type = GHC.synTyConRhs tyCon
     in hang (pprTyConHdr exts tyCon <+> equals) 2 (pprType exts rhs_type)
   | otherwise
   = pprAlgTyCon exts tyCon (const True) (const True)