\section[TypeRep]{Type - friends' interface}
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module TypeRep (
TyThing(..),
- Type(..), TyNote(..), -- Representation visible
+ Type(..),
PredType(..), -- to friends
Kind, ThetaType, -- Synonyms
-- Pretty-printing
pprType, pprParendType, pprTypeApp,
- pprTyThingCategory,
+ pprTyThing, pprTyThingCategory,
pprPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred,
-- Kinds
argTypeKind, ubxTupleKind,
isLiftedTypeKindCon, isLiftedTypeKind,
mkArrowKind, mkArrowKinds, isCoercionKind,
+ coVarPred,
-- Kind constructors...
liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
-- friends:
import Var
-import VarSet
import Name
import OccName
import BasicTypes
-- others
import PrelNames
import Outputable
+import FastString
\end{code}
%************************************************************************
| AppTy
Type -- Function is *not* a TyConApp
Type -- It must be another AppTy, or TyVarTy
- -- (or NoteTy of these)
| TyConApp -- Application of a TyCon, including newtypes *and* synonyms
TyCon -- *Invariant* saturated appliations of FunTyCon and
-- of a coercion variable; never as the argument or result
-- of a FunTy (unlike ClassP, IParam)
- | NoteTy -- A type with a note attached
- TyNote
- Type -- The expanded version
-
type Kind = Type -- Invariant: a kind is always
-- FunTy k1 k2
-- or TyConApp PrimTyCon [...]
type SuperKind = Type -- Invariant: a super kind is always
-- TyConApp SuperKindTyCon ...
-
-data TyNote = FTVNote TyVarSet -- The free type variables of the noted expression
\end{code}
-------------------------------------
| ATyCon TyCon
| AClass Class
-instance Outputable TyThing where
- ppr thing = pprTyThingCategory thing <+> quotes (ppr (getName thing))
+instance Outputable TyThing where
+ ppr = pprTyThing
+
+pprTyThing :: TyThing -> SDoc
+pprTyThing thing = pprTyThingCategory thing <+> quotes (ppr (getName thing))
pprTyThingCategory :: TyThing -> SDoc
pprTyThingCategory (ATyCon _) = ptext SLIT("Type constructor")
--------------------------
-- First the TyCons...
+funTyCon, tySuperKindTyCon, coSuperKindTyCon, liftedTypeKindTyCon,
+ openTypeKindTyCon, unliftedTypeKindTyCon,
+ ubxTupleKindTyCon, argTypeKindTyCon
+ :: TyCon
+funTyConName, tySuperKindTyConName, coSuperKindTyConName, liftedTypeKindTyConName,
+ openTypeKindTyConName, unliftedTypeKindTyConName,
+ ubxTupleKindTyConName, argTypeKindTyConName
+ :: Name
+
funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind)
-- You might think that (->) should have type (?? -> ? -> *), and you'd be right
-- But if we do that we get kind errors when saying
argTypeKindTyConName = mkPrimTyConName FSLIT("??") argTypeKindTyConKey argTypeKindTyCon
funTyConName = mkPrimTyConName FSLIT("(->)") funTyConKey funTyCon
+mkPrimTyConName :: FastString -> Unique -> TyCon -> Name
mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkOccNameFS tcName occ)
key
(ATyCon tycon)
kindTyConType :: TyCon -> Type
kindTyConType kind = TyConApp kind []
+liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind :: Kind
+
liftedTypeKind = kindTyConType liftedTypeKindTyCon
unliftedTypeKind = kindTyConType unliftedTypeKindTyCon
openTypeKind = kindTyConType openTypeKindTyCon
tySuperKind = kindTyConType tySuperKindTyCon
coSuperKind = kindTyConType coSuperKindTyCon
-isTySuperKind (NoteTy _ ty) = isTySuperKind ty
+isTySuperKind :: SuperKind -> Bool
isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey
-isTySuperKind other = False
+isTySuperKind _ = False
isCoSuperKind :: SuperKind -> Bool
-isCoSuperKind (NoteTy _ ty) = isCoSuperKind ty
isCoSuperKind (TyConApp kc []) = kc `hasKey` coSuperKindTyConKey
-isCoSuperKind other = False
+isCoSuperKind _ = False
-------------------
-- Lastly we need a few functions on Kinds
+isLiftedTypeKindCon :: TyCon -> Bool
isLiftedTypeKindCon tc = tc `hasKey` liftedTypeKindTyConKey
isLiftedTypeKind :: Kind -> Bool
isLiftedTypeKind (TyConApp tc []) = isLiftedTypeKindCon tc
-isLiftedTypeKind other = False
+isLiftedTypeKind _ = False
isCoercionKind :: Kind -> Bool
-- All coercions are of form (ty1 ~ ty2)
-- This function is here rather than in Coercion,
-- because it's used in a knot-tied way to enforce invariants in Var
-isCoercionKind (NoteTy _ k) = isCoercionKind k
isCoercionKind (PredTy (EqPred {})) = True
-isCoercionKind other = False
+isCoercionKind _ = False
+
+coVarPred :: CoVar -> PredType
+coVarPred tv
+ = ASSERT( isCoVar tv )
+ case tyVarKind tv of
+ PredTy eq -> eq
+ other -> pprPanic "coVarPred" (ppr tv $$ ppr other)
\end{code}
------------------
-- OK, here's the main printer
+pprKind, pprParendKind :: Kind -> SDoc
pprKind = pprType
pprParendKind = pprParendType
ppr_type :: Prec -> Type -> SDoc
-ppr_type p (TyVarTy tv) = ppr tv
-ppr_type p (PredTy pred) = ifPprDebug (ptext SLIT("<pred>")) <> (ppr pred)
-ppr_type p (NoteTy other ty2) = ppr_type p ty2
+ppr_type _ (TyVarTy tv) = ppr tv
+ppr_type _ (PredTy pred) = 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 $
ppr_forall_type :: Prec -> Type -> SDoc
ppr_forall_type p ty
= maybeParen p FunPrec $
- sep [pprForAll tvs, pprThetaArrow (ctxt1 ++ ctxt2), pprType tau]
+ sep [pprForAll tvs, pprThetaArrow ctxt, pprType tau]
where
- (tvs, ctxt1, rho) = split1 [] [] ty
- (ctxt2, tau) = split2 [] rho
+ (tvs, rho) = split1 [] ty
+ (ctxt, tau) = split2 [] rho
-- We need to be extra careful here as equality constraints will occur as
-- type variables with an equality kind. So, while collecting quantified
-- variables, we separate the coercion variables out and turn them into
-- equality predicates.
- split1 tvs eqs (ForAllTy tv ty)
- | isCoVar tv = split1 tvs (eq:eqs) ty
- | otherwise = split1 (tv:tvs) eqs ty
- where
- PredTy eq = tyVarKind tv
- split1 tvs eqs (NoteTy _ ty) = split1 tvs eqs ty
- split1 tvs eqs ty = (reverse tvs, reverse eqs, ty)
+ split1 tvs (ForAllTy tv ty)
+ | not (isCoVar tv) = split1 (tv:tvs) ty
+ split1 tvs ty = (reverse tvs, ty)
- split2 ps (NoteTy _ arg -- Rather a disgusting case
- `FunTy` res) = split2 ps (arg `FunTy` res)
- split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty
- split2 ps (NoteTy _ ty) = split2 ps ty
- split2 ps ty = (reverse ps, ty)
+ split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty
+ split2 ps (ForAllTy tv ty)
+ | isCoVar tv = split2 (coVarPred tv : ps) ty
+ split2 ps ty = (reverse ps, ty)
ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc
-ppr_tc_app p tc []
+ppr_tc_app _ tc []
= ppr_tc tc
-ppr_tc_app p tc [ty]
+ppr_tc_app _ tc [ty]
| tc `hasKey` listTyConKey = brackets (pprType ty)
| tc `hasKey` parrTyConKey = ptext SLIT("[:") <> pprType ty <> ptext SLIT(":]")
| tc `hasKey` liftedTypeKindTyConKey = ptext SLIT("*")
| otherwise = empty
-------------------
+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)
where