X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FhsSyn%2FHsTypes.lhs;h=b83f4b8fcd4e2fe5bd090f0c5ed961299aab7aba;hb=9c26739695219d8343505a88457cb55c76b65449;hp=d94e1a234551860da2062eee215f3f78e47d97a0;hpb=6267d836c50aedd5a8c4823732da2948285682d2;p=ghc-hetmet.git diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index d94e1a2..b83f4b8 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -23,11 +23,11 @@ module HsTypes ( IMP_Ubiq() -import Outputable ( interppSP, ifnotPprForUser ) +import CmdLineOpts ( opt_PprUserLength ) +import Outputable ( Outputable(..), PprStyle(..), pprQuote, interppSP ) import Kind ( Kind {- instance Outputable -} ) import Name ( nameOccName ) import Pretty -import PprStyle ( PprStyle(..) ) import Util ( thenCmp, cmpList, isIn, panic# ) \end{code} @@ -56,11 +56,8 @@ data 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) @@ -103,30 +100,27 @@ replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k \begin{code} instance (Outputable name) => Outputable (HsType name) where - ppr = pprHsType + ppr sty ty = pprQuote sty $ \ sty -> pprHsType sty 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] - - --- Here -ppr_hs_tyvar PprInterface tv_name = ppr PprForUser tv_name -ppr_hs_tyvar other_sty tv_name = ppr other_sty tv_name + 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 - = ppSep [ppStr "_forall_", ppBracket (interppSP sty tvs), - pprContext sty ctxt, ppStr "=>", + = 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) -> Pretty -pprContext sty [] = ppNil +pprContext :: (Outputable name) => PprStyle -> (Context name) -> Doc +pprContext sty [] = empty pprContext sty context - = ppCat [ppCurlies (ppIntersperse pp'SP (map ppr_assert context))] + = hsep [braces (hsep (punctuate comma (map ppr_assert context)))] where - ppr_assert (clas, ty) = ppCat [ppr sty clas, ppr sty ty] + ppr_assert (clas, ty) = hsep [ppr sty clas, ppr sty ty] \end{code} \begin{code} @@ -134,13 +128,13 @@ pREC_TOP = (0 :: Int) pREC_FUN = (1 :: Int) pREC_CON = (2 :: Int) -maybeParen :: Bool -> Pretty -> Pretty -maybeParen True p = ppParens p +maybeParen :: Bool -> Doc -> Doc +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) => PprStyle -> HsType name -> Doc pprHsType sty ty = ppr_mono_ty sty pREC_TOP ty pprParendHsType sty ty = ppr_mono_ty sty pREC_CON ty @@ -148,32 +142,27 @@ pprParendHsType sty ty = ppr_mono_ty sty 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 sty ctxt_prec (MonoTyVar name) = ppr_hs_tyvar sty name +ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr sty 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 in maybeParen (ctxt_prec >= pREC_FUN) - (ppSep [p1, ppBeside (ppStr "-> ") p2]) + (sep [p1, (<>) (ptext SLIT("-> ")) p2]) ppr_mono_ty sty ctxt_prec (MonoTupleTy _ tys) - = ppParens (ppInterleave ppComma (map (ppr sty) tys)) + = parens (sep (punctuate comma (map (ppr sty) tys))) ppr_mono_ty sty ctxt_prec (MonoListTy _ ty) - = ppBesides [ppLbrack, ppr_mono_ty sty pREC_TOP ty, ppRbrack] + = brackets (ppr_mono_ty sty pREC_TOP 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 sty 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]) ppr_mono_ty sty ctxt_prec (MonoDictTy clas ty) - = ppCurlies (ppCat [ppr sty clas, ppr_mono_ty sty pREC_CON ty]) - -- Curlies are temporary + = hsep [ppr sty clas, ppr_mono_ty sty pREC_CON ty] \end{code} @@ -189,8 +178,8 @@ 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_ +--cmpHsType :: (a -> a -> TAG_) -> HsType a -> HsType a -> TAG_ +--cmpContext :: (a -> a -> TAG_) -> Context a -> Context a -> TAG_ cmpHsTyVar cmp (UserTyVar v1) (UserTyVar v2) = v1 `cmp` v2 cmpHsTyVar cmp (IfaceTyVar v1 _) (IfaceTyVar v2 _) = v1 `cmp` v2 @@ -217,9 +206,8 @@ cmpHsType cmp (MonoTupleTy _ tys1) (MonoTupleTy _ 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