X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsTypes.lhs;h=15bc03f0eb4e8eedf7e747fb522518edb10bff6d;hb=f587e76c3314fb89ba898b4c2aa2f5e5ef56c4f6;hp=a37e27db72e649383ca489033525505242006178;hpb=788faebb40b51d37e73ed94dfc99460d39a1a811;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index a37e27d..15bc03f 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -12,9 +12,13 @@ module HsTypes ( , mkHsForAllTy, mkHsDictTy, mkHsIParamTy , hsTyVarName, hsTyVarNames, replaceTyVarName + , getHsInstHead + + -- Type place holder + , PostTcType, placeHolderType, -- Printing - , pprParendHsType, pprHsForAll, pprHsContext, pprHsTyVarBndr + , pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr -- Equality over Hs things , EqHsEnv, emptyEqHsEnv, extendEqHsEnv, @@ -27,33 +31,57 @@ module HsTypes ( #include "HsVersions.h" import Class ( FunDep ) -import Type ( Type, Kind, ThetaType, PredType(..), - splitSigmaTy, liftedTypeKind +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 ) import OccName ( NameSpace, tvName ) import Var ( TyVar, tyVarKind ) -import Subst ( mkTyVarSubst, substTy ) +import Subst ( substTyWith ) import PprType ( {- instance Outputable Kind -}, pprParendKind ) -import BasicTypes ( Boxity(..), Arity, tupleParens ) +import BasicTypes ( Boxity(..), Arity, IPName, tupleParens ) import PrelNames ( mkTupConRdrName, listTyConKey, usOnceTyConKey, usManyTyConKey, hasKey, usOnceTyConName, usManyTyConName ) import FiniteMap +import Util ( eqListBy, lengthIs ) import Outputable +\end{code} + + +%************************************************************************ +%* * +\subsection{Annotating the syntax} +%* * +%************************************************************************ + +\begin{code} +type PostTcType = Type -- Used for slots in the abstract syntax + -- where we want to keep slot for a type + -- to be added by the type checker...but + -- before typechecking it's just bogus +placeHolderType :: PostTcType -- Used before typechecking +placeHolderType = panic "Evaluated the place holder for a PostTcType" \end{code} + +%************************************************************************ +%* * +\subsection{Data types} +%* * +%************************************************************************ + This is the syntax for types as seen in type signatures. \begin{code} type HsContext name = [HsPred name] data HsPred name = HsClassP name [HsType name] - | HsIParam name (HsType name) + | HsIParam (IPName name) (HsType name) data HsType name = HsForAllTy (Maybe [HsTyVarBndr name]) -- Nothing for implicitly quantified signatures @@ -75,6 +103,7 @@ data HsType name -- Generics | HsOpTy (HsType name) name (HsType name) | HsNumTy Integer + -- these next two are only used in interfaces | HsPredTy (HsPred name) @@ -144,6 +173,27 @@ replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k \end{code} +\begin{code} +getHsInstHead :: HsType name -> ([HsTyVarBndr name], (name, [HsType name])) + -- Split up an instance decl type, returning the 'head' part + +-- In interface fiels, the type of the decl is held like this: +-- forall a. Foo a -> Baz (T a) +-- so we have to strip off function argument types, +-- as well as the bit before the '=>' (which is always +-- empty in interface files) +-- +-- The parser ensures the type will have the right shape. +-- (e.g. see ParseUtil.checkInstType) + +getHsInstHead (HsForAllTy (Just tvs) _ tau) = (tvs, get_head1 tau) +getHsInstHead tau = ([], get_head1 tau) + +get_head1 (HsFunTy _ ty) = get_head1 ty +get_head1 (HsPredTy (HsClassP cls tys)) = (cls,tys) +\end{code} + + %************************************************************************ %* * \subsection{Pretty printing} @@ -163,11 +213,11 @@ instance (Outputable name) => Outputable (HsTyVarBndr name) where instance Outputable name => Outputable (HsPred name) where ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprParendHsType tys) - ppr (HsIParam n ty) = hsep [char '?' <> ppr n, text "::", ppr ty] + ppr (HsIParam n ty) = hsep [ppr n, dcolon, ppr ty] pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc -pprHsTyVarBndr name kind | kind == liftedTypeKind = 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 @@ -179,21 +229,17 @@ pprHsForAll tvs cxt 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 - ppr_context cxt <+> ptext SLIT("=>") - ) + pprHsContext cxt else -- Used in interfaces ptext SLIT("__forall") <+> interppSP tvs <+> - ppr_context cxt <+> ptext SLIT("=>") + ppr_hs_context cxt <+> ptext SLIT("=>") pprHsContext :: (Outputable name) => HsContext name -> SDoc pprHsContext [] = empty -pprHsContext cxt = ppr_context cxt <+> ptext SLIT("=>") +pprHsContext cxt = ppr_hs_context cxt <+> ptext SLIT("=>") -ppr_context [] = empty -ppr_context cxt = parens (interpp'SP cxt) +ppr_hs_context [] = empty +ppr_hs_context cxt = parens (interpp'SP cxt) \end{code} \begin{code} @@ -274,19 +320,18 @@ 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 = +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 = substTyWith 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 @@ -299,9 +344,10 @@ toHsType (NoteTy (SynNote syn_ty) real_ty) -- 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 @@ -313,9 +359,9 @@ toHsType ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of where generic_case = foldl HsAppTy (HsTyVar (getName tc)) tys' tys' = map toHsType tys - saturated = length tys == tyConArity tc + saturated = tys `lengthIs` 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) @@ -325,7 +371,7 @@ toHsType (UsageTy u ty) = HsUsageTy (toHsType u) (toHsType ty) toHsPred (ClassP cls tys) = HsClassP (getName cls) (map toHsType tys) -toHsPred (IParam n ty) = HsIParam (getName n) (toHsType ty) +toHsPred (IParam n ty) = HsIParam n (toHsType ty) toHsContext :: ThetaType -> HsContext Name toHsContext theta = map toHsPred theta @@ -384,7 +430,7 @@ eq_hsTyVars env (tv1:tvs1) (tv2:tvs2) k = eq_hsTyVar env tv1 tv2 $ \ env -> 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 @@ -443,10 +489,4 @@ eq_hsPred env (HsClassP c1 tys1) (HsClassP c2 tys2) eq_hsPred env (HsIParam n1 ty1) (HsIParam n2 ty2) = n1 == n2 && eq_hsType env ty1 ty2 eq_hsPred env _ _ = False - -------------------- -eqListBy :: (a->a->Bool) -> [a] -> [a] -> Bool -eqListBy eq [] [] = True -eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys -eqListBy eq xs ys = False \end{code}