projects / ghc-hetmet.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
[project @ 2002-09-25 11:09:11 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 45717e6..6755b0c 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,33 +18,28 @@ 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, UsageAnn(..),
-                         boxedTypeKind,
-                       )  -- friend
-import Type            ( PredType(..), ThetaType,
-                         splitPredTy_maybe,
-                         splitForAllTys, splitSigmaTy, splitRhoTy,
-                         isDictTy, splitTyConApp_maybe, splitFunTy_maybe,
-                          splitUsForAllTys
-                       )
-import Var             ( TyVar, tyVarKind,
-                         tyVarName, setTyVarName
-                       )
-import VarEnv
-import TyCon           ( TyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, 
+import TypeRep         ( Type(..), TyNote(..), Kind  ) -- friend
+import Type            ( SourceType(..) )
+import TcType          ( ThetaType, PredType,
+                         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, className )
 
 -- 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}
 
 %************************************************************************
@@ -60,25 +55,39 @@ 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 [ppr n, ptext SLIT("::"), ppr ty]
+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)
 
 
-pprConstraint :: Class -> [Type] -> SDoc
-pprConstraint clas tys = ppr clas <+> hsep (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 pprPred theta)))
+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
 \end{code}
 
 
 \end{code}
 
 
@@ -100,9 +109,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
@@ -110,135 +119,93 @@ 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
-       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])
-                      
+                                    (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 `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)
+  | 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
-    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)
-  
+    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 $
-    sep [ ptext SLIT("forall") <+> pp_tyvars <> ptext SLIT("."), 
+    sep [ ptext SLIT("forall") <+> pp_tyvars sty <> ptext SLIT("."), 
          ppr_theta theta,
          ppr_theta theta,
-         ppr_ty env tOP_PREC tau
+         ppr_ty tOP_PREC tau
     ]
  where         
     ]
  where         
-    (tyvars, rho) = splitForAllTys ty  -- don't treat theta specially any more (KSW 1999-04)
-    (theta, tau)  = splitRhoTy rho
+    (tyvars, theta, tau) = tcSplitSigmaTy ty
+    pp_tyvars sty       = sep (map pprTyVarBndr tyvars)
     
     
-    pp_tyvars = hsep (map (pBndr env LambdaBind) tyvars)
-    
-    ppr_theta []       = empty
-    ppr_theta theta     = parens (hsep (punctuate comma (map ppr_pred theta))) 
-                         <+> ptext SLIT("=>")
+    ppr_theta []     = empty
+    ppr_theta theta  = pprTheta theta <+> ptext SLIT("=>")
 
 
-    ppr_pred (Class clas tys) = ppr clas <+> hsep (map (ppr_ty env tYCON_PREC) tys)
-    ppr_pred (IParam n ty)    = hsep [{- char '?' <> -} ppr n, text "::",
-                                     ppr_ty env tYCON_PREC ty]
 
 
-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 tYCON_PREC $
-    ppr_ty env tOP_PREC ty1 <+> ppr_ty env 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 env ctxt_prec (NoteTy (FTVNote _) ty) = ppr_ty env ctxt_prec ty
-
-ppr_ty env ctxt_prec ty@(NoteTy (UsgForAll _) _)
   = maybeParen ctxt_prec fUN_PREC $
   = maybeParen ctxt_prec fUN_PREC $
-    sep [ ptext SLIT("__fuall") <+> brackets pp_uvars <+> ptext SLIT("=>"),
-          ppr_ty env tOP_PREC sigma
+    sep [ ppr_ty fUN_PREC ty1
+        , ptext arrow <+> ppr_ty tOP_PREC ty2
         ]
         ]
-  where
-    (uvars,sigma) = splitUsForAllTys ty
-    pp_uvars      = hsep (map ppr uvars)
+  where arrow | isPredTy ty1 = SLIT("=>")
+             | otherwise    = SLIT("->")
 
 
-ppr_ty env ctxt_prec (NoteTy (UsgNote u) ty)
+ppr_ty ctxt_prec (AppTy ty1 ty2)
   = maybeParen ctxt_prec tYCON_PREC $
   = maybeParen ctxt_prec tYCON_PREC $
-    ptext SLIT("__u") <+> ppr u <+> ppr_ty env tYCON_PREC ty
-
-ppr_ty env ctxt_prec (NoteTy (IPNote nm) ty)
-  = braces (ppr_pred env (IParam nm ty))
+    ppr_ty fUN_PREC ty1 <+> ppr_ty tYCON_PREC ty2
 
 
-ppr_theta env []    = empty
-ppr_theta env theta = braces (hsep (punctuate comma (map (ppr_pred env) theta)))
+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_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 (NoteTy (FTVNote _) ty) = ppr_ty ctxt_prec ty
 
 
-\begin{code}
-pprTyEnv = initPprEnv b (Just ppr) b (Just (\site -> pprTyVarBndr)) b
-  where
-    b = panic "PprType:init_ppr_env"
-\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}
-instance Outputable UsageAnn where
-  ppr UsOnce     = ptext SLIT("-")
-  ppr UsMany     = ptext SLIT("!")
-  ppr (UsVar uv) = ppr uv
+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}
 
 
@@ -252,9 +219,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 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
@@ -279,20 +247,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}
 
 
@@ -321,8 +293,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 '.'
 
@@ -339,7 +311,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'
Glasgow Haskell Compiler with heterogeneous metaprogramming (generalized arrows and modal types)