[commit: ghc] master: Fix #15243 by fixing incorrect uses of NotPromoted (569c16a)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/569c16a76ead8f9012fafe7a7e97c72fabe0bb94/ghc

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

commit 569c16a76ead8f9012fafe7a7e97c72fabe0bb94
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Thu Jun 7 13:28:53 2018 -0400

    Fix #15243 by fixing incorrect uses of NotPromoted
    
    In `Convert`, we were incorrectly using `NotPromoted` to
    denote type constructors that were actually intended to be promoted,
    resulting in poor `-ddump-splices` output (as seen in #15243).
    Easily fixed.
    
    Test Plan: make test TEST=T15243
    
    Reviewers: bgamari, goldfire
    
    Reviewed By: bgamari
    
    Subscribers: rwbarton, thomie, carter
    
    GHC Trac Issues: #15243
    
    Differential Revision: https://phabricator.haskell.org/D4809


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

569c16a76ead8f9012fafe7a7e97c72fabe0bb94
 compiler/hsSyn/Convert.hs                  |  6 +++---
 testsuite/tests/th/T15243.hs               | 15 +++++++++++++++
 testsuite/tests/th/T15243.stderr           | 12 ++++++++++++
 testsuite/tests/th/TH_PromotedTuple.stderr |  4 ++--
 testsuite/tests/th/TH_TyInstWhere1.stderr  |  4 ++--
 testsuite/tests/th/all.T                   |  1 +
 6 files changed, 35 insertions(+), 7 deletions(-)

diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 71cf5a6..7487983 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -1344,7 +1344,7 @@ cvtTypeKind ty_str ty
                    }
 
            PromotedT nm -> do { nm' <- cName nm
-                              ; mk_apps (HsTyVar noExt NotPromoted
+                              ; mk_apps (HsTyVar noExt Promoted
                                                              (noLoc nm')) tys' }
                  -- Promoted data constructor; hence cName
 
@@ -1354,7 +1354,7 @@ cvtTypeKind ty_str ty
              | m == n   -- Saturated
              -> returnL (HsExplicitTupleTy noExt tys')
              | otherwise
-             -> mk_apps (HsTyVar noExt NotPromoted
+             -> mk_apps (HsTyVar noExt Promoted
                                (noLoc (getRdrName (tupleDataCon Boxed n)))) tys'
              where
                m = length tys'
@@ -1367,7 +1367,7 @@ cvtTypeKind ty_str ty
              | [ty1, L _ (HsExplicitListTy _ ip tys2)] <- tys'
              -> returnL (HsExplicitListTy noExt ip (ty1:tys2))
              | otherwise
-             -> mk_apps (HsTyVar noExt NotPromoted
+             -> mk_apps (HsTyVar noExt Promoted
                          (noLoc (getRdrName consDataCon)))
                         tys'
 
diff --git a/testsuite/tests/th/T15243.hs b/testsuite/tests/th/T15243.hs
new file mode 100644
index 0000000..8b36640
--- /dev/null
+++ b/testsuite/tests/th/T15243.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -ddump-splices #-}
+module T15243 where
+
+data Unit = Unit
+
+$([d| type family F (a :: k) :: k where
+        F 'Unit = 'Unit
+        F '(,)  = '(,)
+        F '[]   = '[]
+        F '(:)  = '(:)
+    |])
diff --git a/testsuite/tests/th/T15243.stderr b/testsuite/tests/th/T15243.stderr
new file mode 100644
index 0000000..26082a1
--- /dev/null
+++ b/testsuite/tests/th/T15243.stderr
@@ -0,0 +1,12 @@
+T15243.hs:(10,3)-(15,6): Splicing declarations
+    [d| type family F_at5 (a_at7 :: k_at6) :: k_at6 where
+          F_at5  'Unit =  'Unit
+          F_at5  '(,) =  '(,)
+          F_at5 '[] = '[]
+          F_at5  '(:) =  '(:) |]
+  ======>
+    type family F_a3ZE (a_a3ZG :: k_a3ZF) :: k_a3ZF where
+      F_a3ZE  'Unit =  'Unit
+      F_a3ZE  '(,) =  '(,)
+      F_a3ZE '[] = '[]
+      F_a3ZE  '(:) =  '(:)
diff --git a/testsuite/tests/th/TH_PromotedTuple.stderr b/testsuite/tests/th/TH_PromotedTuple.stderr
index 9619d52..92792a3 100644
--- a/testsuite/tests/th/TH_PromotedTuple.stderr
+++ b/testsuite/tests/th/TH_PromotedTuple.stderr
@@ -3,7 +3,7 @@ TH_PromotedTuple.hs:(14,32)-(16,43): Splicing type
        reportWarning (show ty)
        return ty
   ======>
-    '(Int, False)
+    '(Int,  'False)
 
-TH_PromotedTuple.hs:14:32: Warning:
+TH_PromotedTuple.hs:14:32: warning:
     AppT (AppT (PromotedTupleT 2) (ConT GHC.Types.Int)) (PromotedT GHC.Types.False)
diff --git a/testsuite/tests/th/TH_TyInstWhere1.stderr b/testsuite/tests/th/TH_TyInstWhere1.stderr
index 971b7ee..0d07db8 100644
--- a/testsuite/tests/th/TH_TyInstWhere1.stderr
+++ b/testsuite/tests/th/TH_TyInstWhere1.stderr
@@ -4,5 +4,5 @@ TH_TyInstWhere1.hs:(5,3)-(7,24): Splicing declarations
           F a b = False |]
   ======>
     type family F (a :: k) (b :: k) :: Bool where
-      F a a = True
-      F a b = False
+      F a a =  'True
+      F a b =  'False
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index e998bd0..b97ed40 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -414,3 +414,4 @@ test('T14875', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T14885a', normal, compile, [''])
 test('T14885b', normal, compile, [''])
 test('T14885c', normal, compile, [''])
+test('T15243', normal, compile, [''])