%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1998
%
\section[TypeRep]{Type - friends' interface}
\begin{code}
module TypeRep (
TyThing(..),
- Type(..), TyNote(..), -- Representation visible
+ Type(..),
PredType(..), -- to friends
Kind, ThetaType, -- Synonyms
funTyCon,
-- Pretty-printing
- pprType, pprParendType, pprTyThingCategory,
- pprPred, pprTheta, pprThetaArrow, pprClassPred,
+ pprType, pprParendType, pprTypeApp,
+ pprTyThing, pprTyThingCategory,
+ pprPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred,
-- Kinds
liftedTypeKind, unliftedTypeKind, openTypeKind,
argTypeKind, ubxTupleKind,
isLiftedTypeKindCon, isLiftedTypeKind,
- mkArrowKind, mkArrowKinds,
+ mkArrowKind, mkArrowKinds, isCoercionKind,
+ coVarPred,
-- Kind constructors...
liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
#include "HsVersions.h"
import {-# SOURCE #-} DataCon( DataCon, dataConName )
--- friends:
-import Var ( Var, Id, TyVar, tyVarKind )
-import VarSet ( TyVarSet )
-import Name ( Name, NamedThing(..), BuiltInSyntax(..), mkWiredInName )
-import OccName ( mkOccNameFS, tcName, parenSymOcc )
-import BasicTypes ( IPName, tupleParens )
-import TyCon ( TyCon, mkFunTyCon, tyConArity, tupleTyConBoxity, isTupleTyCon,
- isRecursiveTyCon, isNewTyCon, mkVoidPrimTyCon,
- mkSuperKindTyCon )
-import Class ( Class )
+-- friends:
+import Var
+import Name
+import OccName
+import BasicTypes
+import TyCon
+import Class
-- others
-import PrelNames ( gHC_PRIM, funTyConKey, tySuperKindTyConKey,
- coSuperKindTyConKey, liftedTypeKindTyConKey,
- openTypeKindTyConKey, unliftedTypeKindTyConKey,
- ubxTupleKindTyConKey, argTypeKindTyConKey, listTyConKey,
- parrTyConKey, hasKey )
+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}
-------------------------------------
data PredType
= ClassP Class [Type] -- Class predicate
| IParam (IPName Name) Type -- Implicit parameter
- | EqPred Type Type -- Equality predicate (ty1 :=: ty2)
+ | EqPred Type Type -- Equality predicate (ty1 ~ ty2)
type ThetaType = [PredType]
\end{code}
Note [Equality predicates]
~~~~~~~~~~~~~~~~~~~~~~~~~~
- forall a b. (a :=: S b) => a -> b
+ forall a b. (a ~ S b) => a -> b
could be represented by
ForAllTy a (ForAllTy b (FunTy (PredTy (EqPred a (S b))) ...))
OR
| 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")
-pprTyThingCategory (AClass _) = ptext SLIT("Class")
-pprTyThingCategory (AnId _) = ptext SLIT("Identifier")
-pprTyThingCategory (ADataCon _) = ptext SLIT("Data constructor")
+pprTyThingCategory (ATyCon _) = ptext (sLit "Type constructor")
+pprTyThingCategory (AClass _) = ptext (sLit "Class")
+pprTyThingCategory (AnId _) = ptext (sLit "Identifier")
+pprTyThingCategory (ADataCon _) = ptext (sLit "Data constructor")
instance NamedThing TyThing where -- Can't put this with the type
getName (AnId id) = getName id -- decl, because the DataCon instance
--------------------------
-- 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
--------------------------
-- ... and now their names
-tySuperKindTyConName = mkPrimTyConName FSLIT("BOX") tySuperKindTyConKey tySuperKindTyCon
-coSuperKindTyConName = mkPrimTyConName FSLIT("COERCION") coSuperKindTyConKey coSuperKindTyCon
-liftedTypeKindTyConName = mkPrimTyConName FSLIT("*") liftedTypeKindTyConKey liftedTypeKindTyCon
-openTypeKindTyConName = mkPrimTyConName FSLIT("?") openTypeKindTyConKey openTypeKindTyCon
-unliftedTypeKindTyConName = mkPrimTyConName FSLIT("#") unliftedTypeKindTyConKey unliftedTypeKindTyCon
-ubxTupleKindTyConName = mkPrimTyConName FSLIT("(##)") ubxTupleKindTyConKey ubxTupleKindTyCon
-argTypeKindTyConName = mkPrimTyConName FSLIT("??") argTypeKindTyConKey argTypeKindTyCon
-funTyConName = mkPrimTyConName FSLIT("(->)") funTyConKey funTyCon
+tySuperKindTyConName = mkPrimTyConName (fsLit "BOX") tySuperKindTyConKey tySuperKindTyCon
+coSuperKindTyConName = mkPrimTyConName (fsLit "COERCION") coSuperKindTyConKey coSuperKindTyCon
+liftedTypeKindTyConName = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon
+openTypeKindTyConName = mkPrimTyConName (fsLit "?") openTypeKindTyConKey openTypeKindTyCon
+unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon
+ubxTupleKindTyConName = mkPrimTyConName (fsLit "(#)") ubxTupleKindTyConKey ubxTupleKindTyCon
+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
- Nothing -- No parent object
(ATyCon tycon)
BuiltInSyntax
-- All of the super kinds and kinds are defined in Prim and use BuiltInSyntax,
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
+-- 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 (PredTy (EqPred {})) = True
+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}
pprType ty = ppr_type TopPrec ty
pprParendType ty = ppr_type TyConPrec ty
+pprTypeApp :: NamedThing a => a -> SDoc -> [Type] -> SDoc
+-- The first arg is the tycon; it's used to arrange printing infix
+-- if it looks like an operator
+-- Second arg is the pretty-printed tycon
+pprTypeApp tc pp_tc tys = ppr_type_app TopPrec (getName tc) pp_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) = 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 = ppr_type_app TopPrec (getName clas) (ppr clas) tys
pprTheta :: ThetaType -> SDoc
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("=>")
+ | otherwise = parens (sep (punctuate comma (map pprPred theta))) <+> ptext (sLit "=>")
------------------
instance Outputable Type where
------------------
-- 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) = braces (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 $
(tvs, rho) = split1 [] ty
(ctxt, tau) = split2 [] rho
- split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty
- split1 tvs (NoteTy _ ty) = split1 tvs ty
- split1 tvs ty = (reverse tvs, ty)
+ -- 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 (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("*")
- | tc `hasKey` unliftedTypeKindTyConKey = ptext SLIT("#")
- | tc `hasKey` openTypeKindTyConKey = ptext SLIT("(?)")
- | tc `hasKey` ubxTupleKindTyConKey = ptext SLIT("(#)")
- | tc `hasKey` argTypeKindTyConKey = ptext SLIT("??")
+ | tc `hasKey` parrTyConKey = ptext (sLit "[:") <> pprType ty <> ptext (sLit ":]")
+ | tc `hasKey` liftedTypeKindTyConKey = ptext (sLit "*")
+ | tc `hasKey` unliftedTypeKindTyConKey = ptext (sLit "#")
+ | tc `hasKey` openTypeKindTyConKey = ptext (sLit "(?)")
+ | tc `hasKey` ubxTupleKindTyConKey = ptext (sLit "(#)")
+ | tc `hasKey` argTypeKindTyConKey = ptext (sLit "??")
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)
+ = ppr_type_app p (getName tc) (ppr_naked_tc tc) tys
+
+ppr_type_app :: Prec -> Name -> SDoc -> [Type] -> SDoc
+ppr_type_app p tc pp_tc tys
+ | is_sym_occ -- Print infix if possible
+ , [ty1,ty2] <- tys -- We know nothing of precedence though
+ = maybeParen p FunPrec (sep [ppr_type FunPrec ty1,
+ pp_tc <+> ppr_type FunPrec ty2])
+ | otherwise
+ = maybeParen p TyConPrec (hang paren_tc 2 (sep (map pprParendType tys)))
+ where
+ is_sym_occ = isSymOcc (getOccName tc)
+ paren_tc | is_sym_occ = parens pp_tc
+ | otherwise = pp_tc
ppr_tc :: TyCon -> SDoc
-ppr_tc tc = parenSymOcc (getOccName tc) (pp_nt_debug <> ppr tc)
+ppr_tc tc = parenSymOcc (getOccName tc) (ppr_naked_tc tc)
+
+ppr_naked_tc :: TyCon -> SDoc -- No brackets for SymOcc
+ppr_naked_tc tc
+ = pp_nt_debug <> ppr tc
where
pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc
- then ptext SLIT("<recnt>")
- else ptext SLIT("<nt>"))
+ then ptext (sLit "<recnt>")
+ else ptext (sLit "<nt>"))
| otherwise = empty
-------------------
+pprForAll :: [TyVar] -> SDoc
pprForAll [] = empty
-pprForAll tvs = ptext SLIT("forall") <+> sep (map pprTvBndr tvs) <> dot
+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