Don't drop arguments in TH type arguments
authorAlec Theriault <alec.theriault@gmail.com>
Thu, 4 Oct 2018 22:13:15 +0000 (18:13 -0400)
committerRyan Scott <ryan.gl.scott@gmail.com>
Thu, 4 Oct 2018 22:13:16 +0000 (18:13 -0400)
Summary:
When converting from TH AST back to HsType, we were occasionally
dropping type arguments. This resulted in incorrectly accepted programs
as well as incorrectly rejected programs.

Test Plan: make TEST=T15360a && make TEST=T15360b

Reviewers: goldfire, bgamari, tdammers

Reviewed By: bgamari, tdammers

Subscribers: RyanGlScott, rwbarton, carter

GHC Trac Issues: #15360

Differential Revision: https://phabricator.haskell.org/D5188

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

index f7713ff..d094e17 100644 (file)
@@ -1355,7 +1355,7 @@ cvtTypeKind ty_str ty
                    }
 
            LitT lit
-             -> returnL (HsTyLit noExt (cvtTyLit lit))
+             -> mk_apps (HsTyLit noExt (cvtTyLit lit)) tys'
 
            WildCardT
              -> mk_apps mkAnonWildCardTy tys'
@@ -1364,17 +1364,19 @@ cvtTypeKind ty_str ty
              -> do { s'  <- tconName s
                    ; t1' <- cvtType t1
                    ; t2' <- cvtType t2
-                   ; mk_apps (HsTyVar noExt NotPromoted (noLoc s')) [t1', t2']
+                   ; mk_apps (HsTyVar noExt NotPromoted (noLoc s'))
+                             (t1' : t2' : tys')
                    }
 
            UInfixT t1 s t2
              -> do { t2' <- cvtType t2
-                   ; cvtOpAppT t1 s t2'
-                   } -- Note [Converting UInfix]
+                   ; t <- cvtOpAppT t1 s t2' -- Note [Converting UInfix]
+                   ; mk_apps (unLoc t) tys'
+                   }
 
            ParensT t
              -> do { t' <- cvtType t
-                   ; returnL $ HsParTy noExt t'
+                   ; mk_apps (HsParTy noExt t') tys'
                    }
 
            PromotedT nm -> do { nm' <- cName nm
@@ -1394,7 +1396,7 @@ cvtTypeKind ty_str ty
                m = length tys'
 
            PromotedNilT
-             -> returnL (HsExplicitListTy noExt Promoted [])
+             -> mk_apps (HsExplicitListTy noExt Promoted []) tys'
 
            PromotedConsT  -- See Note [Representing concrete syntax in types]
                           -- in Language.Haskell.TH.Syntax
@@ -1406,12 +1408,14 @@ cvtTypeKind ty_str ty
                         tys'
 
            StarT
-             -> returnL (HsTyVar noExt NotPromoted (noLoc
-                                              (getRdrName liftedTypeKindTyCon)))
+             -> mk_apps (HsTyVar noExt NotPromoted
+                              (noLoc (getRdrName liftedTypeKindTyCon)))
+                        tys'
 
            ConstraintT
-             -> returnL (HsTyVar noExt NotPromoted
+             -> mk_apps (HsTyVar noExt NotPromoted
                               (noLoc (getRdrName constraintKindTyCon)))
+                        tys'
 
            EqualityT
              | [x',y'] <- tys' ->
diff --git a/testsuite/tests/th/T15360a.hs b/testsuite/tests/th/T15360a.hs
new file mode 100644 (file)
index 0000000..4839ccf
--- /dev/null
@@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T15360a where
+
+import Language.Haskell.TH
+
+data T a b c = Mk a b c
+
+bar :: $( return $ AppT (InfixT (ConT ''Int) ''T (ConT ''Bool)) (ConT ''Double) )
+bar = Mk 5 True 3.14
+
+baz :: $( return $ AppT (ParensT (ConT ''Maybe)) (ConT ''Int) )
+baz = Just 5
diff --git a/testsuite/tests/th/T15360b.hs b/testsuite/tests/th/T15360b.hs
new file mode 100644 (file)
index 0000000..276d2cd
--- /dev/null
@@ -0,0 +1,20 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE StarIsType #-}
+module T15360b where
+
+import Data.Kind
+import Data.Proxy
+
+x :: Proxy $([t| * Double |])
+x = Proxy
+
+y :: Proxy $([t| 1 Int |])
+y = Proxy
+
+z :: Proxy $([t| Constraint Bool |])
+z = Proxy
+
+w :: Proxy $([t| '[] Int |])
+w = Proxy
diff --git a/testsuite/tests/th/T15360b.stderr b/testsuite/tests/th/T15360b.stderr
new file mode 100644 (file)
index 0000000..8175c12
--- /dev/null
@@ -0,0 +1,20 @@
+
+T15360b.hs:10:14: error:
+    • Expected kind ‘* -> k4’, but ‘Type’ has kind ‘*’
+    • In the first argument of ‘Proxy’, namely ‘(Type Double)’
+      In the type signature: x :: Proxy (Type Double)
+
+T15360b.hs:13:14: error:
+    • Expected kind ‘* -> k3’, but ‘1’ has kind ‘GHC.Types.Nat’
+    • In the first argument of ‘Proxy’, namely ‘(1 Int)’
+      In the type signature: y :: Proxy (1 Int)
+
+T15360b.hs:16:14: error:
+    • Expected kind ‘* -> k2’, but ‘Constraint’ has kind ‘*’
+    • In the first argument of ‘Proxy’, namely ‘(Constraint Bool)’
+      In the type signature: z :: Proxy (Constraint Bool)
+
+T15360b.hs:19:14: error:
+    • Expected kind ‘* -> k1’, but ‘'[]’ has kind ‘[k0]’
+    • In the first argument of ‘Proxy’, namely ‘('[] Int)’
+      In the type signature: w :: Proxy ('[] Int)
index 948c7db..249493e 100644 (file)
@@ -419,6 +419,8 @@ test('T15321', normal, compile_fail, [''])
 test('T15324', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T15331', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T15365', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T15360a', normal, compile, [''])
+test('T15360b', normal, compile_fail, [''])
 # Note: T9693 should be only_ways(['ghci']) once it's fixed.
 test('T9693', expect_broken(9693), ghci_script, ['T9693.script'])
 test('T14471', normal, compile, [''])