Follow-up to #406

There was one place where #406 forgot to check for higher-rank types: the types of data constructors. Easily fixed.
goldfirere · Nov 2, 2019 · dff1f74 · dff1f74
1 parent b0e0faf
commit dff1f74
Show file tree

Hide file tree

Showing 4 changed files with 25 additions and 2 deletions.
diff --git a/src/Data/Singletons/Single/Data.hs b/src/Data/Singletons/Single/Data.hs
@@ -131,9 +131,10 @@ singCtor dataName (DCon con_tvbs cxt name fields rty)
       sName = singDataConName name
       sCon = DConE sName
       pCon = DConT name
+  checkVanillaDType $ DForallT ForallInvis con_tvbs $ ravel types rty
   indexNames <- mapM (const $ qNewName "n") types
-  kinds <- mapM promoteType types
-  rty' <- promoteType rty
+  kinds <- mapM promoteType_NC types
+  rty' <- promoteType_NC rty
   let indices = map DVarT indexNames
       kindedIndices = zipWith DSigT indices kinds
       args = map (DAppT singFamily) indices

diff --git a/tests/SingletonsTestSuite.hs b/tests/SingletonsTestSuite.hs
@@ -119,6 +119,7 @@ tests =
     , compileAndDumpStdTest "T376"
     , compileAndDumpStdTest "T378a"
     , compileAndDumpStdTest "T401"
+    , compileAndDumpStdTest "T401b"
     , compileAndDumpStdTest "T402"
     , compileAndDumpStdTest "T410"
     , compileAndDumpStdTest "T412"

diff --git a/tests/compile-and-dump/Singletons/T401b.golden b/tests/compile-and-dump/Singletons/T401b.golden
@@ -0,0 +1,13 @@
+
+Singletons/T401b.hs:0:0: error:
+    `singletons` does not support higher-rank `forall`s
+In the type: (forall a_0 . a_0) -> T_1
+
+  |
+5 | $(singletons [d|
+  |   ^^^^^^^^^^^^^^...
+
+Singletons/T401b.hs:0:0: error: Q monad failure
+  |
+5 | $(singletons [d|
+  |   ^^^^^^^^^^^^^^...
diff --git a/tests/compile-and-dump/Singletons/T401b.hs b/tests/compile-and-dump/Singletons/T401b.hs
@@ -0,0 +1,8 @@
+module T401b where
+
+import Data.Singletons.TH
+
+$(singletons [d|
+  newtype T where
+    MkT :: (forall a. a) -> T
+  |])