[commit: ghc] master: Don't drop arguments in TH type arguments (ba163c3)

[git at git.haskell.org]

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

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

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

commit ba163c3b3502df039e589c5bb0bc9ea767267b2a
Author: Alec Theriault <alec.theriault at gmail.com>
Date:   Thu Oct 4 18:13:15 2018 -0400

    Don't drop arguments in TH type arguments
    
    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


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

ba163c3b3502df039e589c5bb0bc9ea767267b2a
 compiler/hsSyn/Convert.hs         | 22 +++++++++++++---------
 testsuite/tests/th/T15360a.hs     | 12 ++++++++++++
 testsuite/tests/th/T15360b.hs     | 20 ++++++++++++++++++++
 testsuite/tests/th/T15360b.stderr | 20 ++++++++++++++++++++
 testsuite/tests/th/all.T          |  2 ++
 5 files changed, 67 insertions(+), 9 deletions(-)

diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index f7713ff..d094e17 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -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
index 0000000..4839ccf
--- /dev/null
+++ b/testsuite/tests/th/T15360a.hs
@@ -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
index 0000000..276d2cd
--- /dev/null
+++ b/testsuite/tests/th/T15360b.hs
@@ -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
index 0000000..8175c12
--- /dev/null
+++ b/testsuite/tests/th/T15360b.stderr
@@ -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)
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 948c7db..249493e 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -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, [''])