\begin{code}
module HsTypes (
- HsType(..), HsUsageAnn(..), HsTyVarBndr(..),
+ HsType(..), HsTyVarBndr(..),
, HsContext, HsPred(..)
, HsTupCon(..), hsTupParens, mkHsTupCon,
+ , hsUsOnce, hsUsMany
- , mkHsForAllTy, mkHsUsForAllTy, mkHsDictTy, mkHsIParamTy
+ , mkHsForAllTy, mkHsDictTy, mkHsIParamTy
, hsTyVarName, hsTyVarNames, replaceTyVarName
-- Printing
-- Equality over Hs things
, EqHsEnv, emptyEqHsEnv, extendEqHsEnv,
- , eqWithHsTyVars, eq_hsVar, eq_hsVars, eq_hsType, eq_hsContext, eqListBy
+ , eqWithHsTyVars, eq_hsVar, eq_hsVars, eq_hsTyVars, eq_hsType, eq_hsContext, eqListBy
-- Converting from Type to HsType
, toHsType, toHsTyVar, toHsTyVars, toHsContext, toHsFDs
#include "HsVersions.h"
import Class ( FunDep )
-import Type ( Type, Kind, PredType(..), ClassContext,
- splitSigmaTy, unUsgTy, boxedTypeKind
+import Type ( Type, Kind, ThetaType, PredType(..),
+ splitSigmaTy, liftedTypeKind
)
import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation
-import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity )
-import RdrName ( RdrName )
-import Name ( toRdrName )
-import OccName ( NameSpace )
+import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity, getSynTyConDefn )
+import RdrName ( RdrName, mkUnqual )
+import Name ( Name, getName )
+import OccName ( NameSpace, tvName )
import Var ( TyVar, tyVarKind )
+import Subst ( mkTyVarSubst, substTy )
import PprType ( {- instance Outputable Kind -}, pprParendKind )
-import BasicTypes ( Boxity(..), tupleParens )
-import PrelNames ( mkTupConRdrName, listTyConKey, hasKey )
+import BasicTypes ( Boxity(..), Arity, tupleParens )
+import PrelNames ( mkTupConRdrName, listTyConKey, usOnceTyConKey, usManyTyConKey, hasKey,
+ usOnceTyConName, usManyTyConName
+ )
import FiniteMap
import Outputable
\begin{code}
type HsContext name = [HsPred name]
-data HsPred name = HsPClass name [HsType name]
- | HsPIParam name (HsType name)
+data HsPred name = HsClassP name [HsType name]
+ | HsIParam name (HsType name)
data HsType name
= HsForAllTy (Maybe [HsTyVarBndr name]) -- Nothing for implicitly quantified signatures
| HsNumTy Integer
-- these next two are only used in interfaces
| HsPredTy (HsPred name)
+
+ | HsUsageTy (HsType name) -- Usage annotation
+ (HsType name) -- Annotated type
- | HsUsgTy (HsUsageAnn name)
- (HsType name)
- | HsUsgForAllTy name
- (HsType name)
+-----------------------
+hsUsOnce, hsUsMany :: HsType RdrName
+hsUsOnce = HsTyVar (mkUnqual tvName SLIT(".")) -- deep magic
+hsUsMany = HsTyVar (mkUnqual tvName SLIT("!")) -- deep magic
-data HsUsageAnn name
- = HsUsOnce
- | HsUsMany
- | HsUsVar name
-
+hsUsOnce_Name, hsUsMany_Name :: HsType Name
+hsUsOnce_Name = HsTyVar usOnceTyConName
+hsUsMany_Name = HsTyVar usManyTyConName
-----------------------
-data HsTupCon name = HsTupCon name Boxity
+data HsTupCon name = HsTupCon name Boxity Arity
instance Eq name => Eq (HsTupCon name) where
- (HsTupCon _ b1) == (HsTupCon _ b2) = b1==b2
+ (HsTupCon _ b1 a1) == (HsTupCon _ b2 a2) = b1==b2 && a1==a2
mkHsTupCon :: NameSpace -> Boxity -> [a] -> HsTupCon RdrName
-mkHsTupCon space boxity args = HsTupCon (mkTupConRdrName space boxity (length args)) boxity
+mkHsTupCon space boxity args = HsTupCon (mkTupConRdrName space boxity arity) boxity arity
+ where
+ arity = length args
hsTupParens :: HsTupCon name -> SDoc -> SDoc
-hsTupParens (HsTupCon _ b) p = tupleParens b p
+hsTupParens (HsTupCon _ b _) p = tupleParens b p
-----------------------
-- Combine adjacent for-alls.
(Just tvs1) `plus` (Just tvs2) = Just (tvs1 ++ tvs2)
mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty
-mkHsUsForAllTy uvs ty = foldr (\ uv ty -> HsUsgForAllTy uv ty)
- ty uvs
-
-mkHsDictTy cls tys = HsPredTy (HsPClass cls tys)
-mkHsIParamTy v ty = HsPredTy (HsPIParam v ty)
+mkHsDictTy cls tys = HsPredTy (HsClassP cls tys)
+mkHsIParamTy v ty = HsPredTy (HsIParam v ty)
data HsTyVarBndr name
= UserTyVar name
ppr (IfaceTyVar name kind) = pprHsTyVarBndr name kind
instance Outputable name => Outputable (HsPred name) where
- ppr (HsPClass clas tys) = ppr clas <+> hsep (map pprParendHsType tys)
- ppr (HsPIParam n ty) = hsep [char '?' <> ppr n, text "::", ppr ty]
+ ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprParendHsType tys)
+ ppr (HsIParam n ty) = hsep [char '?' <> ppr n, text "::", ppr ty]
pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc
-pprHsTyVarBndr name kind | kind == boxedTypeKind = ppr name
- | otherwise = hsep [ppr name, dcolon, pprParendKind kind]
+pprHsTyVarBndr name kind | kind == liftedTypeKind = ppr name
+ | otherwise = hsep [ppr name, dcolon, pprParendKind kind]
pprHsForAll [] [] = empty
pprHsForAll tvs cxt
= getPprStyle $ \ sty ->
if userStyle sty then
ptext SLIT("forall") <+> interppSP tvs <> dot <+>
+ -- **! ToDo: want to hide uvars from user, but not enough info
+ -- in a HsTyVarBndr name (see PprType). KSW 2000-10.
(if null cxt then
empty
else
\end{code}
\begin{code}
-pREC_TOP = (0 :: Int)
-pREC_FUN = (1 :: Int)
-pREC_CON = (2 :: Int)
+pREC_TOP = (0 :: Int) -- type in ParseIface.y
+pREC_FUN = (1 :: Int) -- btype in ParseIface.y
+pREC_CON = (2 :: Int) -- atype in ParseIface.y
maybeParen :: Bool -> SDoc -> SDoc
maybeParen True p = parens p
(hsep [ppr_mono_ty pREC_FUN fun_ty, ppr_mono_ty pREC_CON arg_ty])
ppr_mono_ty ctxt_prec (HsPredTy pred)
- = maybeParen (ctxt_prec >= pREC_FUN) $
- braces (ppr pred)
-
-ppr_mono_ty ctxt_prec ty@(HsUsgForAllTy _ _)
- =
- sep [ ptext SLIT("__fuall") <+> brackets pp_uvars <+> ptext SLIT("=>"),
- ppr_mono_ty pREC_TOP sigma
- ]
- where
- (uvars,sigma) = split [] ty
- pp_uvars = interppSP uvars
+ = braces (ppr pred)
- split uvs (HsUsgForAllTy uv ty') = split (uv:uvs) ty'
- split uvs ty' = (reverse uvs,ty')
+ppr_mono_ty ctxt_prec (HsUsageTy u ty)
+ = maybeParen (ctxt_prec >= pREC_CON)
+ (sep [ptext SLIT("__u") <+> ppr_mono_ty pREC_CON u,
+ ppr_mono_ty pREC_CON ty])
+ -- pREC_FUN would be logical for u, but it yields a reduce/reduce conflict with AppTy
-ppr_mono_ty ctxt_prec (HsUsgTy u ty)
- = maybeParen (ctxt_prec >= pREC_CON) $
- ptext SLIT("__u") <+> pp_ua <+> ppr_mono_ty pREC_CON ty
- where
- pp_ua = case u of
- HsUsOnce -> ptext SLIT("-")
- HsUsMany -> ptext SLIT("!")
- HsUsVar uv -> ppr uv
-- Generics
ppr_mono_ty ctxt_prec (HsNumTy n) = integer n
ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) = ppr ty1 <+> ppr op <+> ppr ty2
expresses overloaded functions using the '=>' context part of a HsForAllTy.
\begin{code}
-toHsTyVar :: TyVar -> HsTyVarBndr RdrName
-toHsTyVar tv = IfaceTyVar (toRdrName tv) (tyVarKind tv)
+toHsTyVar :: TyVar -> HsTyVarBndr Name
+toHsTyVar tv = IfaceTyVar (getName tv) (tyVarKind tv)
toHsTyVars tvs = map toHsTyVar tvs
-toHsType :: Type -> HsType RdrName
-toHsType ty = toHsType' (unUsgTy ty)
- -- For now we just discard the usage
-
-toHsType' :: Type -> HsType RdrName
--- Called after the usage is stripped off
+toHsType :: Type -> HsType Name
-- This function knows the representation of types
-toHsType' (TyVarTy tv) = HsTyVar (toRdrName tv)
-toHsType' (FunTy arg res) = HsFunTy (toHsType arg) (toHsType res)
-toHsType' (AppTy fun arg) = HsAppTy (toHsType fun) (toHsType arg)
-
-toHsType' (NoteTy (SynNote ty) _) = toHsType ty -- Use synonyms if possible!!
-toHsType' (NoteTy _ ty) = toHsType ty
-
-toHsType' (PredTy p) = HsPredTy (toHsPred p)
-
-toHsType' ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of kind *
- | not saturated = generic_case
- | isTupleTyCon tc = HsTupleTy (HsTupCon (toRdrName tc) (tupleTyConBoxity tc)) tys'
- | tc `hasKey` listTyConKey = HsListTy (head tys')
- | otherwise = generic_case
+toHsType (TyVarTy tv) = HsTyVar (getName tv)
+toHsType (FunTy arg res) = HsFunTy (toHsType arg) (toHsType res)
+toHsType (AppTy fun arg) = HsAppTy (toHsType fun) (toHsType arg)
+
+toHsType (NoteTy (SynNote syn_ty) real_ty)
+ | syn_matches = toHsType syn_ty -- Use synonyms if possible!!
+ | otherwise =
+#ifdef DEBUG
+ pprTrace "WARNING: synonym info lost in .hi file for " (ppr syn_ty) $
+#endif
+ toHsType real_ty -- but drop it if not.
+ where
+ syn_matches = ty_from_syn == real_ty
+
+ TyConApp syn_tycon tyargs = syn_ty
+ (tyvars,ty) = getSynTyConDefn syn_tycon
+ ty_from_syn = substTy (mkTyVarSubst tyvars tyargs) ty
+
+ -- We only use the type synonym in the file if this doesn't cause
+ -- us to lose important information. This matters for usage
+ -- annotations. It's an issue if some of the args to the synonym
+ -- have arrows in them, or if the synonym's RHS has an arrow; for
+ -- example, with nofib/real/ebnf2ps/ in Parsers.using.
+
+ -- **! It would be nice if when this test fails we could still
+ -- write the synonym in as a Note, so we don't lose the info for
+ -- error messages, but it's too much work for right now.
+ -- KSW 2000-07.
+
+toHsType (NoteTy _ ty) = toHsType ty
+
+toHsType (PredTy p) = HsPredTy (toHsPred p)
+
+toHsType ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of kind *
+ | not saturated = generic_case
+ | isTupleTyCon tc = HsTupleTy (HsTupCon (getName tc) (tupleTyConBoxity tc) (tyConArity tc)) tys'
+ | tc `hasKey` listTyConKey = HsListTy (head tys')
+ | tc `hasKey` usOnceTyConKey = hsUsOnce_Name -- must print !, . unqualified
+ | tc `hasKey` usManyTyConKey = hsUsMany_Name -- must print !, . unqualified
+ | otherwise = generic_case
where
- generic_case = foldl HsAppTy (HsTyVar (toRdrName tc)) tys'
+ generic_case = foldl HsAppTy (HsTyVar (getName tc)) tys'
tys' = map toHsType tys
saturated = length tys == tyConArity tc
-toHsType' ty@(ForAllTy _ _) = case splitSigmaTy ty of
+toHsType ty@(ForAllTy _ _) = case splitSigmaTy ty of
(tvs, preds, tau) -> HsForAllTy (Just (map toHsTyVar tvs))
(map toHsPred preds)
(toHsType tau)
+toHsType (UsageTy u ty) = HsUsageTy (toHsType u) (toHsType ty)
+ -- **! consider dropping usMany annotations ToDo KSW 2000-10
-toHsPred (Class cls tys) = HsPClass (toRdrName cls) (map toHsType tys)
-toHsPred (IParam n ty) = HsPIParam (toRdrName n) (toHsType ty)
-toHsContext :: ClassContext -> HsContext RdrName
-toHsContext cxt = [HsPClass (toRdrName cls) (map toHsType tys) | (cls,tys) <- cxt]
+toHsPred (ClassP cls tys) = HsClassP (getName cls) (map toHsType tys)
+toHsPred (IParam n ty) = HsIParam (getName n) (toHsType ty)
-toHsFDs :: [FunDep TyVar] -> [FunDep RdrName]
-toHsFDs fds = [(map toRdrName ns, map toRdrName ms) | (ns,ms) <- fds]
+toHsContext :: ThetaType -> HsContext Name
+toHsContext theta = map toHsPred theta
+
+toHsFDs :: [FunDep TyVar] -> [FunDep Name]
+toHsFDs fds = [(map getName ns, map getName ms) | (ns,ms) <- fds]
\end{code}
eq_hsType env (HsPredTy p1) (HsPredTy p2)
= eq_hsPred env p1 p2
+eq_hsType env (HsUsageTy u1 ty1) (HsUsageTy u2 ty2)
+ = eq_hsType env u1 u2 && eq_hsType env ty1 ty2
+
eq_hsType env (HsOpTy lty1 op1 rty1) (HsOpTy lty2 op2 rty2)
= eq_hsVar env op1 op2 && eq_hsType env lty1 lty2 && eq_hsType env rty1 rty2
-eq_hsType env (HsUsgTy u1 ty1) (HsUsgTy u2 ty2)
- = eqUsg u1 u2 && eq_hsType env ty1 ty2
-
eq_hsType env ty1 ty2 = False
eq_hsContext env a b = eqListBy (eq_hsPred env) a b
-------------------
-eq_hsPred env (HsPClass c1 tys1) (HsPClass c2 tys2)
+eq_hsPred env (HsClassP c1 tys1) (HsClassP c2 tys2)
= c1 == c2 && eq_hsTypes env tys1 tys2
-eq_hsPred env (HsPIParam n1 ty1) (HsPIParam n2 ty2)
+eq_hsPred env (HsIParam n1 ty1) (HsIParam n2 ty2)
= n1 == n2 && eq_hsType env ty1 ty2
eq_hsPred env _ _ = False
-------------------
-eqUsg HsUsOnce HsUsOnce = True
-eqUsg HsUsMany HsUsMany = True
-eqUsg (HsUsVar u1) (HsUsVar u2) = u1 == u2
-eqUsg _ _ = False
-
--------------------
eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool
eqListBy eq [] [] = True
eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys