X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FPprTyThing.hs;h=06096602853e0848e54032d19972b187fd852d25;hb=30c122df62ec75f9ed7f392f24c2925675bf1d06;hp=6a0bf82d3b6fd0f18c9585cc81eba8a590399972;hpb=046feb1ea3b3dafb21c43fda88778198c1c709d6;p=ghc-hetmet.git diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index 6a0bf82..0609660 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -6,13 +6,6 @@ -- ----------------------------------------------------------------------------- -{-# 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, @@ -27,14 +20,14 @@ module PprTyThing ( import qualified GHC -import GHC ( TyThing(..) ) -import TyCon ( tyConFamInst_maybe ) -import Type ( TyThing(..), tidyTopType, pprTypeApp ) -import TcType ( tcMultiSplitSigmaTy, mkPhiTy ) -import SrcLoc ( SrcSpan ) +import GHC ( TyThing(..) ) +import TyCon +import Type ( TyThing(..), tidyTopType, pprTypeApp ) +import TcType import Var import Name import Outputable +import FastString -- ----------------------------------------------------------------------------- -- Pretty-printing entities that we get from the GHC API @@ -81,12 +74,13 @@ pprTyThingHdr pefas (AnId id) = pprId pefas id pprTyThingHdr pefas (ADataCon dataCon) = pprDataConSig pefas dataCon pprTyThingHdr pefas (ATyCon tyCon) = pprTyConHdr pefas tyCon pprTyThingHdr pefas (AClass cls) = pprClassHdr pefas cls - -pprTyConHdr pefas tyCon - | Just (fam_tc, tys) <- tyConFamInst_maybe tyCon + +pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc +pprTyConHdr _ 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 @@ -100,10 +94,16 @@ 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 :: PrintExplicitForalls -> GHC.DataCon -> SDoc pprDataConSig pefas dataCon = ppr_bndr dataCon <+> dcolon <+> pprTypeForUser pefas (GHC.dataConType dataCon) -pprClassHdr pefas cls = +pprClassHdr :: PrintExplicitForalls -> GHC.Class -> SDoc +pprClassHdr _ cls = let (tyVars, funDeps) = GHC.classTvsFds cls in ptext SLIT("class") <+> GHC.pprThetaArrow (GHC.classSCTheta cls) <+> @@ -111,11 +111,13 @@ pprClassHdr pefas cls = hsep (map ppr tyVars) <+> GHC.pprFundeps funDeps +pprIdInContext :: PrintExplicitForalls -> Var -> SDoc pprIdInContext pefas id | GHC.isRecordSelector id = pprRecordSelector pefas id | Just cls <- GHC.isClassOpId_maybe id = pprClassOneMethod pefas cls id | otherwise = pprId pefas id +pprRecordSelector :: PrintExplicitForalls -> Id -> SDoc pprRecordSelector pefas id = pprAlgTyCon pefas tyCon show_con show_label where @@ -144,6 +146,7 @@ pprTypeForUser print_foralls ty tidy_ty = tidyTopType ty (ctxt, ty') = tcMultiSplitSigmaTy tidy_ty +pprTyCon :: PrintExplicitForalls -> TyCon -> SDoc pprTyCon pefas tyCon | GHC.isSynTyCon tyCon = if GHC.isOpenTyCon tyCon @@ -155,6 +158,8 @@ pprTyCon pefas tyCon | otherwise = pprAlgTyCon pefas tyCon (const True) (const True) +pprAlgTyCon :: PrintExplicitForalls -> TyCon -> (GHC.DataCon -> Bool) + -> (FieldLabel -> Bool) -> SDoc pprAlgTyCon pefas tyCon ok_con ok_label | gadt = pprTyConHdr pefas tyCon <+> ptext SLIT("where") $$ nest 2 (vcat (ppr_trim show_con datacons)) @@ -168,10 +173,13 @@ pprAlgTyCon pefas tyCon ok_con ok_label | ok_con dataCon = Just (pprDataConDecl pefas gadt ok_label dataCon) | otherwise = Nothing +pprDataCon :: PrintExplicitForalls -> GHC.DataCon -> SDoc pprDataCon pefas dataCon = pprAlgTyCon pefas tyCon (== dataCon) (const True) where tyCon = GHC.dataConTyCon dataCon -pprDataConDecl pefas gadt_style show_label dataCon +pprDataConDecl :: PrintExplicitForalls -> Bool -> (FieldLabel -> Bool) + -> GHC.DataCon -> SDoc +pprDataConDecl _ gadt_style show_label dataCon | not gadt_style = ppr_fields tys_w_strs | otherwise = ppr_bndr dataCon <+> dcolon <+> sep [ ppr_tvs, GHC.pprThetaArrow theta, pp_tau ] @@ -190,7 +198,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 @@ -215,6 +223,7 @@ pprDataConDecl pefas gadt_style show_label dataCon braces (sep (punctuate comma (ppr_trim maybe_show_label (zip labels fields)))) +pprClass :: PrintExplicitForalls -> GHC.Class -> SDoc pprClass pefas cls | null methods = pprClassHdr pefas cls @@ -224,6 +233,7 @@ pprClass pefas cls where methods = GHC.classMethods cls +pprClassOneMethod :: PrintExplicitForalls -> GHC.Class -> Id -> SDoc pprClassOneMethod pefas cls this_one = hang (pprClassHdr pefas cls <+> ptext SLIT("where")) 2 (vcat (ppr_trim show_meth methods)) @@ -232,6 +242,7 @@ pprClassOneMethod pefas cls this_one show_meth id | id == this_one = Just (pprClassMethod pefas id) | otherwise = Nothing +pprClassMethod :: PrintExplicitForalls -> Id -> SDoc pprClassMethod pefas id = hang (ppr_bndr id <+> dcolon) 2 (pprTypeForUser pefas op_ty) where @@ -259,6 +270,7 @@ ppr_trim show xs | otherwise = if eliding then (True, so_far) else (True, ptext SLIT("...") : so_far) +add_bars :: [SDoc] -> SDoc add_bars [] = empty add_bars [c] = equals <+> c add_bars (c:cs) = sep ((equals <+> c) : map (char '|' <+>) cs)