Fix #15243 by fixing incorrect uses of NotPromoted
authorRyan Scott <ryan.gl.scott@gmail.com>
Thu, 7 Jun 2018 17:28:53 +0000 (13:28 -0400)
committerBen Gamari <ben@smart-cactus.org>
Thu, 7 Jun 2018 22:06:30 +0000 (18:06 -0400)
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

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

index 71cf5a6..7487983 100644 (file)
@@ -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 (file)
index 0000000..8b36640
--- /dev/null
@@ -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 (file)
index 0000000..26082a1
--- /dev/null
@@ -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  '(:) =  '(:)
index 9619d52..92792a3 100644 (file)
@@ -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)
index 971b7ee..0d07db8 100644 (file)
@@ -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
index e998bd0..b97ed40 100644 (file)
@@ -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, [''])