X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FhsSyn%2FHsTypes.lhs;h=f57cbe86c89386ef35f910763ad3738499cff231;hb=cfcebde74cf826af12143a92bcffa8c995eee135;hp=ba9adf6eae97d45faf6d315d18e1a01d1c68c314;hpb=38db229302890403037c5de7453299b3538bb404;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index ba9adf6..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 CmdLineOpts ( opt_PprUserLength ) -import Outputable ( Outputable(..), PprStyle(..), pprQuote, interppSP ) -import Kind ( Kind {- instance Outputable -} ) -import Name ( nameOccName ) -import Pretty -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,21 +32,12 @@ 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) @@ -62,18 +49,20 @@ data 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 @@ -100,27 +89,22 @@ replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k \begin{code} instance (Outputable name) => Outputable (HsType name) where - ppr sty ty = pprQuote sty $ \ sty -> pprHsType sty ty + ppr ty = pprHsType ty instance (Outputable name) => Outputable (HsTyVar name) where - ppr sty (UserTyVar name) = ppr sty name - ppr sty (IfaceTyVar name kind) = pprQuote sty $ \ sty -> - hsep [ppr sty name, ptext SLIT("::"), ppr sty kind] - -ppr_forall sty ctxt_prec [] [] ty - = ppr_mono_ty sty ctxt_prec ty -ppr_forall sty ctxt_prec tvs ctxt ty - = maybeParen (ctxt_prec >= pREC_FUN) $ - sep [ptext SLIT("_forall_"), brackets (interppSP sty tvs), - pprContext sty ctxt, ptext SLIT("=>"), - pprHsType sty ty] - -pprContext :: (Outputable name) => PprStyle -> (Context name) -> Doc -pprContext sty [] = empty -pprContext sty context - = pprQuote sty $ \ sty -> parens (hsep (punctuate comma (map ppr_assert context))) - where - ppr_assert (clas, ty) = hsep [ppr sty clas, ppr sty ty] + 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(".") + +pprContext :: (Outputable name) => Context name -> SDoc +pprContext [] = empty +pprContext context = parens (hsep (punctuate comma (map pprClassAssertion context))) <+> ptext SLIT("=>") + +pprClassAssertion :: (Outputable name) => ClassAssertion name -> SDoc +pprClassAssertion (clas, tys) + = ppr clas <+> hsep (map pprParendHsType tys) \end{code} \begin{code} @@ -128,41 +112,53 @@ pREC_TOP = (0 :: Int) pREC_FUN = (1 :: Int) pREC_CON = (2 :: Int) -maybeParen :: Bool -> Doc -> Doc +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 -> Doc +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 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) (sep [p1, (<>) (ptext SLIT("-> ")) p2]) -ppr_mono_ty sty ctxt_prec (MonoTupleTy _ tys) - = parens (sep (punctuate comma (map (ppr sty) tys))) +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 (MonoListTy _ ty) - = brackets (ppr_mono_ty sty pREC_TOP ty) +ppr_mono_ty ctxt_prec (MonoListTy ty) + = brackets (ppr_mono_ty pREC_TOP ty) -ppr_mono_ty sty ctxt_prec (MonoTyApp fun_ty arg_ty) +ppr_mono_ty ctxt_prec (MonoTyApp fun_ty arg_ty) = maybeParen (ctxt_prec >= pREC_CON) - (hsep [ppr_mono_ty sty pREC_FUN fun_ty, ppr_mono_ty sty pREC_CON arg_ty]) + (hsep [ppr_mono_ty pREC_FUN fun_ty, ppr_mono_ty pREC_CON arg_ty]) + +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) - = hsep [ppr sty clas, ppr_mono_ty sty pREC_CON ty] +ppr_mono_ty ctxt_prec (MonoUsgTy u ty) + = maybeParen (ctxt_prec >= pREC_CON) $ + ppr u <+> ppr_mono_ty pREC_CON ty \end{code} @@ -177,33 +173,34 @@ 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 fun_ty1 arg_ty1) (MonoTyApp fun_ty2 arg_ty2) @@ -212,28 +209,45 @@ cmpHsType cmp (MonoTyApp fun_ty1 arg_ty1) (MonoTyApp fun_ty2 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}