Fix #15572 by checking for promoted names in ConT
authorRyan Scott <ryan.gl.scott@gmail.com>
Tue, 28 Aug 2018 18:54:28 +0000 (20:54 +0200)
committerKrzysztof Gogolewski <krz.gogolewski@gmail.com>
Tue, 28 Aug 2018 18:54:28 +0000 (20:54 +0200)
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

compiler/hsSyn/Convert.hs
testsuite/tests/th/T15572.hs [new file with mode: 0644]
testsuite/tests/th/T15572.stderr [new file with mode: 0644]
testsuite/tests/th/all.T

index 687c828..832a513 100644 (file)
@@ -1305,7 +1305,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 (file)
index 0000000..7bbbcac
--- /dev/null
@@ -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 (file)
index 0000000..27132d6
--- /dev/null
@@ -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 =  '()
index 296cec7..cf9153e 100644 (file)
@@ -428,3 +428,4 @@ test('TH_invalid_add_top_decl', normal, compile_fail, [''])
 test('T15550', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T15502', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T15518', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T15572', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])