Add the function TypeRep.pprTypeApp, and use it

  pprTypeApp :: SDoc -> [Type] -> SDoc
  pprTypeApp pp tys = hang pp 2 (sep (map pprParendType tys))

diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 966976b..5c0dbcd 100644 (file)
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -142,7 +142,8 @@ module GHC (
        instanceDFunId, pprInstance, pprInstanceHdr,
 
        -- ** Types and Kinds
-       Type, dropForAlls, splitForAllTys, funResultTy, pprParendType,
+       Type, dropForAlls, splitForAllTys, funResultTy, 
+       pprParendType, pprTypeApp,
        Kind,
        PredType,
        ThetaType, pprThetaArrow,
@@ -189,6 +190,7 @@ import RdrName              ( plusGlobalRdrEnv, Provenance(..),
 import HscMain         ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
 import Name            ( nameOccName )
 import Type            ( tidyType )
+import Var             ( varName )
 import VarEnv          ( emptyTidyEnv )
 import GHC.Exts         ( unsafeCoerce# )
 
@@ -218,14 +220,14 @@ import RdrName            ( GlobalRdrEnv, GlobalRdrElt(..), RdrName(..),
 import HsSyn 
 import Type            ( Kind, Type, dropForAlls, PredType, ThetaType,
                          pprThetaArrow, pprParendType, splitForAllTys,
-                         funResultTy )
+                         pprTypeApp, funResultTy )
 import Id              ( Id, idType, isImplicitId, isDeadBinder,
                           isExportedId, isLocalId, isGlobalId,
                           isRecordSelector, recordSelectorFieldLabel,
                           isPrimOpId, isFCallId, isClassOpId_maybe,
                           isDataConWorkId, idDataCon,
                           isBottomingId )
-import Var             ( TyVar, varName )
+import Var             ( TyVar )
 import TysPrim         ( alphaTyVars )
 import TyCon           ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon,
                          isPrimTyCon, isFunTyCon, isOpenTyCon, tyConArity,

diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs
index ea97495..51144ec 100644 (file)
--- a/compiler/main/PprTyThing.hs
+++ b/compiler/main/PprTyThing.hs
@@ -158,7 +158,7 @@ pprDataConDecl exts gadt_style show_label dataCon
 
        -- printing out the dataCon as a type signature, in GADT style
     pp_tau = foldr add pp_res_ty tys_w_strs
-    pp_res_ty = ppr_bndr tyCon <+> hsep (map GHC.pprParendType res_tys)
+    pp_res_ty = GHC.pprTypeApp (ppr_bndr tyCon) res_tys
     add (str,ty) pp_ty = pprBangTy str ty <+> arrow <+> pp_ty
 
     pprParendBangTy (strict,ty)

diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index 0972530..ff49db6 100644 (file)
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -686,7 +686,7 @@ wrongThingErr expected thing name
                ptext SLIT("used as a") <+> text expected)
 
 famInstNotFound tycon tys what
-  = failWithTc (msg <+> quotes (ppr tycon <+> hsep (map pprParendType tys)))
+  = failWithTc (msg <+> quotes (pprTypeApp (ppr tycon) tys))
   where
     msg = ptext $ if length what > 1 
                  then SLIT("More than one family instance for")

diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 3d42498..e7083ac 100644 (file)
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -122,7 +122,7 @@ module TcType (
   tcTyVarsOfType, tcTyVarsOfTypes, exactTyVarsOfType, exactTyVarsOfTypes,
 
   pprKind, pprParendKind,
-  pprType, pprParendType, pprTyThingCategory,
+  pprType, pprParendType, pprTypeApp, pprTyThingCategory,
   pprPred, pprTheta, pprThetaArrow, pprClassPred
 
   ) where

diff --git a/compiler/types/FamInstEnv.lhs b/compiler/types/FamInstEnv.lhs
index b9276b7..60b55d1 100644 (file)
--- a/compiler/types/FamInstEnv.lhs
+++ b/compiler/types/FamInstEnv.lhs
@@ -46,13 +46,19 @@ import Maybe
 \begin{code}
 data FamInst 
   = FamInst { fi_fam   :: Name         -- Family name
+               -- INVARIANT: fi_fam = case tyConFamInst_maybe fi_tycon of
+               --                         Just (tc, tys) -> tc
 
                -- Used for "rough matching"; same idea as for class instances
            , fi_tcs   :: [Maybe Name]  -- Top of type args
+               -- INVARIANT: fi_tcs = roughMatchTcs is_tys
 
                -- Used for "proper matching"; ditto
            , fi_tvs   :: TyVarSet      -- Template tyvars for full match
            , fi_tys   :: [Type]        -- Full arg types
+               -- INVARIANT: fi_tvs = tyConTyVars fi_tycon
+               --            fi_tys = case tyConFamInst_maybe fi_tycon of
+               --                         Just (_, tys) -> tys
 
            , fi_tycon :: TyCon         -- Representation tycon
            }
@@ -82,8 +88,7 @@ pprFamInstHdr :: FamInst -> SDoc
 pprFamInstHdr (FamInst {fi_fam = fam, fi_tys = tys, fi_tycon = tycon})
   = pprTyConSort <+> pprHead
   where
-    pprHead = parenSymOcc (getOccName fam) (ppr fam) <+> 
-             sep (map pprParendType tys)
+    pprHead = pprTypeApp (parenSymOcc (getOccName fam) (ppr fam)) tys
     pprTyConSort | isDataTyCon tycon = ptext SLIT("data instance")
                 | isNewTyCon  tycon = ptext SLIT("newtype instance")
                 | isSynTyCon  tycon = ptext SLIT("type instance")

diff --git a/compiler/types/Type.lhs b/compiler/types/Type.lhs
index 147f546..fd81795 100644 (file)
--- a/compiler/types/Type.lhs
+++ b/compiler/types/Type.lhs
@@ -95,7 +95,7 @@ module Type (
        substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar,
 
        -- Pretty-printing
-       pprType, pprParendType, pprTyThingCategory, pprForAll,
+       pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprForAll,
        pprPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind
     ) where
 
@@ -611,11 +611,14 @@ tyConOrigHead tycon = case tyConFamInst_maybe tycon of
                        Just famInst -> famInst
 
 -- Pretty prints a tycon, using the family instance in case of a
--- representation tycon.
-pprSourceTyCon tycon | Just (repTyCon, tys) <- tyConFamInst_maybe tycon =
-  ppr $ repTyCon `TyConApp` tys               -- can't be FunTyCon
-                     | otherwise                                        =
-  ppr tycon
+-- representation tycon.  For example
+--     e.g.  data T [a] = ...
+-- In that case we want to print `T [a]', where T is the family TyCon
+pprSourceTyCon tycon 
+  | Just (repTyCon, tys) <- tyConFamInst_maybe tycon
+  = ppr $ repTyCon `TyConApp` tys             -- can't be FunTyCon
+  | otherwise
+  = ppr tycon
 \end{code}
 
 

diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 6a9c609..cc8e4be 100644 (file)
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -15,7 +15,8 @@ module TypeRep (
        funTyCon,
 
        -- Pretty-printing
-       pprType, pprParendType, pprTyThingCategory, 
+       pprType, pprParendType, pprTypeApp,
+       pprTyThingCategory, 
        pprPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred,
 
        -- Kinds
@@ -432,6 +433,9 @@ pprType, pprParendType :: Type -> SDoc
 pprType       ty = ppr_type TopPrec   ty
 pprParendType ty = ppr_type TyConPrec ty
 
+pprTypeApp :: SDoc -> [Type] -> SDoc
+pprTypeApp pp tys = hang pp 2 (sep (map pprParendType tys))
+
 ------------------
 pprPred :: PredType -> SDoc
 pprPred (ClassP cls tys) = pprClassPred cls tys
@@ -439,8 +443,7 @@ pprPred (IParam ip ty)   = ppr ip <> dcolon <> pprType ty
 pprPred (EqPred ty1 ty2) = sep [ppr ty1, nest 2 (ptext SLIT("~")), ppr ty2]
 
 pprClassPred :: Class -> [Type] -> SDoc
-pprClassPred clas tys = parenSymOcc (getOccName clas) (ppr clas) 
-                       <+> sep (map pprParendType tys)
+pprClassPred clas tys = pprTypeApp (parenSymOcc (getOccName clas) (ppr clas)) tys
 
 pprTheta :: ThetaType -> SDoc
 pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
@@ -520,8 +523,7 @@ ppr_tc_app p tc tys
   | isTupleTyCon tc && tyConArity tc == length tys
   = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys)))
   | otherwise
-  = maybeParen p TyConPrec $
-    ppr_tc tc <+> sep (map (ppr_type TyConPrec) tys)
+  = maybeParen p TyConPrec (pprTypeApp (ppr_tc tc) tys)
 
 ppr_tc :: TyCon -> SDoc
 ppr_tc tc = parenSymOcc (getOccName tc) (pp_nt_debug <> ppr tc)