[commit: ghc] ghc-8.6: Fix #15572 by checking for promoted names in ConT (ebc8ebf)

[git at git.haskell.org]

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

On branch  : ghc-8.6
Link       : http://ghc.haskell.org/trac/ghc/changeset/ebc8ebf89332ddac3039ff87331c4c053ae516ea/ghc

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

commit ebc8ebf89332ddac3039ff87331c4c053ae516ea
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Tue Aug 28 20:54:28 2018 +0200

    Fix #15572 by checking for promoted names in ConT
    
    Summary:
    When converting `ConT`s to `HsTyVar`s in `Convert`, we were
    failing to account for the possibility of promoted data constructor
    names appearing in a `ConT`, which could result in improper
    pretty-printing results (as observed in #15572). The fix is
    straightforward: use `Promoted` instead of `NotPromoted` when the
    name of a `ConT` is a data constructor name.
    
    Test Plan: make test TEST=T15572
    
    Reviewers: goldfire, bgamari, simonpj, monoidal
    
    Reviewed By: goldfire, simonpj
    
    Subscribers: monoidal, rwbarton, carter
    
    GHC Trac Issues: #15572
    
    Differential Revision: https://phabricator.haskell.org/D5112
    
    (cherry picked from commit c46a5f2002f6694ea58f79f505d57f3b7bd450e7)


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

ebc8ebf89332ddac3039ff87331c4c053ae516ea
 compiler/hsSyn/Convert.hs        | 9 ++++++++-
 testsuite/tests/th/T15572.hs     | 8 ++++++++
 testsuite/tests/th/T15572.stderr | 6 ++++++
 testsuite/tests/th/all.T         | 1 +
 4 files changed, 23 insertions(+), 1 deletion(-)

diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 1e6611c..c44abf6 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -1302,7 +1302,14 @@ cvtTypeKind ty_str ty
            VarT nm -> do { nm' <- tNameL nm
                          ; mk_apps (HsTyVar noExt NotPromoted nm') tys' }
            ConT nm -> do { nm' <- tconName nm
-                         ; mk_apps (HsTyVar noExt NotPromoted (noLoc nm')) tys'}
+                         ; -- ConT can contain both data constructor (i.e.,
+                           -- promoted) names and other (i.e, unpromoted)
+                           -- names, as opposed to PromotedT, which can only
+                           -- contain data constructor names. See #15572.
+                           let prom = if isRdrDataCon nm'
+                                      then Promoted
+                                      else NotPromoted
+                         ; mk_apps (HsTyVar noExt prom (noLoc nm')) tys'}
 
            ForallT tvs cxt ty
              | null tys'
diff --git a/testsuite/tests/th/T15572.hs b/testsuite/tests/th/T15572.hs
new file mode 100644
index 0000000..7bbbcac
--- /dev/null
+++ b/testsuite/tests/th/T15572.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+module T15572 where
+
+import Language.Haskell.TH
+
+$([d| type AbsoluteUnit1 = '() |])
+$(pure [TySynD (mkName "AbsoluteUnit2") [] (ConT '())])
diff --git a/testsuite/tests/th/T15572.stderr b/testsuite/tests/th/T15572.stderr
new file mode 100644
index 0000000..27132d69
--- /dev/null
+++ b/testsuite/tests/th/T15572.stderr
@@ -0,0 +1,6 @@
+T15572.hs:7:3-33: Splicing declarations
+    [d| type AbsoluteUnit1 =  '() |] ======> type AbsoluteUnit1 =  '()
+T15572.hs:8:3-54: Splicing declarations
+    pure [TySynD (mkName "AbsoluteUnit2") [] (ConT '())]
+  ======>
+    type AbsoluteUnit2 =  '()
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 280200e..55452b5 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -422,3 +422,4 @@ test('T15365', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T15518', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T15502', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T15550', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T15572', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])