Improve HsSyn pretty-printing of instance declarations (fixes Trac #7532)
authorSimon Peyton Jones <simonpj@microsoft.com>
Wed, 2 Jan 2013 12:37:07 +0000 (12:37 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Wed, 2 Jan 2013 12:37:07 +0000 (12:37 +0000)
compiler/hsSyn/HsDecls.lhs

index 05af165..bd007a8 100644 (file)
@@ -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