Add Data and Typeable instances to HsSyn

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

diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index 600b731..819a71c 100644 (file)
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -7,6 +7,7 @@
 \begin{code}
 -- We expose the relevant stuff from this module via the Type module
 {-# OPTIONS_HADDOCK hide #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 
 module TypeRep (
        TyThing(..), 
@@ -20,7 +21,7 @@ module TypeRep (
        -- Pretty-printing
        pprType, pprParendType, pprTypeApp,
        pprTyThing, pprTyThingCategory, 
-       pprPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred,
+       pprPred, pprEqPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred,
 
        -- Kinds
        liftedTypeKind, unliftedTypeKind, openTypeKind,
@@ -53,7 +54,6 @@ import {-# SOURCE #-} DataCon( DataCon, dataConName )
 -- friends:
 import Var
 import Name
-import OccName
 import BasicTypes
 import TyCon
 import Class
@@ -62,6 +62,9 @@ import Class
 import PrelNames
 import Outputable
 import FastString
+
+-- libraries
+import Data.Data hiding ( TyCon )
 \end{code}
 
        ----------------------
@@ -156,6 +159,7 @@ data Type
                        -- of a 'FunTy' (unlike the 'PredType' constructors 'ClassP' or 'IParam')
                        
                        -- See Note [PredTy], and Note [Equality predicates]
+  deriving (Data, Typeable)
 
 -- | The key type representing kinds in the compiler.
 -- Invariant: a kind is always in one of these forms:
@@ -197,6 +201,7 @@ data PredType
   = ClassP Class [Type]                -- ^ Class predicate e.g. @Eq a@
   | IParam (IPName Name) Type  -- ^ Implicit parameter e.g. @?x :: Int@
   | EqPred Type Type           -- ^ Equality predicate e.g @ty1 ~ ty2@
+  deriving (Data, Typeable)
 
 -- | A collection of 'PredType's
 type ThetaType = [PredType]
@@ -305,14 +310,11 @@ funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] lif
 tySuperKindTyCon     = mkSuperKindTyCon tySuperKindTyConName
 coSuperKindTyCon     = mkSuperKindTyCon coSuperKindTyConName
 
-liftedTypeKindTyCon   = mkKindTyCon liftedTypeKindTyConName
-openTypeKindTyCon     = mkKindTyCon openTypeKindTyConName
-unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName
-ubxTupleKindTyCon     = mkKindTyCon ubxTupleKindTyConName
-argTypeKindTyCon      = mkKindTyCon argTypeKindTyConName
-
-mkKindTyCon :: Name -> TyCon
-mkKindTyCon name = mkVoidPrimTyCon name tySuperKind 0
+liftedTypeKindTyCon   = mkKindTyCon liftedTypeKindTyConName   tySuperKind
+openTypeKindTyCon     = mkKindTyCon openTypeKindTyConName     tySuperKind
+unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind
+ubxTupleKindTyCon     = mkKindTyCon ubxTupleKindTyConName     tySuperKind
+argTypeKindTyCon      = mkKindTyCon argTypeKindTyConName      tySuperKind
 
 --------------------------
 -- ... and now their names
@@ -432,7 +434,17 @@ pprTypeApp tc tys = ppr_type_app TopPrec (getName tc) tys
 pprPred :: PredType -> SDoc
 pprPred (ClassP cls tys) = pprClassPred cls tys
 pprPred (IParam ip ty)   = ppr ip <> dcolon <> pprType ty
-pprPred (EqPred ty1 ty2) = sep [ppr ty1, nest 2 (ptext (sLit "~")), ppr ty2]
+pprPred (EqPred ty1 ty2) = pprEqPred (ty1,ty2)
+
+pprEqPred :: (Type,Type) -> SDoc
+pprEqPred (ty1,ty2) = sep [ ppr_type FunPrec ty1
+                          , nest 2 (ptext (sLit "~"))
+                          , ppr_type FunPrec ty2]
+                              -- Precedence looks like (->) so that we get
+                              --    Maybe a ~ Bool
+                              --    (a->a) ~ Bool
+                              -- Note parens on the latter!
+
 pprClassPred :: Class -> [Type] -> SDoc
 pprClassPred clas tys = ppr_type_app TopPrec (getName clas) tys
 
@@ -465,7 +477,8 @@ ppr_type :: Prec -> Type -> SDoc
 ppr_type _ (TyVarTy tv)                -- Note [Infix type variables]
   | isSymOcc (getOccName tv)  = parens (ppr tv)
   | otherwise                = ppr tv
-ppr_type _ (PredTy pred)      = ifPprDebug (ptext (sLit "<pred>")) <> (ppr pred)
+ppr_type p (PredTy pred)      = maybeParen p TyConPrec $
+                                ifPprDebug (ptext (sLit "<pred>")) <> (ppr pred)
 ppr_type p (TyConApp tc tys)  = ppr_tc_app p tc tys
 
 ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $