\begin{code}
-- We expose the relevant stuff from this module via the Type module
{-# OPTIONS_HADDOCK hide #-}
+{-# LANGUAGE DeriveDataTypeable #-}
module TypeRep (
TyThing(..),
-- Pretty-printing
pprType, pprParendType, pprTypeApp,
pprTyThing, pprTyThingCategory,
- pprPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred,
+ pprPred, pprEqPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred,
-- Kinds
liftedTypeKind, unliftedTypeKind, openTypeKind,
- argTypeKind, ubxTupleKind,
+ argTypeKind, ubxTupleKind, ecKind,
isLiftedTypeKindCon, isLiftedTypeKind,
mkArrowKind, mkArrowKinds, isCoercionKind,
coVarPred,
import PrelNames
import Outputable
import FastString
+
+-- libraries
+import Data.Data hiding ( TyCon )
\end{code}
----------------------
-- 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:
= 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]
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
kindTyConType kind = TyConApp kind []
-- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's
-liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind :: Kind
+liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, ecKind :: Kind
liftedTypeKind = kindTyConType liftedTypeKindTyCon
unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
openTypeKind = kindTyConType openTypeKindTyCon
argTypeKind = kindTyConType argTypeKindTyCon
ubxTupleKind = kindTyConType ubxTupleKindTyCon
+ecKind = liftedTypeKind `mkArrowKind` (liftedTypeKind `mkArrowKind` liftedTypeKind)
+-- NOTE: if you change ecKind, you must also change the explicit kind signatures
+-- on hetmet_{brak,esc,csp} in GHC.Hetmet.CodeTypes
-- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@
mkArrowKind :: Kind -> Kind -> Kind
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
pprTheta :: ThetaType -> SDoc
-pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
+-- pprTheta [pred] = pprPred pred -- I'm in two minds about this
+pprTheta theta = parens (sep (punctuate comma (map pprPred theta)))
pprThetaArrow :: ThetaType -> SDoc
-pprThetaArrow theta
- | null theta = empty
- | otherwise = parens (sep (punctuate comma (map pprPred theta))) <+> ptext (sLit "=>")
+pprThetaArrow [] = empty
+pprThetaArrow [pred]
+ | noParenPred pred = pprPred pred <+> darrow
+pprThetaArrow preds = parens (sep (punctuate comma (map pprPred preds))) <+> darrow
+
+noParenPred :: PredType -> Bool
+-- A predicate that can appear without parens before a "=>"
+-- C a => a -> a
+-- a~b => a -> b
+-- But (?x::Int) => Int -> Int
+noParenPred (ClassP {}) = True
+noParenPred (EqPred {}) = True
+noParenPred (IParam {}) = False
------------------
instance Outputable Type where
pprParendKind = pprParendType
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 _ (TyVarTy tv) = ppr_tvar tv
+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 $
maybeParen p FunPrec $
sep (ppr_type FunPrec ty1 : ppr_fun_tail ty2)
where
- ppr_fun_tail (FunTy ty1 ty2) = (arrow <+> ppr_type FunPrec ty1) : ppr_fun_tail ty2
- ppr_fun_tail other_ty = [arrow <+> pprType other_ty]
+ ppr_fun_tail (FunTy ty1 ty2)
+ | not (is_pred ty1) = (arrow <+> ppr_type FunPrec ty1) : ppr_fun_tail ty2
+ ppr_fun_tail other_ty = [arrow <+> pprType other_ty]
+ is_pred (PredTy {}) = True
+ is_pred _ = False
ppr_forall_type :: Prec -> Type -> SDoc
ppr_forall_type p ty
| tc `hasKey` argTypeKindTyConKey = ptext (sLit "??")
ppr_tc_app p tc tys
+ | [ecvar,ty] <- tys, tc `hasKey` hetMetCodeTypeTyConKey
+ = ptext (sLit "<[") <> pprType ty <> ptext (sLit "]>@") <> ppr ecvar
| isTupleTyCon tc && tyConArity tc == length tys
= tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys)))
| otherwise
else ptext (sLit "<nt>"))
| otherwise = empty
+ppr_tvar :: TyVar -> SDoc
+ppr_tvar tv -- Note [Infix type variables]
+ | isSymOcc (getOccName tv) = parens (ppr tv)
+ | otherwise = ppr tv
+
-------------------
pprForAll :: [TyVar] -> SDoc
pprForAll [] = empty
pprForAll tvs = ptext (sLit "forall") <+> sep (map pprTvBndr tvs) <> dot
pprTvBndr :: TyVar -> SDoc
-pprTvBndr tv | isLiftedTypeKind kind = ppr tv
- | otherwise = parens (ppr tv <+> dcolon <+> pprKind kind)
+pprTvBndr tv | isLiftedTypeKind kind = ppr_tvar tv
+ | otherwise = parens (ppr_tvar tv <+> dcolon <+> pprKind kind)
where
kind = tyVarKind tv
\end{code}
Note [Infix type variables]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In Haskell 98 you can say
+With TypeOperators you can say
f :: (a ~> b) -> b