Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/9b9f197b05c4bf9d16289d3aa6e71e9f081da7f6

>---------------------------------------------------------------

commit 9b9f197b05c4bf9d16289d3aa6e71e9f081da7f6
Author: Simon Peyton Jones <simo...@microsoft.com>
Date:   Wed Jan 2 12:37:07 2013 +0000

    Improve HsSyn pretty-printing of instance declarations (fixes Trac #7532)

>---------------------------------------------------------------

 compiler/hsSyn/HsDecls.lhs |   42 +++++++++++++++++++++++++++---------------
 1 files changed, 27 insertions(+), 15 deletions(-)

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 05af165..bd007a8 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -755,8 +755,8 @@ pp_data_defn :: OutputableBndr name
                   -> HsDataDefn name
                   -> SDoc 
 pp_data_defn pp_hdr (HsDataDefn { dd_ND = new_or_data, dd_ctxt = L _ context
-                              , dd_kindSig = mb_sig 
-                              , dd_cons = condecls, dd_derivs = derivings })
+                                , dd_kindSig = mb_sig 
+                                , dd_cons = condecls, dd_derivs = derivings })
   | null condecls
   = ppr new_or_data <+> pp_hdr context <+> pp_sig
 
@@ -921,13 +921,19 @@ It is not possible for this list to have 0 elements --
 
 \begin{code}
 instance (OutputableBndr name) => Outputable (TyFamInstDecl name) where
-  ppr (TyFamInstDecl { tfid_group = False, tfid_eqns = [lEqn] })
-    = let eqn = unLoc lEqn in
-        ptext (sLit "type instance") <+> (ppr eqn)
-  ppr (TyFamInstDecl { tfid_eqns = eqns })
-    = hang (ptext (sLit "type instance where"))
+  ppr = pprTyFamInstDecl TopLevel
+
+pprTyFamInstDecl :: OutputableBndr name => TopLevelFlag -> TyFamInstDecl name 
-> SDoc
+pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_group = False, tfid_eqns = 
[eqn] })
+   = ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> (ppr eqn)
+pprTyFamInstDecl top_lvl (TyFamInstDecl { tfid_eqns = eqns })
+   = hang (ptext (sLit "type") <+> ppr_instance_keyword top_lvl <+> ptext 
(sLit "where"))
         2 (vcat (map ppr eqns))
 
+ppr_instance_keyword :: TopLevelFlag -> SDoc
+ppr_instance_keyword TopLevel    = ptext (sLit "instance")
+ppr_instance_keyword NotTopLevel = empty
+
 instance (OutputableBndr name) => Outputable (TyFamInstEqn name) where
   ppr (TyFamInstEqn { tfie_tycon = tycon
                     , tfie_pats  = pats
@@ -935,10 +941,15 @@ instance (OutputableBndr name) => Outputable 
(TyFamInstEqn name) where
     = (pp_fam_inst_lhs tycon pats []) <+> equals <+> (ppr rhs)
 
 instance (OutputableBndr name) => Outputable (DataFamInstDecl name) where
-  ppr (DataFamInstDecl { dfid_tycon = tycon
-                       , dfid_pats  = pats
-                       , dfid_defn  = defn })
-    = pp_data_defn ((ptext (sLit "instance") <+>) . (pp_fam_inst_lhs tycon 
pats)) defn
+  ppr = pprDataFamInstDecl TopLevel
+
+pprDataFamInstDecl :: OutputableBndr name => TopLevelFlag -> DataFamInstDecl 
name -> SDoc
+pprDataFamInstDecl top_lvl (DataFamInstDecl { dfid_tycon = tycon
+                                            , dfid_pats  = pats  
+                                            , dfid_defn  = defn })
+  = pp_data_defn pp_hdr defn
+  where
+    pp_hdr ctxt = ppr_instance_keyword top_lvl <+> pp_fam_inst_lhs tycon pats 
ctxt
 
 pprDataFamInstFlavour :: DataFamInstDecl name -> SDoc
 pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd 
}) })
@@ -948,14 +959,15 @@ instance (OutputableBndr name) => Outputable (ClsInstDecl 
name) where
     ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
                      , cid_sigs = sigs, cid_tyfam_insts = ats
                      , cid_datafam_insts = adts })
-      | null sigs && null ats && isEmptyBag binds  -- No "where" part
+      | null sigs, null ats, null adts, isEmptyBag binds  -- No "where" part
       = top_matter
 
       | otherwise       -- Laid out
       = vcat [ top_matter <+> ptext (sLit "where")
-             , nest 2 $ pprDeclList (map ppr ats ++
-                                     map ppr adts ++
-                                     pprLHsBindsForUser binds sigs) ]
+             , nest 2 $ pprDeclList $
+               map (pprTyFamInstDecl NotTopLevel . unLoc)   ats ++
+               map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++
+               pprLHsBindsForUser binds sigs ]
       where
         top_matter = ptext (sLit "instance") <+> ppr inst_ty
 



_______________________________________________
Cvs-ghc mailing list
Cvs-ghc@haskell.org
http://www.haskell.org/mailman/listinfo/cvs-ghc

Reply via email to