X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FPprTyThing.hs;h=c379d972d968d681a6f4471b76922d7701c4ac4b;hb=8cf861ba91941412e93f70a916233223aebf686e;hp=d58bd110923b487d29b214671f272ad23e2e9194;hpb=3b1438a9757639d7f37f10e1237e2369ca0ebe4a;p=ghc-hetmet.git diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index d58bd11..c379d97 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -1,3 +1,10 @@ +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + ----------------------------------------------------------------------------- -- -- Pretty-printing TyThings @@ -6,29 +13,25 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module PprTyThing ( PrintExplicitForalls, pprTyThing, pprTyThingInContext, pprTyThingLoc, pprTyThingInContextLoc, - pprTyThingHdr + pprTyThingHdr, + pprTypeForUser ) where #include "HsVersions.h" import qualified GHC -import TyCon ( tyConFamInst_maybe ) -import Type ( pprTypeApp ) -import GHC ( TyThing(..), SrcSpan ) +import GHC ( TyThing(..) ) +import TyCon ( tyConFamInst_maybe, isAlgTyCon, tyConStupidTheta ) +import Type ( TyThing(..), tidyTopType, pprTypeApp ) +import TcType ( tcMultiSplitSigmaTy, mkPhiTy ) +import SrcLoc ( SrcSpan ) import Var import Name import Outputable @@ -83,7 +86,7 @@ pprTyConHdr pefas tyCon | Just (fam_tc, tys) <- tyConFamInst_maybe tyCon = ptext keyword <+> ptext SLIT("instance") <+> pprTypeApp tyCon (ppr_bndr tyCon) tys | otherwise - = ptext keyword <+> opt_family <+> ppr_bndr tyCon <+> hsep (map ppr vars) + = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars) where vars | GHC.isPrimTyCon tyCon || GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars @@ -97,8 +100,12 @@ pprTyConHdr pefas tyCon | GHC.isOpenTyCon tyCon = ptext SLIT("family") | otherwise = empty + opt_stupid -- The "stupid theta" part of the declaration + | isAlgTyCon tyCon = GHC.pprThetaArrow (tyConStupidTheta tyCon) + | otherwise = empty -- Returns 'empty' if null theta + pprDataConSig pefas dataCon = - ppr_bndr dataCon <+> dcolon <+> pprType pefas (GHC.dataConType dataCon) + ppr_bndr dataCon <+> dcolon <+> pprTypeForUser pefas (GHC.dataConType dataCon) pprClassHdr pefas cls = let (tyVars, funDeps) = GHC.classTvsFds cls @@ -122,21 +129,33 @@ pprRecordSelector pefas id pprId :: PrintExplicitForalls -> Var -> SDoc pprId pefas ident - = hang (ppr_bndr ident <+> dcolon) 2 - (pprType pefas (GHC.idType ident)) - -pprType :: PrintExplicitForalls -> GHC.Type -> SDoc -pprType True ty = ppr ty -pprType False ty = ppr (GHC.dropForAlls ty) + = hang (ppr_bndr ident <+> dcolon) + 2 (pprTypeForUser pefas (GHC.idType ident)) + +pprTypeForUser :: PrintExplicitForalls -> GHC.Type -> SDoc +-- We do two things here. +-- a) We tidy the type, regardless +-- b) If PrintExplicitForAlls is True, we discard the foralls +-- but we do so `deeply' +-- Prime example: a class op might have type +-- forall a. C a => forall b. Ord b => stuff +-- Then we want to display +-- (C a, Ord b) => stuff +pprTypeForUser print_foralls ty + | print_foralls = ppr tidy_ty + | otherwise = ppr (mkPhiTy [p | (_tvs, ps) <- ctxt, p <- ps] ty') + where + tidy_ty = tidyTopType ty + (ctxt, ty') = tcMultiSplitSigmaTy tidy_ty pprTyCon pefas tyCon | GHC.isSynTyCon tyCon = if GHC.isOpenTyCon tyCon then pprTyConHdr pefas tyCon <+> dcolon <+> - pprType pefas (GHC.synTyConResKind tyCon) + pprTypeForUser pefas (GHC.synTyConResKind tyCon) else let rhs_type = GHC.synTyConType tyCon - in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprType pefas rhs_type) + in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprTypeForUser pefas rhs_type) | otherwise = pprAlgTyCon pefas tyCon (const True) (const True) @@ -175,7 +194,7 @@ pprDataConDecl pefas gadt_style show_label dataCon -- printing out the dataCon as a type signature, in GADT style pp_tau = foldr add (ppr res_ty) tys_w_strs - add (str,ty) pp_ty = pprBangTy str ty <+> arrow <+> pp_ty + add str_ty pp_ty = pprParendBangTy str_ty <+> arrow <+> pp_ty pprParendBangTy (strict,ty) | GHC.isMarkedStrict strict = char '!' <> GHC.pprParendType ty @@ -209,21 +228,31 @@ pprClass pefas cls where methods = GHC.classMethods cls -pprClassOneMethod pefas cls this_one = - hang (pprClassHdr pefas cls <+> ptext SLIT("where")) - 2 (vcat (ppr_trim show_meth methods)) +pprClassOneMethod pefas cls this_one + = hang (pprClassHdr pefas cls <+> ptext SLIT("where")) + 2 (vcat (ppr_trim show_meth methods)) where methods = GHC.classMethods cls show_meth id | id == this_one = Just (pprClassMethod pefas id) | otherwise = Nothing -pprClassMethod pefas id = - hang (ppr_bndr id <+> dcolon) 2 (pprType pefas (classOpType id)) +pprClassMethod pefas id + = hang (ppr_bndr id <+> dcolon) 2 (pprTypeForUser pefas op_ty) where -- Here's the magic incantation to strip off the dictionary -- from the class op type. Stolen from IfaceSyn.tyThingToIfaceDecl. - classOpType id = GHC.funResultTy rho_ty - where (_sel_tyvars, rho_ty) = GHC.splitForAllTys (GHC.idType id) + -- + -- It's important to tidy it *before* splitting it up, so that if + -- we have class C a b where + -- op :: forall a. a -> b + -- then the inner forall on op gets renamed to a1, and we print + -- (when dropping foralls) + -- class C a b where + -- op :: a1 -> b + + tidy_sel_ty = tidyTopType (GHC.idType id) + (_sel_tyvars, rho_ty) = GHC.splitForAllTys tidy_sel_ty + op_ty = GHC.funResultTy rho_ty ppr_trim :: (a -> Maybe SDoc) -> [a] -> [SDoc] ppr_trim show xs