[project @ 2003-08-06 15:26:02 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 8c29300..4a04bff 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, pprTheta,
+       pprSourceType, pprPred, pprTheta, pprClassPred,

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

@@ -18,30 +18,27 @@ 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 Type            ( Type(..), TyNote(..), Kind, ThetaType, UsageAnn(..),
-                         splitDictTy_maybe,
-                         splitForAllTys, splitSigmaTy, splitRhoTy,
-                         isDictTy, splitTyConApp_maybe, splitFunTy_maybe,
-                         boxedTypeKind
-                       )
-import Var             ( TyVar, tyVarKind,
-                         tyVarName, setTyVarName
-                       )
-import VarEnv
-import TyCon           ( TyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, 
-                         maybeTyConSingleCon, isEnumerationTyCon, 
-                         tyConArity, tyConUnique
-                       )
+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 Class           ( Class )

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

 
 -- others:
 import Maybes          ( maybeToBool )
 
 -- others:
 import Maybes          ( maybeToBool )

-import Name            ( getOccString, NamedThing(..) )
+import Name            ( getOccString, getOccName )
+import OccName         ( occNameUserString )

 import Outputable
 import Outputable

-import PprEnv

 import Unique          ( Uniquable(..) )
 import Unique          ( Uniquable(..) )

-import Unique          -- quite a few *Keys
-import Util
+import Util             ( lengthIs )
+import BasicTypes      ( IPName(..), tupleParens, ipNameName )
+import PrelNames               -- quite a few *Keys

 \end{code}
 
 %************************************************************************
 \end{code}
 
 %************************************************************************

@@ -57,23 +54,45 @@ 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
 
 
 pprKind, pprParendKind :: Kind -> SDoc
 pprKind       = pprType
 pprParendKind = pprParendType
 

-pprConstraint :: Class -> [Type] -> SDoc
-pprConstraint clas tys = ppr clas <+> hsep (map (pprParendType) tys)
+pprPred :: PredType -> SDoc
+pprPred = pprSourceType
+
+pprSourceType :: SourceType -> SDoc
+pprSourceType (ClassP clas tys) = pprClassPred clas 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 <+> sep (map pprParendType tys)

 
 pprTheta :: ThetaType -> SDoc
 
 pprTheta :: ThetaType -> SDoc

-pprTheta theta = parens (hsep (punctuate comma (map ppr_dict theta)))
-              where
-                ppr_dict (c,tys) = pprConstraint c tys
+pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))

 
 instance Outputable Type where
     ppr ty = pprType ty
 
 instance Outputable Type where
     ppr ty = pprType ty

+
+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}
 
 
 \end{code}
 
 

@@ -95,9 +114,9 @@ The precedence levels are:
 
 
 \begin{code}
 
 
 \begin{code}

-tOP_PREC    = (0 :: Int)
-fUN_PREC    = (1 :: Int)
-tYCON_PREC  = (2 :: Int)
+tOP_PREC    = (0 :: Int)  -- type   in ParseIface.y
+fUN_PREC    = (1 :: Int)  -- btype  in ParseIface.y
+tYCON_PREC  = (2 :: Int)  -- atype  in ParseIface.y

 
 maybeParen ctxt_prec inner_prec pretty
   | ctxt_prec < inner_prec = pretty
 
 maybeParen ctxt_prec inner_prec pretty
   | ctxt_prec < inner_prec = pretty

@@ -105,126 +124,89 @@ 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_uniq == 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
-       TyConApp bx [] -> ppr bx
+    case ty of
+       TyConApp bx [] -> ppr (getOccName bx)   -- Always unqualified

        other          -> maybeParen ctxt_prec tYCON_PREC 
        other          -> maybeParen ctxt_prec tYCON_PREC 

-                                    (sep [ppr tycon, nest 4 tys_w_spaces])
-                      
-       
-       -- TUPLE CASE (boxed and unboxed)
-  |  isTupleTyCon tycon
-  && length tys == tyConArity tycon    -- no magic if partially applied
-  = parens tys_w_commas
+                                    (ppr tycon <+> ppr_ty tYCON_PREC ty)

 
 

-  |  isUnboxedTupleTyCon tycon
-  && length tys == tyConArity tycon    -- no magic if partially applied
-  = parens (char '#' <+> tys_w_commas <+> char '#')
+       -- TUPLE CASE (boxed and unboxed)
+  |  isTupleTyCon tycon,
+      tys `lengthIs` tyConArity tycon  -- No magic if partially applied
+  = tupleParens (tupleTyConBoxity tycon)
+               (sep (punctuate comma (map (ppr_ty tOP_PREC) tys)))

 
        -- LIST CASE
 
        -- LIST CASE

-  | tycon_uniq == 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_dict
-  = braces (ppr_dict env tYCON_PREC ctys)
+  | tycon `hasKey` listTyConKey,
+    [ty] <- tys
+  = brackets (ppr_ty tOP_PREC ty)

 
 

-       -- NO-ARGUMENT CASE (=> no parens)
-  | null tys
-  = ppr tycon
+       -- PARALLEL ARRAY CASE
+  | tycon `hasKey` parrTyConKey,
+    [ty] <- tys
+  = pabrackets (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
 
   where

-    tycon_uniq = tyConUnique tycon
-    n_tys      = length tys
-    (ty1:_)    = tys
-    Just ctys  = maybe_dict
-    maybe_dict = splitDictTy_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)
-  
+    pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")

 
 
 
 

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

   = getPprStyle $ \ sty -> 
     maybeParen ctxt_prec fUN_PREC $
   = getPprStyle $ \ sty -> 
     maybeParen ctxt_prec fUN_PREC $

-    if ifaceStyle sty then
-       sep [ ptext SLIT("__forall") <+> brackets pp_tyvars <+> ptext SLIT("=>"), 
-            ppr_ty env tOP_PREC rho
-          ]
-    else
-       -- The type checker occasionally prints a type in an error message,
-       -- and it had better come out looking like a user type
-       sep [ ptext SLIT("forall") <+> pp_tyvars <> ptext SLIT("."), 
-            ppr_theta theta <+> ptext SLIT("=>"),
-            ppr_ty env tOP_PREC tau
-          ]
-  where                
-    (tyvars, rho) = splitForAllTys ty  -- don't treat theta specially any more (KSW 1999-04)
-    (theta, tau)  = splitRhoTy rho
-    
-    pp_tyvars = hsep (map (pBndr env LambdaBind) tyvars)
+    sep [ ptext SLIT("forall") <+> pp_tyvars sty <> ptext SLIT("."), 
+         ppr_theta theta,
+         ppr_ty tOP_PREC tau
+    ]
+ where         
+    (tyvars, theta, tau) = tcSplitSigmaTy ty
+    pp_tyvars sty       = sep (map pprTyVarBndr tyvars)

     
     

-    ppr_theta theta     = parens (hsep (punctuate comma (map ppr_dict theta)))
-    ppr_dict (clas,tys) = ppr clas <+> hsep (map (ppr_ty env tYCON_PREC) tys)
+    ppr_theta []     = empty
+    ppr_theta theta  = pprTheta theta <+> ptext SLIT("=>")

 
 
 
 

-ppr_ty env ctxt_prec (FunTy ty1 ty2)
-  = maybeParen ctxt_prec fUN_PREC (sep (ppr_ty env fUN_PREC ty1 : pp_rest 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.
   -- we don't want to lose usage annotations or synonyms,
   -- so we mustn't use splitFunTys here.

-  where
-    pp_rest (FunTy ty1 ty2) = pp_codom ty1 : pp_rest ty2
-    pp_rest ty              = [pp_codom ty]
-    pp_codom ty             = ptext SLIT("->") <+> ppr_ty env fUN_PREC ty
-
-ppr_ty env ctxt_prec (AppTy ty1 ty2)
+  = maybeParen ctxt_prec fUN_PREC $
+    sep [ ppr_ty fUN_PREC ty1
+        , ptext arrow <+> ppr_ty tOP_PREC ty2
+        ]
+  where arrow | isPredTy ty1 = SLIT("=>")
+             | otherwise    = SLIT("->")
+
+ppr_ty ctxt_prec (AppTy ty1 ty2)

   = maybeParen ctxt_prec tYCON_PREC $
   = maybeParen ctxt_prec tYCON_PREC $

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

 
 

-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 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 (NoteTy (FTVNote _) ty) = ppr_ty env ctxt_prec ty
+ppr_ty ctxt_prec (NoteTy (FTVNote _) ty) = ppr_ty ctxt_prec ty

 
 

-ppr_ty env ctxt_prec (NoteTy (UsgNote u) ty)
-  = maybeParen ctxt_prec tYCON_PREC $
-    ppr u <+> ppr_ty env tYCON_PREC ty
-
-ppr_theta env []    = empty
-ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_dict env tOP_PREC) theta)))
+ppr_ty ctxt_prec (SourceTy (NType tc tys)) = ppr_tc_app ctxt_prec tc tys
+ppr_ty ctxt_prec (SourceTy pred)          = braces (pprPred pred)

 
 

-ppr_dict env ctxt (clas, tys) = ppr clas <+> 
-                               hsep (map (ppr_ty env tYCON_PREC) tys)
+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}
 

-\begin{code}
-pprTyEnv = initPprEnv b b (Just ppr) b (Just (\site -> pprTyVarBndr)) b
-  where
-    b = panic "PprType:init_ppr_env"
-\end{code}
-
-\begin{code}
-instance Outputable UsageAnn where
-  ppr UsOnce     = ptext SLIT("__o")
-  ppr UsMany     = ptext SLIT("__m")
-  ppr (UsVar uv) = ptext SLIT("__uv") <> ppr uv
-\end{code}

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

@@ -236,9 +218,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 || debugStyle sty) && kind /= boxedTypeKind then
+    if 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

@@ -263,20 +246,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 _              -> occNameUserString (getOccName tycon)

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

-      NoteTy (UsgNote _) ty  -> getTyDescription ty
-      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 ip ty)  = getOccString (ipNameName ip)

 \end{code}
 
 
 \end{code}
 
 

@@ -305,8 +292,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 '.'
 

@@ -323,7 +310,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'