[project @ 2001-11-26 09:20:25 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 b3b3163..24cbb40 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,29 @@ 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, 
-                         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, 
+import TypeRep         ( Type(..), TyNote(..), IPName(..), 
+                         Kind, liftedTypeKind ) -- friend
+import Type            ( SourceType(..), isUTyVar, eqKind )
+import TcType          ( ThetaType, PredType, ipNameName,
+                         tcSplitSigmaTy, isPredTy, isDictTy,
+                         tcSplitTyConApp_maybe, tcSplitFunTy_maybe
+                       ) 
+import Var             ( TyVar, tyVarKind )
+import Class           ( Class )
+import TyCon           ( TyCon, isPrimTyCon, isTupleTyCon, tupleTyConBoxity,

                          maybeTyConSingleCon, isEnumerationTyCon, 
                          maybeTyConSingleCon, isEnumerationTyCon, 

-                         tyConArity, tyConUnique
+                         tyConArity, tyConName

                        )
                        )

-import Class           ( Class )

 
 -- others:
 
 -- others:

+import CmdLineOpts     ( opt_PprStyle_RawTypes )

 import Maybes          ( maybeToBool )
 import Maybes          ( maybeToBool )

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

 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      ( tupleParens )
+import PrelNames               -- quite a few *Keys

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

@@ -57,23 +56,36 @@ 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 <+> hsep (map pprParendType tys)
+
+pprClassPred :: Class -> [Type] -> SDoc
+pprClassPred clas tys = ppr clas <+> hsep (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 (hsep (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 (MustSplit n) = char '%' <> ppr n -- Splittable implicit parameters

 \end{code}
 
 
 \end{code}
 
 

@@ -95,9 +107,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,110 +117,99 @@ 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 

-                                    (ppr tycon <+> tys_w_spaces)
-                      
+                                    (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)
        
        -- TUPLE CASE (boxed and unboxed)

-  |  isTupleTyCon tycon
-  && length tys == tyConArity tycon    -- no magic if partially applied
-  = parens tys_w_commas
-
-  |  isUnboxedTupleTyCon tycon
-  && length tys == tyConArity tycon    -- no magic if partially applied
-  = parens (char '#' <+> tys_w_commas <+> char '#')
+  |  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)
-
-       -- 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 (hsep [ppr tycon, tys_w_spaces])
-
-  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 = hsep (map (ppr_ty env tYCON_PREC) tys)
-  
+  = ppr_tc_app ctxt_prec tycon tys

 
 
 
 

-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, pp_ctxt, pp_body ]
-    else
-       sep [ ptext SLIT("forall") <+> pp_tyvars <> ptext SLIT("."), pp_maybe_ctxt, pp_body ]
-  where                
-    (tyvars, rho_ty) = splitForAllTys ty
-    (theta, body_ty) = splitRhoTy rho_ty
+    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 = hsep (map (pBndr env LambdaBind) tyvars)
-    pp_body   = ppr_ty env tOP_PREC body_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_maybe_ctxt | null theta = empty
-                 | otherwise  = pp_ctxt
-
-    pp_ctxt = ppr_theta env theta <+> ptext SLIT("=>") 
+    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
+  = 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 $
+    ppr_ty fUN_PREC ty1 <+> ppr_ty tYCON_PREC ty2

 
 

-ppr_ty env ctxt_prec (AppTy ty1 ty2)
+ppr_ty ctxt_prec (UsageTy u ty)

   = maybeParen ctxt_prec tYCON_PREC $
   = maybeParen ctxt_prec tYCON_PREC $

-    ppr_ty env tOP_PREC ty1 <+> ppr_ty env tYCON_PREC ty2
+    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 env ctxt_prec (NoteTy (SynNote ty) expansion)
-  = 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 (NoteTy (FTVNote _) ty) = ppr_ty env ctxt_prec ty
+ppr_ty ctxt_prec (NoteTy (FTVNote _) ty) = ppr_ty ctxt_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}

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

@@ -220,9 +221,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 (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

@@ -247,19 +249,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

-      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}
 
 

@@ -288,8 +295,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 '.'
 

@@ -306,7 +313,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'