[project @ 2003-06-27 21:17:24 by simonpj]

[ghc-hetmet.git] / ghc / compiler / types / PprType.lhs

diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs
index 25348d0..4a04bff 100644 (file)
--- a/ghc/compiler/types/PprType.lhs
+++ b/ghc/compiler/types/PprType.lhs
@@ -18,26 +18,26 @@ module PprType(
 
 -- friends:
 -- (PprType can see all the representations it's trying to print)
-import TypeRep         ( Type(..), TyNote(..), Kind, liftedTypeKind ) -- friend
-import Type            ( SourceType(..), isUTyVar, eqKind )
-import TcType          ( ThetaType, PredType, tcSplitPredTy_maybe, 
+import TypeRep         ( Type(..), TyNote(..), Kind  ) -- friend
+import Type            ( SourceType(..) ) 
+import TcType          ( ThetaType, PredType, TyThing(..),
                          tcSplitSigmaTy, isPredTy, isDictTy,
                          tcSplitTyConApp_maybe, tcSplitFunTy_maybe
                        ) 
 import Var             ( TyVar, tyVarKind )
 import Class           ( Class )
 import TyCon           ( TyCon, isPrimTyCon, isTupleTyCon, tupleTyConBoxity,
-                         maybeTyConSingleCon, isEnumerationTyCon, 
-                         tyConArity, tyConName
+                         maybeTyConSingleCon, isEnumerationTyCon, tyConArity
                        )
 
 -- others:
-import CmdLineOpts     ( opt_PprStyle_RawTypes )
 import Maybes          ( maybeToBool )
 import Name            ( getOccString, getOccName )
+import OccName         ( occNameUserString )
 import Outputable
 import Unique          ( Uniquable(..) )
-import BasicTypes      ( tupleParens )
+import Util             ( lengthIs )
+import BasicTypes      ( IPName(..), tupleParens, ipNameName )
 import PrelNames               -- quite a few *Keys
 \end{code}
 
@@ -66,21 +66,33 @@ pprPred = pprSourceType
 
 pprSourceType :: SourceType -> SDoc
 pprSourceType (ClassP clas tys) = pprClassPred clas tys
-pprSourceType (IParam n ty)     = hsep [ptext SLIT("?") <> ppr n,
-                                 ptext SLIT("::"), ppr ty]
-pprSourceType (NType tc tys)    = ppr tc <+> hsep (map pprParendType tys)
+pprSourceType (IParam n ty)     = hsep [ppr n, dcolon, ppr ty]
+pprSourceType (NType tc tys)    = ppr tc <+> sep (map pprParendType tys)
 
 pprClassPred :: Class -> [Type] -> SDoc
-pprClassPred clas tys = ppr clas <+> hsep (map pprParendType tys)
+pprClassPred clas tys = ppr clas <+> sep (map pprParendType tys)
 
 pprTheta :: ThetaType -> SDoc
-pprTheta theta = parens (hsep (punctuate comma (map pprPred theta)))
+pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
 
 instance Outputable Type where
     ppr ty = pprType ty
 
-instance Outputable PredType where
+instance Outputable SourceType where
     ppr = pprPred
+
+instance Outputable name => Outputable (IPName name) where
+    ppr (Dupable n) = char '?' <> ppr n -- Ordinary implicit parameters
+    ppr (Linear  n) = char '%' <> ppr n -- Splittable implicit parameters
+
+instance Outputable name => OutputableBndr (IPName name) where
+    pprBndr _ n = ppr n        -- Simple for now
+
+instance Outputable TyThing where
+  ppr (AnId   id)   = ptext SLIT("AnId")     <+> ppr id
+  ppr (ATyCon tc)   = ptext SLIT("ATyCon")   <+> ppr tc
+  ppr (AClass cl)   = ptext SLIT("AClass")   <+> ppr cl
+  ppr (ADataCon dc) = ptext SLIT("ADataCon") <+> ppr dc
 \end{code}
 
 
@@ -128,15 +140,9 @@ ppr_ty ctxt_prec ty@(TyConApp tycon tys)
        other          -> maybeParen ctxt_prec tYCON_PREC 
                                     (ppr tycon <+> ppr_ty tYCON_PREC ty)
 
-       -- USAGE CASE
-  | (tycon `hasKey` usOnceTyConKey || tycon `hasKey` usManyTyConKey),
-    null tys
-  =    -- For usages (! and .), always print bare OccName, without pkg/mod/uniq
-    ppr (getOccName (tyConName tycon))
-       
        -- TUPLE CASE (boxed and unboxed)
   |  isTupleTyCon tycon,
-     length tys == tyConArity tycon    -- No magic if partially applied
+      tys `lengthIs` tyConArity tycon  -- No magic if partially applied
   = tupleParens (tupleTyConBoxity tycon)
                (sep (punctuate comma (map (ppr_ty tOP_PREC) tys)))
 
@@ -145,10 +151,18 @@ ppr_ty ctxt_prec ty@(TyConApp tycon tys)
     [ty] <- tys
   = brackets (ppr_ty tOP_PREC ty)
 
+       -- PARALLEL ARRAY CASE
+  | tycon `hasKey` parrTyConKey,
+    [ty] <- tys
+  = pabrackets (ppr_ty tOP_PREC ty)
+
        -- GENERAL CASE
   | otherwise
   = ppr_tc_app ctxt_prec tycon tys
 
+  where
+    pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")
+
 
 ppr_ty ctxt_prec ty@(ForAllTy _ _)
   = getPprStyle $ \ sty -> 
@@ -159,13 +173,7 @@ ppr_ty ctxt_prec ty@(ForAllTy _ _)
     ]
  where         
     (tyvars, theta, tau) = tcSplitSigmaTy ty
-    
-    pp_tyvars sty = sep (map pprTyVarBndr some_tyvars)
-      where
-        some_tyvars | userStyle sty && not opt_PprStyle_RawTypes
-                    = filter (not . isUTyVar) tyvars  -- hide uvars from user
-                    | otherwise
-                    = tyvars
+    pp_tyvars sty       = sep (map pprTyVarBndr tyvars)
     
     ppr_theta []     = empty
     ppr_theta theta  = pprTheta theta <+> ptext SLIT("=>")
@@ -185,12 +193,6 @@ ppr_ty ctxt_prec (AppTy ty1 ty2)
   = maybeParen ctxt_prec tYCON_PREC $
     ppr_ty fUN_PREC ty1 <+> ppr_ty tYCON_PREC ty2
 
-ppr_ty ctxt_prec (UsageTy u ty)
-  = maybeParen ctxt_prec tYCON_PREC $
-    ptext SLIT("__u") <+> ppr_ty tYCON_PREC u
-                      <+> ppr_ty tYCON_PREC ty
-    -- fUN_PREC would be logical for u, but it yields a reduce/reduce conflict with AppTy
-
 ppr_ty ctxt_prec (NoteTy (SynNote ty) expansion)
   = ppr_ty ctxt_prec ty
 --  = ppr_ty ctxt_prec expansion -- if we don't want to see syntys
@@ -219,7 +221,7 @@ and when in debug mode.
 pprTyVarBndr :: TyVar -> SDoc
 pprTyVarBndr tyvar
   = getPprStyle $ \ sty ->
-    if (ifaceStyle sty  && not (kind `eqKind` liftedTypeKind)) || debugStyle sty then
+    if debugStyle sty then
         hsep [ppr tyvar, dcolon, pprParendKind kind]
                -- See comments with ppDcolon in PprCore.lhs
     else
@@ -249,7 +251,7 @@ getTyDescription ty
       TyVarTy _                     -> "*"
       AppTy fun _                   -> getTyDescription fun
       FunTy _ res                   -> '-' : '>' : fun_result res
-      TyConApp tycon _              -> getOccString tycon
+      TyConApp tycon _              -> occNameUserString (getOccName tycon)
       NoteTy (FTVNote _) ty  -> getTyDescription ty
       NoteTy (SynNote ty1) _ -> getTyDescription ty1
       SourceTy sty          -> getSourceTyDescription sty
@@ -261,7 +263,7 @@ getTyDescription ty
 
 getSourceTyDescription (ClassP cl tys) = getOccString cl
 getSourceTyDescription (NType  tc tys) = getOccString tc
-getSourceTyDescription (IParam id ty)  = getOccString id
+getSourceTyDescription (IParam ip ty)  = getOccString (ipNameName ip)
 \end{code}