#include "HsVersions.h"
import Class ( FunDep )
-import Type ( Type, Kind, PredType(..), ClassContext,
- splitSigmaTy, boxedTypeKind
+import TcType ( Type, Kind, ThetaType, SourceType(..),
+ tcSplitSigmaTy, liftedTypeKind, eqKind, tcEqType
)
import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation
-import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity, getSynTyConDefn )
+import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity, isNewTyCon, getSynTyConDefn )
import RdrName ( RdrName, mkUnqual )
-import Name ( Name, getName, setLocalNameSort )
+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 BasicTypes ( Boxity(..), Arity, tupleParens )
import PrelNames ( mkTupConRdrName, listTyConKey, usOnceTyConKey, usManyTyConKey, hasKey,
usOnceTyConName, usManyTyConName
)
\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
-- Generics
| HsOpTy (HsType name) name (HsType name)
| HsNumTy Integer
+
-- these next two are only used in interfaces
| HsPredTy (HsPred name)
hsUsMany = HsTyVar (mkUnqual tvName SLIT("!")) -- deep magic
hsUsOnce_Name, hsUsMany_Name :: HsType Name
--- Fudge the TyConName so that it prints unqualified
--- I hate it! I hate it!
-hsUsOnce_Name = HsTyVar (setLocalNameSort usOnceTyConName False)
-hsUsMany_Name = HsTyVar (setLocalNameSort usManyTyConName False)
+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
-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 `eqKind` liftedTypeKind = ppr name
+ | otherwise = hsep [ppr name, dcolon, pprParendKind kind]
pprHsForAll [] [] = empty
pprHsForAll tvs cxt
(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)
+ = braces (ppr pred)
ppr_mono_ty ctxt_prec (HsUsageTy u ty)
= maybeParen (ctxt_prec >= pREC_CON)
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 =
+toHsType (NoteTy (SynNote ty@(TyConApp tycon tyargs)) real_ty)
+ | isNewTyCon tycon = toHsType ty
+ | syn_matches = toHsType ty -- Use synonyms if possible!!
+ | otherwise =
#ifdef DEBUG
- pprTrace "WARNING: synonym info lost in .hi file for " (ppr syn_ty) $
+ pprTrace "WARNING: synonym info lost in .hi file for " (ppr syn_ty) $
#endif
- toHsType real_ty -- but drop it if not.
+ 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
+ syn_matches = ty_from_syn `tcEqType` real_ty
+ (tyvars,syn_ty) = getSynTyConDefn tycon
+ ty_from_syn = substTy (mkTyVarSubst tyvars tyargs) syn_ty
-- We only use the type synonym in the file if this doesn't cause
-- us to lose important information. This matters for usage
-- error messages, but it's too much work for right now.
-- KSW 2000-07.
-toHsType (NoteTy _ ty) = toHsType ty
+toHsType (NoteTy _ ty) = toHsType ty
-toHsType (PredTy p) = HsPredTy (toHsPred p)
+toHsType (SourceTy (NType tc tys)) = foldl HsAppTy (HsTyVar (getName tc)) (map toHsType tys)
+toHsType (SourceTy pred) = HsPredTy (toHsPred pred)
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)) tys'
+ | 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
tys' = map toHsType tys
saturated = length tys == tyConArity tc
-toHsType ty@(ForAllTy _ _) = case splitSigmaTy ty of
+toHsType ty@(ForAllTy _ _) = case tcSplitSigmaTy ty of
(tvs, preds, tau) -> HsForAllTy (Just (map toHsTyVar tvs))
(map toHsPred preds)
(toHsType tau)
-- **! consider dropping usMany annotations ToDo KSW 2000-10
-toHsPred (Class cls tys) = HsPClass (getName cls) (map toHsType tys)
-toHsPred (IParam n ty) = HsPIParam (getName n) (toHsType ty)
+toHsPred (ClassP cls tys) = HsClassP (getName cls) (map toHsType tys)
+toHsPred (IParam n ty) = HsIParam (getName n) (toHsType ty)
-toHsContext :: ClassContext -> HsContext Name
-toHsContext cxt = [HsPClass (getName cls) (map toHsType tys) | (cls,tys) <- cxt]
+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]
eq_hsTyVars env _ _ _ = False
eq_hsTyVar env (UserTyVar v1) (UserTyVar v2) k = k (extendEqHsEnv env v1 v2)
-eq_hsTyVar env (IfaceTyVar v1 k1) (IfaceTyVar v2 k2) k = k1 == k2 && k (extendEqHsEnv env v1 v2)
+eq_hsTyVar env (IfaceTyVar v1 k1) (IfaceTyVar v2 k2) k = k1 `eqKind` k2 && k (extendEqHsEnv env v1 v2)
eq_hsTyVar env _ _ _ = False
eq_hsVars env [] [] k = k env
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
projects / ghc-hetmet.git / blobdiff