From f12d4af480bc8fea6a44777199c9a32f60f444b9 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Tue, 25 Mar 2008 22:31:04 +0000 Subject: [PATCH] Fix warnings in main/PprTyThing --- compiler/main/PprTyThing.hs | 44 ++++++++++++++++++++++++++----------------- 1 file changed, 27 insertions(+), 17 deletions(-) diff --git a/compiler/main/PprTyThing.hs b/compiler/main/PprTyThing.hs index c379d97..16f5181 100644 --- a/compiler/main/PprTyThing.hs +++ b/compiler/main/PprTyThing.hs @@ -1,10 +1,3 @@ -{-# 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 @@ -27,14 +20,14 @@ module PprTyThing ( import qualified GHC -import GHC ( TyThing(..) ) -import TyCon ( tyConFamInst_maybe, isAlgTyCon, tyConStupidTheta ) -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 Pretty ( Doc ) -- ----------------------------------------------------------------------------- -- Pretty-printing entities that we get from the GHC API @@ -81,9 +74,10 @@ 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 -> PprStyle -> Doc +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 <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars) @@ -104,10 +98,12 @@ pprTyConHdr pefas tyCon | isAlgTyCon tyCon = GHC.pprThetaArrow (tyConStupidTheta tyCon) | otherwise = empty -- Returns 'empty' if null theta +pprDataConSig :: PrintExplicitForalls -> GHC.DataCon -> PprStyle -> Doc pprDataConSig pefas dataCon = ppr_bndr dataCon <+> dcolon <+> pprTypeForUser pefas (GHC.dataConType dataCon) -pprClassHdr pefas cls = +pprClassHdr :: PrintExplicitForalls -> GHC.Class -> PprStyle -> Doc +pprClassHdr _ cls = let (tyVars, funDeps) = GHC.classTvsFds cls in ptext SLIT("class") <+> GHC.pprThetaArrow (GHC.classSCTheta cls) <+> @@ -115,11 +111,13 @@ pprClassHdr pefas cls = hsep (map ppr tyVars) <+> GHC.pprFundeps funDeps +pprIdInContext :: PrintExplicitForalls -> Var -> PprStyle -> Doc 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 -> PprStyle -> Doc pprRecordSelector pefas id = pprAlgTyCon pefas tyCon show_con show_label where @@ -148,6 +146,7 @@ pprTypeForUser print_foralls ty tidy_ty = tidyTopType ty (ctxt, ty') = tcMultiSplitSigmaTy tidy_ty +pprTyCon :: PrintExplicitForalls -> TyCon -> PprStyle -> Doc pprTyCon pefas tyCon | GHC.isSynTyCon tyCon = if GHC.isOpenTyCon tyCon @@ -159,6 +158,9 @@ pprTyCon pefas tyCon | otherwise = pprAlgTyCon pefas tyCon (const True) (const True) +pprAlgTyCon :: PrintExplicitForalls -> TyCon -> (GHC.DataCon -> Bool) + -> (FieldLabel -> Bool) -> PprStyle + -> Doc pprAlgTyCon pefas tyCon ok_con ok_label | gadt = pprTyConHdr pefas tyCon <+> ptext SLIT("where") $$ nest 2 (vcat (ppr_trim show_con datacons)) @@ -172,10 +174,14 @@ pprAlgTyCon pefas tyCon ok_con ok_label | ok_con dataCon = Just (pprDataConDecl pefas gadt ok_label dataCon) | otherwise = Nothing +pprDataCon :: PrintExplicitForalls -> GHC.DataCon -> PprStyle -> Doc 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 -> PprStyle + -> Doc +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 ] @@ -219,6 +225,7 @@ pprDataConDecl pefas gadt_style show_label dataCon braces (sep (punctuate comma (ppr_trim maybe_show_label (zip labels fields)))) +pprClass :: PrintExplicitForalls -> GHC.Class -> PprStyle -> Doc pprClass pefas cls | null methods = pprClassHdr pefas cls @@ -228,6 +235,7 @@ pprClass pefas cls where methods = GHC.classMethods cls +pprClassOneMethod :: PrintExplicitForalls -> GHC.Class -> Id -> PprStyle -> Doc pprClassOneMethod pefas cls this_one = hang (pprClassHdr pefas cls <+> ptext SLIT("where")) 2 (vcat (ppr_trim show_meth methods)) @@ -236,6 +244,7 @@ pprClassOneMethod pefas cls this_one show_meth id | id == this_one = Just (pprClassMethod pefas id) | otherwise = Nothing +pprClassMethod :: PrintExplicitForalls -> Id -> PprStyle -> Doc pprClassMethod pefas id = hang (ppr_bndr id <+> dcolon) 2 (pprTypeForUser pefas op_ty) where @@ -263,6 +272,7 @@ ppr_trim show xs | otherwise = if eliding then (True, so_far) else (True, ptext SLIT("...") : so_far) +add_bars :: [SDoc] -> PprStyle -> Doc add_bars [] = empty add_bars [c] = equals <+> c add_bars (c:cs) = sep ((equals <+> c) : map (char '|' <+>) cs) -- 1.7.10.4