X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsTypes.lhs;h=f57cbe86c89386ef35f910763ad3738499cff231;hb=cfcebde74cf826af12143a92bcffa8c995eee135;hp=d94e1a234551860da2062eee215f3f78e47d97a0;hpb=6267d836c50aedd5a8c4823732da2948285682d2;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index d94e1a2..f57cbe8 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[HsTypes]{Abstract syntax: user-defined types} @@ -8,27 +8,23 @@ If compiled without \tr{#define COMPILING_GHC}, you get you get part of GHC. \begin{code} -#include "HsVersions.h" - module HsTypes ( HsType(..), HsTyVar(..), - SYN_IE(Context), SYN_IE(ClassAssertion) + Context, ClassAssertion , mkHsForAllTy , getTyVarName, replaceTyVarName , pprParendHsType - , pprContext - , cmpHsType, cmpContext + , pprForAll, pprContext, pprClassAssertion + , cmpHsType, cmpHsTypes, cmpContext ) where -IMP_Ubiq() +#include "HsVersions.h" -import Outputable ( interppSP, ifnotPprForUser ) -import Kind ( Kind {- instance Outputable -} ) -import Name ( nameOccName ) -import Pretty -import PprStyle ( PprStyle(..) ) -import Util ( thenCmp, cmpList, isIn, panic# ) +import Type ( Kind, UsageAnn(..) ) +import PprType ( {- instance Outputable Kind -} ) +import Outputable +import Util ( thenCmp, cmpList ) \end{code} This is the syntax for types as seen in type signatures. @@ -36,47 +32,37 @@ This is the syntax for types as seen in type signatures. \begin{code} type Context name = [ClassAssertion name] -type ClassAssertion name = (name, HsType name) +type ClassAssertion name = (name, [HsType name]) -- The type is usually a type variable, but it -- doesn't have to be when reading interface files data HsType name - = HsPreForAllTy (Context name) - (HsType name) - - -- The renamer turns HsPreForAllTys into HsForAllTys when they - -- occur in signatures, to make the binding of variables - -- explicit. This distinction is made visible for - -- non-COMPILING_GHC code, because you probably want to do the - -- same thing. - - | HsForAllTy [HsTyVar name] + = HsForAllTy (Maybe [HsTyVar name]) -- Nothing for implicitly quantified signatures (Context name) (HsType name) | MonoTyVar name -- Type variable - | MonoTyApp name -- Type constructor or variable - [HsType name] - - -- We *could* have a "MonoTyCon name" equiv to "MonoTyApp name []" - -- (for efficiency, what?) WDP 96/02/18 + | MonoTyApp (HsType name) + (HsType name) | MonoFunTy (HsType name) -- function type (HsType name) - | MonoListTy name -- The list TyCon name - (HsType name) -- Element type + | MonoListTy (HsType name) -- Element type - | MonoTupleTy name -- The tuple TyCon name - [HsType name] -- Element types (length gives arity) + | MonoTupleTy [HsType name] -- Element types (length gives arity) + Bool -- boxed? - -- these next two are only used in unfoldings in interfaces + -- these next two are only used in interfaces | MonoDictTy name -- Class - (HsType name) + [HsType name] + + | MonoUsgTy UsageAnn + (HsType name) mkHsForAllTy [] [] ty = ty -mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty +mkHsForAllTy tvs ctxt ty = HsForAllTy (Just tvs) ctxt ty data HsTyVar name = UserTyVar name @@ -103,30 +89,22 @@ replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k \begin{code} instance (Outputable name) => Outputable (HsType name) where - ppr = pprHsType + ppr ty = pprHsType ty instance (Outputable name) => Outputable (HsTyVar name) where - ppr sty (UserTyVar name) = ppr_hs_tyvar sty name - ppr sty (IfaceTyVar name kind) = ppCat [ppr_hs_tyvar sty name, ppStr "::", ppr sty kind] + ppr (UserTyVar name) = ppr name + ppr (IfaceTyVar name kind) = hsep [ppr name, dcolon, ppr kind] +pprForAll [] = empty +pprForAll tvs = ptext SLIT("forall") <+> interppSP tvs <> ptext SLIT(".") --- Here -ppr_hs_tyvar PprInterface tv_name = ppr PprForUser tv_name -ppr_hs_tyvar other_sty tv_name = ppr other_sty tv_name +pprContext :: (Outputable name) => Context name -> SDoc +pprContext [] = empty +pprContext context = parens (hsep (punctuate comma (map pprClassAssertion context))) <+> ptext SLIT("=>") -ppr_forall sty ctxt_prec [] [] ty - = ppr_mono_ty sty ctxt_prec ty -ppr_forall sty ctxt_prec tvs ctxt ty - = ppSep [ppStr "_forall_", ppBracket (interppSP sty tvs), - pprContext sty ctxt, ppStr "=>", - pprHsType sty ty] - -pprContext :: (Outputable name) => PprStyle -> (Context name) -> Pretty -pprContext sty [] = ppNil -pprContext sty context - = ppCat [ppCurlies (ppIntersperse pp'SP (map ppr_assert context))] - where - ppr_assert (clas, ty) = ppCat [ppr sty clas, ppr sty ty] +pprClassAssertion :: (Outputable name) => ClassAssertion name -> SDoc +pprClassAssertion (clas, tys) + = ppr clas <+> hsep (map pprParendHsType tys) \end{code} \begin{code} @@ -134,46 +112,53 @@ pREC_TOP = (0 :: Int) pREC_FUN = (1 :: Int) pREC_CON = (2 :: Int) -maybeParen :: Bool -> Pretty -> Pretty -maybeParen True p = ppParens p +maybeParen :: Bool -> SDoc -> SDoc +maybeParen True p = parens p maybeParen False p = p -- printing works more-or-less as for Types -pprHsType, pprParendHsType :: (Outputable name) => PprStyle -> HsType name -> Pretty +pprHsType, pprParendHsType :: (Outputable name) => HsType name -> SDoc -pprHsType sty ty = ppr_mono_ty sty pREC_TOP ty -pprParendHsType sty ty = ppr_mono_ty sty pREC_CON ty +pprHsType ty = ppr_mono_ty pREC_TOP ty +pprParendHsType ty = ppr_mono_ty pREC_CON ty -ppr_mono_ty sty ctxt_prec (HsPreForAllTy ctxt ty) = ppr_forall sty ctxt_prec [] ctxt ty -ppr_mono_ty sty ctxt_prec (HsForAllTy tvs ctxt ty) = ppr_forall sty ctxt_prec tvs ctxt ty +ppr_mono_ty ctxt_prec (HsForAllTy maybe_tvs ctxt ty) + = maybeParen (ctxt_prec >= pREC_FUN) $ + sep [pprForAll tvs, pprContext ctxt, pprHsType ty] + where + tvs = case maybe_tvs of + Just tvs -> tvs + Nothing -> [] -ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr_hs_tyvar sty name +ppr_mono_ty ctxt_prec (MonoTyVar name) + = ppr name -ppr_mono_ty sty ctxt_prec (MonoFunTy ty1 ty2) - = let p1 = ppr_mono_ty sty pREC_FUN ty1 - p2 = ppr_mono_ty sty pREC_TOP ty2 +ppr_mono_ty ctxt_prec (MonoFunTy ty1 ty2) + = let p1 = ppr_mono_ty pREC_FUN ty1 + p2 = ppr_mono_ty pREC_TOP ty2 in maybeParen (ctxt_prec >= pREC_FUN) - (ppSep [p1, ppBeside (ppStr "-> ") p2]) + (sep [p1, (<>) (ptext SLIT("-> ")) p2]) + +ppr_mono_ty ctxt_prec (MonoTupleTy tys True) + = parens (sep (punctuate comma (map ppr tys))) +ppr_mono_ty ctxt_prec (MonoTupleTy tys False) + = ptext SLIT("(#") <> sep (punctuate comma (map ppr tys)) <> ptext SLIT("#)") -ppr_mono_ty sty ctxt_prec (MonoTupleTy _ tys) - = ppParens (ppInterleave ppComma (map (ppr sty) tys)) +ppr_mono_ty ctxt_prec (MonoListTy ty) + = brackets (ppr_mono_ty pREC_TOP ty) -ppr_mono_ty sty ctxt_prec (MonoListTy _ ty) - = ppBesides [ppLbrack, ppr_mono_ty sty pREC_TOP ty, ppRbrack] +ppr_mono_ty ctxt_prec (MonoTyApp 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 sty ctxt_prec (MonoTyApp tycon tys) - = let pp_tycon = ppr sty tycon in - if null tys then - pp_tycon - else - maybeParen (ctxt_prec >= pREC_CON) - (ppCat [pp_tycon, ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys)]) +ppr_mono_ty ctxt_prec (MonoDictTy clas tys) + = ppr clas <+> hsep (map (ppr_mono_ty pREC_CON) tys) -ppr_mono_ty sty ctxt_prec (MonoDictTy clas ty) - = ppCurlies (ppCat [ppr sty clas, ppr_mono_ty sty pREC_CON ty]) - -- Curlies are temporary +ppr_mono_ty ctxt_prec (MonoUsgTy u ty) + = maybeParen (ctxt_prec >= pREC_CON) $ + ppr u <+> ppr_mono_ty pREC_CON ty \end{code} @@ -188,64 +173,81 @@ in checking interfaces. Most any other use is likely to be {\em wrong}, so be careful! \begin{code} -cmpHsTyVar :: (a -> a -> TAG_) -> HsTyVar a -> HsTyVar a -> TAG_ -cmpHsType :: (a -> a -> TAG_) -> HsType a -> HsType a -> TAG_ -cmpContext :: (a -> a -> TAG_) -> Context a -> Context a -> TAG_ +cmpHsTyVar :: (a -> a -> Ordering) -> HsTyVar a -> HsTyVar a -> Ordering +cmpHsType :: (a -> a -> Ordering) -> HsType a -> HsType a -> Ordering +cmpHsTypes :: (a -> a -> Ordering) -> [HsType a] -> [HsType a] -> Ordering +cmpContext :: (a -> a -> Ordering) -> Context a -> Context a -> Ordering cmpHsTyVar cmp (UserTyVar v1) (UserTyVar v2) = v1 `cmp` v2 cmpHsTyVar cmp (IfaceTyVar v1 _) (IfaceTyVar v2 _) = v1 `cmp` v2 -cmpHsTyVar cmp (UserTyVar _) other = LT_ -cmpHsTyVar cmp other1 other2 = GT_ +cmpHsTyVar cmp (UserTyVar _) other = LT +cmpHsTyVar cmp other1 other2 = GT --- We assume that HsPreForAllTys have been smashed by now. -# ifdef DEBUG -cmpHsType _ (HsPreForAllTy _ _) _ = panic# "cmpHsType:HsPreForAllTy:1st arg" -cmpHsType _ _ (HsPreForAllTy _ _) = panic# "cmpHsType:HsPreForAllTy:2nd arg" -# endif +cmpHsTypes cmp [] [] = EQ +cmpHsTypes cmp [] tys2 = LT +cmpHsTypes cmp tys1 [] = GT +cmpHsTypes cmp (ty1:tys1) (ty2:tys2) = cmpHsType cmp ty1 ty2 `thenCmp` cmpHsTypes cmp tys1 tys2 cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2) - = cmpList (cmpHsTyVar cmp) tvs1 tvs2 `thenCmp` - cmpContext cmp c1 c2 `thenCmp` + = cmpMaybe (cmpList (cmpHsTyVar cmp)) tvs1 tvs2 `thenCmp` + cmpContext cmp c1 c2 `thenCmp` cmpHsType cmp t1 t2 cmpHsType cmp (MonoTyVar n1) (MonoTyVar n2) = cmp n1 n2 -cmpHsType cmp (MonoTupleTy _ tys1) (MonoTupleTy _ tys2) - = cmpList (cmpHsType cmp) tys1 tys2 -cmpHsType cmp (MonoListTy _ ty1) (MonoListTy _ ty2) +cmpHsType cmp (MonoTupleTy tys1 b1) (MonoTupleTy tys2 b2) + = (b1 `compare` b2) `thenCmp` cmpHsTypes cmp tys1 tys2 + +cmpHsType cmp (MonoListTy ty1) (MonoListTy ty2) = cmpHsType cmp ty1 ty2 -cmpHsType cmp (MonoTyApp tc1 tys1) (MonoTyApp tc2 tys2) - = cmp tc1 tc2 `thenCmp` - cmpList (cmpHsType cmp) tys1 tys2 +cmpHsType cmp (MonoTyApp fun_ty1 arg_ty1) (MonoTyApp fun_ty2 arg_ty2) + = cmpHsType cmp fun_ty1 fun_ty2 `thenCmp` cmpHsType cmp arg_ty1 arg_ty2 cmpHsType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2) = cmpHsType cmp a1 a2 `thenCmp` cmpHsType cmp b1 b2 -cmpHsType cmp (MonoDictTy c1 ty1) (MonoDictTy c2 ty2) - = cmp c1 c2 `thenCmp` cmpHsType cmp ty1 ty2 +cmpHsType cmp (MonoDictTy c1 tys1) (MonoDictTy c2 tys2) + = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2 + +cmpHsType cmp (MonoUsgTy u1 ty1) (MonoUsgTy u2 ty2) + = cmpUsg u1 u2 `thenCmp` cmpHsType cmp ty1 ty2 cmpHsType cmp ty1 ty2 -- tags must be different = let tag1 = tag ty1 tag2 = tag ty2 in - if tag1 _LT_ tag2 then LT_ else GT_ + if tag1 _LT_ tag2 then LT else GT where - tag (MonoTyVar n1) = (ILIT(1) :: FAST_INT) - tag (MonoTupleTy _ tys1) = ILIT(2) - tag (MonoListTy _ ty1) = ILIT(3) - tag (MonoTyApp tc1 tys1) = ILIT(4) - tag (MonoFunTy a1 b1) = ILIT(5) - tag (MonoDictTy c1 ty1) = ILIT(7) - tag (HsForAllTy _ _ _) = ILIT(8) - tag (HsPreForAllTy _ _) = ILIT(9) + tag (MonoTyVar n1) = (ILIT(1) :: FAST_INT) + tag (MonoTupleTy tys1 _) = ILIT(2) + tag (MonoListTy ty1) = ILIT(3) + tag (MonoTyApp tc1 tys1) = ILIT(4) + tag (MonoFunTy a1 b1) = ILIT(5) + tag (MonoDictTy c1 tys1) = ILIT(7) + tag (MonoUsgTy c1 tys1) = ILIT(6) + tag (HsForAllTy _ _ _) = ILIT(8) ------------------- cmpContext cmp a b = cmpList cmp_ctxt a b where - cmp_ctxt (c1, ty1) (c2, ty2) - = cmp c1 c2 `thenCmp` cmpHsType cmp ty1 ty2 + cmp_ctxt (c1, tys1) (c2, tys2) + = cmp c1 c2 `thenCmp` cmpHsTypes cmp tys1 tys2 + +-- Should be in Type, perhaps +cmpUsg UsOnce UsOnce = EQ +cmpUsg UsOnce UsMany = LT +cmpUsg UsMany UsOnce = GT +cmpUsg UsMany UsMany = EQ +cmpUsg u1 u2 = pprPanic "cmpUsg:" $ + ppr u1 <+> ppr u2 + +-- Should be in Maybes, I guess +cmpMaybe cmp Nothing Nothing = EQ +cmpMaybe cmp Nothing (Just x) = LT +cmpMaybe cmp (Just x) Nothing = GT +cmpMaybe cmp (Just x) (Just y) = x `cmp` y \end{code}