[commit: ghc] master: Disambiguate reified closed type family kinds in TH (f65ff2c)

[git at git.haskell.org]

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

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

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

commit f65ff2c4c9b60e370a722ac7572186816e23e573
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Fri Dec 9 08:50:54 2016 -0500

    Disambiguate reified closed type family kinds in TH
    
    Summary:
    A continuation of #8953. This fixes an oversight in which the
    left-hand sides of closed type families, when reified in Template Haskell,
    would not be given kind annotations, even when they are necessary for
    disambiguation purposes in the presence of `PolyKinds`.
    
    Fixes #8953 and #12646.
    
    Test Plan: ./validate
    
    Reviewers: hvr, bgamari, austin, goldfire
    
    Reviewed By: goldfire
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D2795
    
    GHC Trac Issues: #8953, #12646


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

f65ff2c4c9b60e370a722ac7572186816e23e573
 compiler/typecheck/TcSplice.hs   | 11 ++++++++---
 docs/users_guide/8.2.1-notes.rst |  5 +++++
 testsuite/tests/th/T12646.hs     | 16 ++++++++++++++++
 testsuite/tests/th/T12646.stderr |  3 +++
 testsuite/tests/th/T8884.stderr  |  2 +-
 testsuite/tests/th/all.T         |  1 +
 6 files changed, 34 insertions(+), 4 deletions(-)

diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs
index a0838ee..1e35eec 100644
--- a/compiler/typecheck/TcSplice.hs
+++ b/compiler/typecheck/TcSplice.hs
@@ -1357,11 +1357,16 @@ reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing)
 
 -------------------------------------------
 reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn
-reifyAxBranch fam_tc (CoAxBranch { cab_lhs = args, cab_rhs = rhs })
+reifyAxBranch fam_tc (CoAxBranch { cab_lhs = lhs, cab_rhs = rhs })
             -- remove kind patterns (#8884)
-  = do { args' <- mapM reifyType (filterOutInvisibleTypes fam_tc args)
+  = do { let lhs_types_only = filterOutInvisibleTypes fam_tc lhs
+       ; lhs' <- reifyTypes lhs_types_only
+       ; annot_th_lhs <- zipWith3M annotThType (mkIsPolyTvs fam_tvs)
+                                   lhs_types_only lhs'
        ; rhs'  <- reifyType rhs
-       ; return (TH.TySynEqn args' rhs') }
+       ; return (TH.TySynEqn annot_th_lhs rhs') }
+  where
+    fam_tvs = filterOutInvisibleTyVars fam_tc (tyConTyVars fam_tc)
 
 reifyTyCon :: TyCon -> TcM TH.Info
 reifyTyCon tc
diff --git a/docs/users_guide/8.2.1-notes.rst b/docs/users_guide/8.2.1-notes.rst
index 42a1ded..ea22d4f 100644
--- a/docs/users_guide/8.2.1-notes.rst
+++ b/docs/users_guide/8.2.1-notes.rst
@@ -124,6 +124,11 @@ Template Haskell
 
 -  Make quoting and reification return the same types.  (:ghc-ticket:`11629`)
 
+-  More kind annotations appear in the left-hand sides of reified closed
+   type family equations, in order to disambiguate types that would otherwise
+   be ambiguous in the presence of :ghc-flag:`-XPolyKinds`.
+   (:ghc-ticket:`12646`)
+
 Runtime system
 ~~~~~~~~~~~~~~
 
diff --git a/testsuite/tests/th/T12646.hs b/testsuite/tests/th/T12646.hs
new file mode 100644
index 0000000..197d59e
--- /dev/null
+++ b/testsuite/tests/th/T12646.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+module T12646 where
+
+import Language.Haskell.TH
+import System.IO
+
+type family F (a :: k) :: * where
+    F (a :: * -> *) = Int
+    F (a :: k)      = Char
+
+$(do info <- reify ''F
+     runIO $ putStrLn $ pprint info
+     runIO $ hFlush stdout
+     return [])
diff --git a/testsuite/tests/th/T12646.stderr b/testsuite/tests/th/T12646.stderr
new file mode 100644
index 0000000..647ccd6
--- /dev/null
+++ b/testsuite/tests/th/T12646.stderr
@@ -0,0 +1,3 @@
+type family T12646.F (a_0 :: k_1) :: * where
+    T12646.F (a_2 :: * -> *) = GHC.Types.Int
+    T12646.F (a_3 :: k_4) = GHC.Types.Char
diff --git a/testsuite/tests/th/T8884.stderr b/testsuite/tests/th/T8884.stderr
index 28be299..022776e 100644
--- a/testsuite/tests/th/T8884.stderr
+++ b/testsuite/tests/th/T8884.stderr
@@ -1,4 +1,4 @@
 type family T8884.Foo (a_0 :: k_1) = (r_2 :: k_1) | r_2 -> k_1 a_0 where
-    T8884.Foo x_3 = x_3
+    T8884.Foo (x_3 :: k_4) = x_3
 type family T8884.Baz (a_0 :: k_1) = (r_2 :: k_1) | r_2 -> k_1 a_0
 type instance T8884.Baz (x_0 :: k_1) = x_0
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index b96ea78..b144419 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -440,6 +440,7 @@ test('T12478_3', omit_ways(['ghci']), compile, ['-v0'])
 test('T12478_4', omit_ways(['ghci']), compile_fail, ['-v0'])
 test('T12513', omit_ways(['ghci']), compile_fail, ['-v0'])
 test('T12530', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T12646', normal, compile, ['-v0'])
 test('T12788', extra_clean(['T12788_Lib.hi', 'T12788_Lib.o']),
                multimod_compile_fail,
                ['T12788.hs', '-v0 ' + config.ghc_th_way_flags])