X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsTypes.lhs;h=bfacdcd4afabc5fc9f7e8f1a24d36e9402240749;hb=2205f0ceeb65d8acb7db953bf4fd2ad673dc55ee;hp=49040bfc0e4a765a283d34ef7bacd52e883e03ee;hpb=5d095cc1308afc5e539174f33fd3ff2bd9788bbd;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 49040bf..bfacdcd 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -5,19 +5,23 @@ \begin{code} module HsTypes ( - HsType(..), HsTyVarBndr(..), + HsType(..), HsTyVarBndr(..), HsTyOp(..), , HsContext, HsPred(..) , HsTupCon(..), hsTupParens, mkHsTupCon, , hsUsOnce, hsUsMany , mkHsForAllTy, mkHsDictTy, mkHsIParamTy - , hsTyVarName, hsTyVarNames, replaceTyVarName, + , hsTyVarName, hsTyVarNames, replaceTyVarName + , getHsInstHead -- Type place holder - PostTcType, placeHolderType, + , PostTcType, placeHolderType, + + -- Name place holder + , SyntaxName, placeHolderName, -- Printing - , pprParendHsType, pprHsForAll, pprHsContext, pprHsTyVarBndr + , pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr -- Equality over Hs things , EqHsEnv, emptyEqHsEnv, extendEqHsEnv, @@ -36,17 +40,18 @@ import TcType ( Type, Kind, ThetaType, SourceType(..), import TypeRep ( Type(..), TyNote(..) ) -- toHsType sees the representation import TyCon ( isTupleTyCon, tupleTyConBoxity, tyConArity, isNewTyCon, getSynTyConDefn ) import RdrName ( RdrName, mkUnqual ) -import Name ( Name, getName ) -import OccName ( NameSpace, tvName ) +import Name ( Name, getName, mkInternalName ) +import OccName ( NameSpace, mkVarOcc, tvName ) import Var ( TyVar, tyVarKind ) import Subst ( substTyWith ) -import PprType ( {- instance Outputable Kind -}, pprParendKind ) -import BasicTypes ( Boxity(..), Arity, tupleParens ) -import PrelNames ( mkTupConRdrName, listTyConKey, usOnceTyConKey, usManyTyConKey, hasKey, - usOnceTyConName, usManyTyConName - ) +import PprType ( {- instance Outputable Kind -}, pprParendKind, pprKind ) +import BasicTypes ( Boxity(..), Arity, IPName, tupleParens ) +import PrelNames ( mkTupConRdrName, listTyConKey, parrTyConKey, + usOnceTyConKey, usManyTyConKey, hasKey, unboundKey, + usOnceTyConName, usManyTyConName ) +import SrcLoc ( builtinSrcLoc ) +import Util ( eqListBy, lengthIs ) import FiniteMap -import Util ( eqListBy ) import Outputable \end{code} @@ -65,6 +70,18 @@ type PostTcType = Type -- Used for slots in the abstract syntax placeHolderType :: PostTcType -- Used before typechecking placeHolderType = panic "Evaluated the place holder for a PostTcType" + + +type SyntaxName = Name -- These names are filled in by the renamer + -- Before then they are a placeHolderName (so that + -- we can still print the HsSyn) + -- They correspond to "rebindable syntax"; + -- See RnEnv.lookupSyntaxName + +placeHolderName :: SyntaxName +placeHolderName = mkInternalName unboundKey + (mkVarOcc FSLIT("syntaxPlaceHolder")) + builtinSrcLoc \end{code} @@ -80,7 +97,7 @@ This is the syntax for types as seen in type signatures. 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 @@ -92,28 +109,40 @@ data HsType name | HsAppTy (HsType name) (HsType name) - | HsFunTy (HsType name) -- function type + | HsFunTy (HsType name) -- function type (HsType name) | HsListTy (HsType name) -- Element type + | HsPArrTy (HsType name) -- Elem. type of parallel array: [:t:] + | HsTupleTy (HsTupCon name) [HsType name] -- Element types (length gives arity) - -- Generics - | HsOpTy (HsType name) name (HsType name) - | HsNumTy Integer + + | HsOpTy (HsType name) (HsTyOp name) (HsType name) + + | HsParTy (HsType name) -- Parenthesis preserved for the + -- precedence parser; are removed by + -- the type checker + + | HsNumTy Integer -- Generics only -- these next two are only used in interfaces | HsPredTy (HsPred name) - - | HsUsageTy (HsType name) -- Usage annotation - (HsType name) -- Annotated type + | HsKindSig (HsType name) -- (ty :: kind) + Kind -- A type with a kind signature + + +data HsTyOp name = HsArrow | HsTyOp name + -- Function arrows from *source* get read in as HsOpTy t1 HsArrow t2 + -- But when we generate or parse interface files, we use HsFunTy. + -- This keeps interfaces a bit smaller, because there are a lot of arrows ----------------------- hsUsOnce, hsUsMany :: HsType RdrName -hsUsOnce = HsTyVar (mkUnqual tvName SLIT(".")) -- deep magic -hsUsMany = HsTyVar (mkUnqual tvName SLIT("!")) -- deep magic +hsUsOnce = HsTyVar (mkUnqual tvName FSLIT(".")) -- deep magic +hsUsMany = HsTyVar (mkUnqual tvName FSLIT("!")) -- deep magic hsUsOnce_Name, hsUsMany_Name :: HsType Name hsUsOnce_Name = HsTyVar usOnceTyConName @@ -172,6 +201,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} @@ -185,13 +235,17 @@ NB: these types get printed into interface files, so instance (Outputable name) => Outputable (HsType name) where ppr ty = pprHsType ty +instance (Outputable name) => Outputable (HsTyOp name) where + ppr HsArrow = ftext FSLIT("->") + ppr (HsTyOp n) = ppr n + instance (Outputable name) => Outputable (HsTyVarBndr name) where ppr (UserTyVar name) = ppr name ppr (IfaceTyVar name kind) = pprHsTyVarBndr name kind 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 `eqKind` liftedTypeKind = ppr name @@ -207,21 +261,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} @@ -259,24 +309,28 @@ ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) (sep [p1, (<>) (ptext SLIT("-> ")) p2]) ppr_mono_ty ctxt_prec (HsTupleTy con tys) = hsTupParens con (interpp'SP tys) +ppr_mono_ty ctxt_prec (HsKindSig ty kind) = parens (ppr_mono_ty pREC_TOP ty <+> dcolon <+> pprKind kind) ppr_mono_ty ctxt_prec (HsListTy ty) = brackets (ppr_mono_ty pREC_TOP ty) +ppr_mono_ty ctxt_prec (HsPArrTy ty) = pabrackets (ppr_mono_ty pREC_TOP ty) + where + pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) - = maybeParen (ctxt_prec >= pREC_CON) - (hsep [ppr_mono_ty pREC_FUN fun_ty, ppr_mono_ty pREC_CON arg_ty]) +ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) = + maybeParen (ctxt_prec >= pREC_CON) + (hsep [ppr_mono_ty pREC_FUN fun_ty, ppr_mono_ty pREC_CON arg_ty]) ppr_mono_ty ctxt_prec (HsPredTy pred) = braces (ppr pred) -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 (HsOpTy ty1 op ty2) = + maybeParen (ctxt_prec >= pREC_FUN) + (ppr_mono_ty pREC_FUN ty1 <+> ppr op <+> ppr_mono_ty pREC_FUN ty2) + +ppr_mono_ty ctxt_prec (HsParTy ty) = ppr_mono_ty ctxt_prec ty + -- `HsParTy' isn't useful for pretty printing, as it is removed by the type + -- checker and we need to be able to pretty print after type checking --- 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 +ppr_mono_ty ctxt_prec (HsNumTy n) = integer n -- generics only \end{code} @@ -335,25 +389,22 @@ toHsType ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of | not saturated = generic_case | isTupleTyCon tc = HsTupleTy (HsTupCon (getName tc) (tupleTyConBoxity tc) (tyConArity tc)) tys' | tc `hasKey` listTyConKey = HsListTy (head tys') + | tc `hasKey` parrTyConKey = HsPArrTy (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 (getName tc)) tys' tys' = map toHsType tys - saturated = length tys == tyConArity tc + saturated = tys `lengthIs` tyConArity tc toHsType ty@(ForAllTy _ _) = case tcSplitSigmaTy 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 (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 @@ -444,6 +495,12 @@ eq_hsType env (HsTupleTy c1 tys1) (HsTupleTy c2 tys2) eq_hsType env (HsListTy ty1) (HsListTy ty2) = eq_hsType env ty1 ty2 +eq_hsType env (HsKindSig ty1 k1) (HsKindSig ty2 k2) + = eq_hsType env ty1 ty2 && k1 `eqKind` k2 + +eq_hsType env (HsPArrTy ty1) (HsPArrTy ty2) + = eq_hsType env ty1 ty2 + eq_hsType env (HsAppTy fun_ty1 arg_ty1) (HsAppTy fun_ty2 arg_ty2) = eq_hsType env fun_ty1 fun_ty2 && eq_hsType env arg_ty1 arg_ty2 @@ -453,15 +510,16 @@ eq_hsType env (HsFunTy a1 b1) (HsFunTy a2 b2) 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_hsOp env op1 op2 && eq_hsType env lty1 lty2 && eq_hsType env rty1 rty2 eq_hsType env ty1 ty2 = False +eq_hsOp env (HsTyOp n1) (HsTyOp n2) = eq_hsVar env n1 n2 +eq_hsOp env HsArrow HsArrow = True +eq_hsOp env op1 op2 = False + ------------------- eq_hsContext env a b = eqListBy (eq_hsPred env) a b