[project @ 2001-09-04 18:29:20 by ken]

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

diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs
index 87ddcfa..25348d0 100644 (file)
--- a/ghc/compiler/types/PprType.lhs
+++ b/ghc/compiler/types/PprType.lhs
@@ -7,7 +7,7 @@
 module PprType(
        pprKind, pprParendKind,
        pprType, pprParendType,
 module PprType(
        pprKind, pprParendKind,
        pprType, pprParendType,

-       pprConstraint, pprPred, pprTheta,
+       pprSourceType, pprPred, pprTheta, pprClassPred,

        pprTyVarBndr, pprTyVarBndrs,
 
        -- Junk
        pprTyVarBndr, pprTyVarBndrs,
 
        -- Junk

@@ -18,26 +18,24 @@ module PprType(
 
 -- friends:
 -- (PprType can see all the representations it's trying to print)
 
 -- friends:
 -- (PprType can see all the representations it's trying to print)

-import TypeRep         ( Type(..), TyNote(..), Kind, boxedTypeKind )  -- friend
-import Type            ( PredType(..), ThetaType,
-                         splitPredTy_maybe,
-                         splitForAllTys, splitSigmaTy, splitRhoTy,
-                         isDictTy, splitTyConApp_maybe, splitFunTy_maybe,
-                          predRepTy, isUTyVar
-                       )
+import TypeRep         ( Type(..), TyNote(..), Kind, liftedTypeKind ) -- friend
+import Type            ( SourceType(..), isUTyVar, eqKind )
+import TcType          ( ThetaType, PredType, tcSplitPredTy_maybe, 
+                         tcSplitSigmaTy, isPredTy, isDictTy,
+                         tcSplitTyConApp_maybe, tcSplitFunTy_maybe
+                       ) 

 import Var             ( TyVar, tyVarKind )
 import Var             ( TyVar, tyVarKind )

+import Class           ( Class )

 import TyCon           ( TyCon, isPrimTyCon, isTupleTyCon, tupleTyConBoxity,
                          maybeTyConSingleCon, isEnumerationTyCon, 
                          tyConArity, tyConName
                        )
 import TyCon           ( TyCon, isPrimTyCon, isTupleTyCon, tupleTyConBoxity,
                          maybeTyConSingleCon, isEnumerationTyCon, 
                          tyConArity, tyConName
                        )

-import Class           ( Class )

 
 -- others:
 import CmdLineOpts     ( opt_PprStyle_RawTypes )
 import Maybes          ( maybeToBool )
 import Name            ( getOccString, getOccName )
 import Outputable
 
 -- others:
 import CmdLineOpts     ( opt_PprStyle_RawTypes )
 import Maybes          ( maybeToBool )
 import Name            ( getOccString, getOccName )
 import Outputable

-import PprEnv

 import Unique          ( Uniquable(..) )
 import BasicTypes      ( tupleParens )
 import PrelNames               -- quite a few *Keys
 import Unique          ( Uniquable(..) )
 import BasicTypes      ( tupleParens )
 import PrelNames               -- quite a few *Keys

@@ -56,20 +54,24 @@ works just by setting the initial context precedence very high.
 
 \begin{code}
 pprType, pprParendType :: Type -> SDoc
 
 \begin{code}
 pprType, pprParendType :: Type -> SDoc

-pprType       ty = ppr_ty pprTyEnv tOP_PREC   ty
-pprParendType ty = ppr_ty pprTyEnv tYCON_PREC ty
+pprType       ty = ppr_ty tOP_PREC   ty
+pprParendType ty = ppr_ty tYCON_PREC ty

 
 pprKind, pprParendKind :: Kind -> SDoc
 pprKind       = pprType
 pprParendKind = pprParendType
 
 pprPred :: PredType -> SDoc
 
 pprKind, pprParendKind :: Kind -> SDoc
 pprKind       = pprType
 pprParendKind = pprParendType
 
 pprPred :: PredType -> SDoc

-pprPred (Class clas tys) = pprConstraint clas tys
-pprPred (IParam n ty)    = hsep [ptext SLIT("?") <> ppr n,
-                                ptext SLIT("::"), ppr ty]
+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)

 
 

-pprConstraint :: Class -> [Type] -> SDoc
-pprConstraint clas tys = ppr clas <+> hsep (map pprParendType tys)
+pprClassPred :: Class -> [Type] -> SDoc
+pprClassPred clas tys = ppr clas <+> hsep (map pprParendType tys)

 
 pprTheta :: ThetaType -> SDoc
 pprTheta theta = parens (hsep (punctuate comma (map pprPred theta)))
 
 pprTheta :: ThetaType -> SDoc
 pprTheta theta = parens (hsep (punctuate comma (map pprPred theta)))

@@ -110,118 +112,97 @@ maybeParen ctxt_prec inner_prec pretty
 \end{code}
 
 \begin{code}
 \end{code}
 
 \begin{code}

-ppr_ty :: PprEnv TyVar -> Int -> Type -> SDoc
-ppr_ty env ctxt_prec (TyVarTy tyvar)
-  = pTyVarO env tyvar
+ppr_ty :: Int -> Type -> SDoc
+ppr_ty ctxt_prec (TyVarTy tyvar)
+  = ppr tyvar

 
 

-ppr_ty env ctxt_prec ty@(TyConApp tycon tys)
+ppr_ty ctxt_prec ty@(TyConApp tycon tys)

        -- KIND CASE; it's of the form (Type x)
        -- KIND CASE; it's of the form (Type x)

-  | tycon `hasKey` typeConKey && n_tys == 1
+  | tycon `hasKey` typeConKey,
+    [ty] <- tys

   =    -- For kinds, print (Type x) as just x if x is a 
        --      type constructor (must be Boxed, Unboxed, AnyBox)
        -- Otherwise print as (Type x)
   =    -- For kinds, print (Type x) as just x if x is a 
        --      type constructor (must be Boxed, Unboxed, AnyBox)
        -- Otherwise print as (Type x)

-    case ty1 of
+    case ty of

        TyConApp bx [] -> ppr (getOccName bx)   -- Always unqualified
        other          -> maybeParen ctxt_prec tYCON_PREC 
        TyConApp bx [] -> ppr (getOccName bx)   -- Always unqualified
        other          -> maybeParen ctxt_prec tYCON_PREC 

-                                    (sep [ppr tycon, nest 4 tys_w_spaces])
+                                    (ppr tycon <+> ppr_ty tYCON_PREC ty)

 
        -- USAGE CASE
 
        -- USAGE CASE

-  | (tycon `hasKey` usOnceTyConKey || tycon `hasKey` usManyTyConKey) && n_tys == 0
+  | (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)
   =    -- 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
-  = tupleParens (tupleTyConBoxity tycon) tys_w_commas
+  |  isTupleTyCon tycon,
+     length tys == tyConArity tycon    -- No magic if partially applied
+  = tupleParens (tupleTyConBoxity tycon)
+               (sep (punctuate comma (map (ppr_ty tOP_PREC) tys)))

 
        -- LIST CASE
 
        -- LIST CASE

-  | tycon `hasKey` listTyConKey && n_tys == 1
-  = brackets (ppr_ty env tOP_PREC ty1)
-
-       -- DICTIONARY CASE, prints {C a}
-       -- This means that instance decls come out looking right in interfaces
-       -- and that in turn means they get "gated" correctly when being slurped in
-  | maybeToBool maybe_pred
-  = braces (ppr_pred env pred)
-
-       -- NO-ARGUMENT CASE (=> no parens)
-  | null tys
-  = ppr tycon
+  | tycon `hasKey` listTyConKey,
+    [ty] <- tys
+  = brackets (ppr_ty tOP_PREC ty)

 
        -- GENERAL CASE
   | otherwise
 
        -- GENERAL CASE
   | otherwise

-  = maybeParen ctxt_prec tYCON_PREC (sep [ppr tycon, nest 4 tys_w_spaces])
+  = ppr_tc_app ctxt_prec tycon tys

 
 

-  where
-    n_tys      = length tys
-    (ty1:_)    = tys
-    Just pred  = maybe_pred
-    maybe_pred = splitPredTy_maybe ty  -- Checks class and arity
-    tys_w_commas = sep (punctuate comma (map (ppr_ty env tOP_PREC) tys))
-    tys_w_spaces = sep (map (ppr_ty env tYCON_PREC) tys)
-  

 
 

-
-ppr_ty env ctxt_prec ty@(ForAllTy _ _)
+ppr_ty ctxt_prec ty@(ForAllTy _ _)

   = getPprStyle $ \ sty -> 
     maybeParen ctxt_prec fUN_PREC $
     sep [ ptext SLIT("forall") <+> pp_tyvars sty <> ptext SLIT("."), 
          ppr_theta theta,
   = getPprStyle $ \ sty -> 
     maybeParen ctxt_prec fUN_PREC $
     sep [ ptext SLIT("forall") <+> pp_tyvars sty <> ptext SLIT("."), 
          ppr_theta theta,

-         ppr_ty env tOP_PREC tau
+         ppr_ty tOP_PREC tau

     ]
  where         
     ]
  where         

-    (tyvars, rho) = splitForAllTys ty
-    (theta, tau)  = splitRhoTy rho
+    (tyvars, theta, tau) = tcSplitSigmaTy ty

     
     

-    pp_tyvars sty = hsep (map (pBndr env LambdaBind) some_tyvars)
+    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
     
       where
         some_tyvars | userStyle sty && not opt_PprStyle_RawTypes
                     = filter (not . isUTyVar) tyvars  -- hide uvars from user
                     | otherwise
                     = tyvars
     

-    ppr_theta []       = empty
-    ppr_theta theta     = parens (hsep (punctuate comma (map (ppr_pred env) theta))) 
-                         <+> ptext SLIT("=>")
+    ppr_theta []     = empty
+    ppr_theta theta  = pprTheta theta <+> ptext SLIT("=>")

 
 
 
 

-ppr_ty env ctxt_prec (FunTy ty1 ty2)
+ppr_ty ctxt_prec (FunTy ty1 ty2)

   -- we don't want to lose usage annotations or synonyms,
   -- so we mustn't use splitFunTys here.
   = maybeParen ctxt_prec fUN_PREC $
   -- we don't want to lose usage annotations or synonyms,
   -- so we mustn't use splitFunTys here.
   = maybeParen ctxt_prec fUN_PREC $

-    sep [ ppr_ty env fUN_PREC ty1
-        , ptext SLIT("->") <+> ppr_ty env tOP_PREC ty2
+    sep [ ppr_ty fUN_PREC ty1
+        , ptext arrow <+> ppr_ty tOP_PREC ty2

         ]
         ]

+  where arrow | isPredTy ty1 = SLIT("=>")
+             | otherwise    = SLIT("->")

 
 

-ppr_ty env ctxt_prec (AppTy ty1 ty2)
+ppr_ty ctxt_prec (AppTy ty1 ty2)

   = maybeParen ctxt_prec tYCON_PREC $
   = maybeParen ctxt_prec tYCON_PREC $

-    ppr_ty env fUN_PREC ty1 <+> ppr_ty env tYCON_PREC ty2
+    ppr_ty fUN_PREC ty1 <+> ppr_ty tYCON_PREC ty2

 
 

-ppr_ty env ctxt_prec (UsageTy u ty)
+ppr_ty ctxt_prec (UsageTy u ty)

   = maybeParen ctxt_prec tYCON_PREC $
   = maybeParen ctxt_prec tYCON_PREC $

-    ptext SLIT("__u") <+> ppr_ty env tYCON_PREC u
-                      <+> ppr_ty env tYCON_PREC ty
+    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
 
     -- fUN_PREC would be logical for u, but it yields a reduce/reduce conflict with AppTy
 

-ppr_ty env ctxt_prec (NoteTy (SynNote ty) expansion)
-  = ppr_ty env ctxt_prec ty
---  = ppr_ty env ctxt_prec expansion -- if we don't want to see syntys
-
-ppr_ty env ctxt_prec (NoteTy (FTVNote _) ty) = ppr_ty env ctxt_prec ty
+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

 
 

-ppr_ty env ctxt_prec (PredTy p) = braces (ppr_pred env p)
+ppr_ty ctxt_prec (NoteTy (FTVNote _) ty) = ppr_ty ctxt_prec ty

 
 

-ppr_pred env (Class clas tys) = ppr clas <+>
-                               hsep (map (ppr_ty env tYCON_PREC) tys)
-ppr_pred env (IParam n ty)    = hsep [char '?' <> ppr n, text "::",
-                                     ppr_ty env tYCON_PREC ty]
-\end{code}
+ppr_ty ctxt_prec (SourceTy (NType tc tys)) = ppr_tc_app ctxt_prec tc tys
+ppr_ty ctxt_prec (SourceTy pred)          = braces (pprPred pred)

 
 

-\begin{code}
-pprTyEnv = initPprEnv b (Just ppr) b (Just (\site -> pprTyVarBndr)) b
-  where
-    b = panic "PprType:init_ppr_env"
+ppr_tc_app ctxt_prec tc []  = ppr tc
+ppr_tc_app ctxt_prec tc tys = maybeParen ctxt_prec tYCON_PREC 
+                                        (sep [ppr tc, nest 4 (sep (map (ppr_ty tYCON_PREC) tys))])

 \end{code}
 
 
 \end{code}
 
 

@@ -235,9 +216,10 @@ We print type-variable binders with their kinds in interface files,
 and when in debug mode.
 
 \begin{code}
 and when in debug mode.
 
 \begin{code}

+pprTyVarBndr :: TyVar -> SDoc

 pprTyVarBndr tyvar
   = getPprStyle $ \ sty ->
 pprTyVarBndr tyvar
   = getPprStyle $ \ sty ->

-    if (ifaceStyle sty  && kind /= boxedTypeKind) || debugStyle sty then
+    if (ifaceStyle sty  && not (kind `eqKind` liftedTypeKind)) || debugStyle sty then

         hsep [ppr tyvar, dcolon, pprParendKind kind]
                -- See comments with ppDcolon in PprCore.lhs
     else
         hsep [ppr tyvar, dcolon, pprParendKind kind]
                -- See comments with ppDcolon in PprCore.lhs
     else

@@ -262,20 +244,24 @@ description for profiling.
 getTyDescription :: Type -> String
 
 getTyDescription ty
 getTyDescription :: Type -> String
 
 getTyDescription ty

-  = case (splitSigmaTy ty) of { (_, _, tau_ty) ->
+  = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->

     case tau_ty of
     case tau_ty of

-      TyVarTy _               -> "*"
-      AppTy fun _      -> getTyDescription fun
-      FunTy _ res      -> '-' : '>' : fun_result res
-      TyConApp tycon _ -> getOccString tycon
+      TyVarTy _                     -> "*"
+      AppTy fun _                   -> getTyDescription fun
+      FunTy _ res                   -> '-' : '>' : fun_result res
+      TyConApp tycon _              -> getOccString tycon

       NoteTy (FTVNote _) ty  -> getTyDescription ty
       NoteTy (SynNote ty1) _ -> getTyDescription ty1
       NoteTy (FTVNote _) ty  -> getTyDescription ty
       NoteTy (SynNote ty1) _ -> getTyDescription ty1

-      PredTy p              -> getTyDescription (predRepTy p)
-      ForAllTy _ ty    -> getTyDescription ty
+      SourceTy sty          -> getSourceTyDescription sty
+      ForAllTy _ ty          -> getTyDescription ty

     }
   where
     fun_result (FunTy _ res) = '>' : fun_result res
     fun_result other        = getTyDescription other
     }
   where
     fun_result (FunTy _ res) = '>' : fun_result res
     fun_result other        = getTyDescription other

+
+getSourceTyDescription (ClassP cl tys) = getOccString cl
+getSourceTyDescription (NType  tc tys) = getOccString tc
+getSourceTyDescription (IParam id ty)  = getOccString id

 \end{code}
 
 
 \end{code}
 
 

@@ -304,8 +290,8 @@ showTypeCategory ty
   = if isDictTy ty
     then '+'
     else
   = if isDictTy ty
     then '+'
     else

-      case splitTyConApp_maybe ty of
-       Nothing -> if maybeToBool (splitFunTy_maybe ty)
+      case tcSplitTyConApp_maybe ty of
+       Nothing -> if maybeToBool (tcSplitFunTy_maybe ty)

                   then '>'
                   else '.'
 
                   then '>'
                   else '.'
 

@@ -322,7 +308,7 @@ showTypeCategory ty
                || utc == addrPrimTyConKey)                then 'i'
          else if utc  == floatPrimTyConKey                then 'f'
          else if utc  == doublePrimTyConKey               then 'd'
                || utc == addrPrimTyConKey)                then 'i'
          else if utc  == floatPrimTyConKey                then 'f'
          else if utc  == doublePrimTyConKey               then 'd'

-         else if isPrimTyCon tycon {- array, we hope -}   then 'A'
+         else if isPrimTyCon tycon {- array, we hope -}   then 'A'     -- Bogus

          else if isEnumerationTyCon tycon                 then 'E'
          else if isTupleTyCon tycon                       then 'T'
          else if maybeToBool (maybeTyConSingleCon tycon)  then 'S'
          else if isEnumerationTyCon tycon                 then 'E'
          else if isTupleTyCon tycon                       then 'T'
          else if maybeToBool (maybeTyConSingleCon tycon)  then 'S'