[commit: ghc] ghc-7.10: Small improvement in pretty-printing constructors. (cbd1ccb)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-7.10
Link       : http://ghc.haskell.org/trac/ghc/changeset/cbd1ccbebd830476119e46330096c8bc38bfbfa0/ghc

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

commit cbd1ccbebd830476119e46330096c8bc38bfbfa0
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Sun Sep 20 16:03:07 2015 -0400

    Small improvement in pretty-printing constructors.
    
    This fixes #10810 by cleaning up pretty-printing of constructor
    declarations. This change also removes a (in my opinion) deeply
    bogus orphan instance OutputableBndr [Located name], making
    HsDecls now a non-orphan module. Yay all around.
    
    Test case: th/T10810


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

cbd1ccbebd830476119e46330096c8bc38bfbfa0
 compiler/hsSyn/HsDecls.hs        | 26 ++++++++++----------------
 testsuite/tests/th/T10810.hs     |  6 ++++++
 testsuite/tests/th/T10810.stderr |  2 ++
 testsuite/tests/th/all.T         |  1 +
 4 files changed, 19 insertions(+), 16 deletions(-)

diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 4e94b3e..4840768 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -12,7 +12,6 @@
                                       -- in module PlaceHolder
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -- | Abstract syntax of global declarations.
 --
@@ -971,15 +970,16 @@ instance (OutputableBndr name) => Outputable (ConDecl name) where
     ppr = pprConDecl
 
 pprConDecl :: OutputableBndr name => ConDecl name -> SDoc
-pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
+pprConDecl (ConDecl { con_names = [L _ con]  -- NB: non-GADT means 1 con
+                    , con_explicit = expl, con_qvars = tvs
                     , con_cxt = cxt, con_details = details
                     , con_res = ResTyH98, con_doc = doc })
   = sep [ppr_mbDoc doc, pprHsForAll expl tvs cxt, ppr_details details]
   where
-    ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc cons, ppr t2]
-    ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc cons
+    ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2]
+    ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc con
                                    : map (pprParendHsType . unLoc) tys)
-    ppr_details (RecCon fields)  = ppr_con_names cons
+    ppr_details (RecCon fields)  = pprPrefixOcc con
                                  <+> pprConDeclFields (unLoc fields)
 
 pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs
@@ -1002,18 +1002,12 @@ pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {
         -- so if we ever trip over one (albeit I can't see how that
         -- can happen) print it like a prefix one
 
-ppr_con_names :: (OutputableBndr name) => [Located name] -> SDoc
-ppr_con_names [x] = ppr x
-ppr_con_names xs  = interpp'SP xs
-
-instance (Outputable name) => OutputableBndr [Located name] where
-  pprBndr _bs xs = cat $ punctuate comma (map ppr xs)
+-- this fallthrough would happen with a non-GADT-syntax ConDecl with more
+-- than one constructor, which should indeed be impossible
+pprConDecl (ConDecl { con_names = cons }) = pprPanic "pprConDecl" (ppr cons)
 
-  pprPrefixOcc [x] = ppr x
-  pprPrefixOcc xs  = cat $ punctuate comma (map ppr xs)
-
-  pprInfixOcc [x] = ppr x
-  pprInfixOcc xs  = cat $ punctuate comma (map ppr xs)
+ppr_con_names :: (OutputableBndr name) => [Located name] -> SDoc
+ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc)
 
 {-
 ************************************************************************
diff --git a/testsuite/tests/th/T10810.hs b/testsuite/tests/th/T10810.hs
new file mode 100644
index 0000000..328c3e9
--- /dev/null
+++ b/testsuite/tests/th/T10810.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-}
+
+module T10810 where
+
+$([d| data Foo = (:!) |])
diff --git a/testsuite/tests/th/T10810.stderr b/testsuite/tests/th/T10810.stderr
new file mode 100644
index 0000000..c960fe1
--- /dev/null
+++ b/testsuite/tests/th/T10810.stderr
@@ -0,0 +1,2 @@
+T10810.hs:6:3-24: Splicing declarations
+    [d| data Foo = (:!) |] ======> data Foo = (:!)
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index ff0bc9b..59b6668 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -361,3 +361,4 @@ test('TH_Lift', normal, compile, ['-v0'])
 test('T10019', normal, ghci_script, ['T10019.script'])
 test('T10279', normal, compile_fail, ['-v0'])
 test('T10596', normal, compile, ['-v0'])
+test('T10810', normal, compile, ['-v0'])