X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsTypes.lhs;h=e64c34ae34d5082235942374d1847e67a7e44a24;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=195809dc3427c93826d646e92d417de2960a401a;hpb=1fb1ab5d53a09607e7f6d2450806760688396387;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 195809d..e64c34a 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 ) +import PprType ( {- instance Outputable Kind -} ) +import Outputable +import Util ( thenCmp, cmpList, panic ) \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 [HsTyVar name] (Context name) (HsType name) @@ -62,15 +49,14 @@ 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 | MonoDictTy name -- Class - (HsType name) + [HsType name] mkHsForAllTy [] [] ty = ty mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty @@ -100,34 +86,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_tyname sty name - ppr sty (IfaceTyVar name kind) = ppCat [ppr_hs_tyname sty name, ppPStr SLIT("::"), ppr sty kind] - - --- Here comes a rather gross hack. --- We want to print data and class decls in interface files, from the original source --- When we do, we want the type variables to come out with their original names, not --- some new unique (or else interfaces wobble too much). So when we come to one of --- these type variables we sneakily change the style to PprForUser! -ppr_hs_tyname PprInterface tv_name = ppr PprForUser tv_name -ppr_hs_tyname other_sty tv_name = ppr other_sty tv_name - -ppr_forall sty ctxt_prec [] [] ty - = ppr_mono_ty sty ctxt_prec ty -ppr_forall sty ctxt_prec tvs ctxt ty - = ppSep [ppPStr SLIT("_forall_"), ppBracket (interppSP sty tvs), - pprContext sty ctxt, ppPStr SLIT("=>"), - 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] + ppr (UserTyVar name) = ppr name + ppr (IfaceTyVar name kind) = hsep [ppr name, ptext SLIT("::"), 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 ppr tys) \end{code} \begin{code} @@ -135,42 +109,45 @@ 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 tvs ctxt ty) + = maybeParen (ctxt_prec >= pREC_FUN) $ + sep [pprForAll tvs, pprContext ctxt, pprHsType ty] -ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr_hs_tyname 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 (ppPStr SLIT("-> ")) p2]) + (sep [p1, (<>) (ptext SLIT("-> ")) p2]) -ppr_mono_ty sty ctxt_prec (MonoTupleTy _ tys) - = ppParens (ppInterleave ppComma (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) - = ppBesides [ppLbrack, ppr_mono_ty sty pREC_TOP ty, ppRbrack] +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) - (ppCat [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 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 (MonoDictTy clas tys) + = ppr clas <+> hsep (map (ppr_mono_ty pREC_CON) tys) \end{code} @@ -185,21 +162,21 @@ 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` @@ -209,9 +186,10 @@ cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 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) @@ -220,28 +198,27 @@ 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 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 (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 \end{code}