Improve pretty-printing of Core

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

diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index d536f59..51bc1f1 100644 (file)
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -14,11 +14,12 @@ module TyCon(
        SynTyConRhs(..),
 
        isFunTyCon, isUnLiftedTyCon, isProductTyCon, 
-       isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon,
+       isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isClosedNewTyCon,
+       isPrimTyCon, 
        isEnumerationTyCon, isGadtSyntaxTyCon, isOpenTyCon,
        assocTyConArgPoss_maybe, isTyConAssoc, setTyConArgPoss,
        isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
-       isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo,
+       isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo_maybe,
        isHiBootTyCon, isSuperKindTyCon,
         isCoercionTyCon_maybe, isCoercionTyCon,
 
@@ -60,7 +61,7 @@ module TyCon(
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} TypeRep ( Kind, Type, Coercion, PredType )
+import {-# SOURCE #-} TypeRep ( Kind, Type, PredType )
 import {-# SOURCE #-} DataCon ( DataCon, isVanillaDataCon )
 
 import Var             ( TyVar, Id )
@@ -100,6 +101,8 @@ data TyCon
        tyConTyVars :: [TyVar],         -- Scopes over (a) the algTcStupidTheta
                                        --             (b) the cached types in
                                        --                 algTyConRhs.NewTyCon
+                                       --             (c) the family instance
+                                       --                 types if present
                                        -- But not over the data constructors
 
         tyConArgPoss :: Maybe [Int],    -- for associated families: for each
@@ -191,10 +194,6 @@ data TyCon
         tyConName   :: Name
     }
 
-type KindCon = TyCon
-
-type SuperKindCon = TyCon
-
 type FieldLabel = Name
 
 data AlgTyConRhs
@@ -560,6 +559,14 @@ isNewTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of
                                           _            -> False
 isNewTyCon other                       = False
 
+-- This is an important refinement as typical newtype optimisations do *not*
+-- hold for newtype families.  Why?  Given a type `T a', if T is a newtype
+-- family, there is no unique right hand side by which `T a' can be replaced
+-- by a cast.
+--
+isClosedNewTyCon :: TyCon -> Bool
+isClosedNewTyCon tycon = isNewTyCon tycon && not (isOpenTyCon tycon)
+
 isProductTyCon :: TyCon -> Bool
 -- A "product" tycon
 --     has *one* constructor, 
@@ -747,12 +754,9 @@ newTyConRep :: TyCon -> ([TyVar], Type)
 newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_rep = rep }}) = (tvs, rep)
 newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon)
 
-newTyConCo :: TyCon -> Maybe TyCon
-newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon { nt_co = co }})
-  = co
-newTyConCo (AlgTyCon {tyConTyVars = tvs, algTcRhs = OpenNewTyCon})
-  = Nothing
-newTyConCo tycon = pprPanic "newTyConCo" (ppr tycon)
+newTyConCo_maybe :: TyCon -> Maybe TyCon
+newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = co
+newTyConCo_maybe _                                              = Nothing
 
 tyConPrimRep :: TyCon -> PrimRep
 tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep
@@ -807,8 +811,8 @@ tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas}) = Just clas
 tyConClass_maybe ther_tycon                                = Nothing
 
 isFamInstTyCon :: TyCon -> Bool
-isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _}) = True
-isFamInstTyCon other_tycon                                 = False
+isFamInstTyCon (AlgTyCon {algTcParent = FamilyTyCon _ _ _ }) = True
+isFamInstTyCon other_tycon                                  = False
 
 tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type])
 tyConFamInst_maybe (AlgTyCon {algTcParent = FamilyTyCon fam instTys _}) =