[commit: ghc] master: Fix inference of partial signatures (1bfff60)

[git at git.haskell.org]

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

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

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

commit 1bfff60fc57cd564382b86bdfb1f2764ca15d44f
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri Nov 25 11:35:50 2016 +0000

    Fix inference of partial signatures
    
    When we had
      f :: ( _ ) => blah
    we were failing to call growThetaTyVars, as we do in the
    no-type-signature case, and that meant that we weren't generalising
    over the right type variables.  I'm quite surprised this didn't cause
    problems earlier.
    
    Anyway Trac #12844 showed it up and this patch fixes it


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

1bfff60fc57cd564382b86bdfb1f2764ca15d44f
 compiler/typecheck/TcBinds.hs                      |  7 ++++--
 .../tests/partial-sigs/should_compile/T12844.hs    | 20 +++++++++++++++++
 .../partial-sigs/should_compile/T12844.stderr      | 25 ++++++++++++++++++++++
 testsuite/tests/partial-sigs/should_compile/all.T  |  1 +
 4 files changed, 51 insertions(+), 2 deletions(-)

diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index 1c93962..d13af8b 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -822,8 +822,11 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs
 
   | Just wc_var <- wcx
   = do { annotated_theta <- zonkTcTypes annotated_theta
-       ; let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta
-                                        `unionVarSet` tau_tvs)
+       ; let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs)
+                          -- growThetaVars just like the no-type-sig case
+                          -- Omitting this caused #12844
+             seed_tvs = tyCoVarsOfTypes annotated_theta  -- These are put there
+                        `unionVarSet` tau_tvs            --       by the user
              my_theta = pickCapturedPreds free_tvs inferred_theta
 
        -- Report the inferred constraints for an extra-constraints wildcard/hole as
diff --git a/testsuite/tests/partial-sigs/should_compile/T12844.hs b/testsuite/tests/partial-sigs/should_compile/T12844.hs
new file mode 100644
index 0000000..d47b82c
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_compile/T12844.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE PolyKinds             #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
+
+module T12844 where
+
+barWraper :: ('(r,r') ~ Head rngs, Foo rngs) => FooData rngs
+barWraper = bar
+
+bar :: (_) => FooData rngs
+bar = foo
+
+data FooData rngs
+
+class Foo xs where foo :: (Head xs ~ '(r,r')) => FooData xs
+
+type family Head (xs :: [k]) where Head (x ': xs) = x
+
diff --git a/testsuite/tests/partial-sigs/should_compile/T12844.stderr b/testsuite/tests/partial-sigs/should_compile/T12844.stderr
new file mode 100644
index 0000000..8ad3777
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_compile/T12844.stderr
@@ -0,0 +1,25 @@
+
+T12844.hs:12:9: warning: [-Wpartial-type-signatures (in -Wdefault)]
+    • Found type wildcard ‘_’
+        standing for ‘(Head rngs ~ '(r, r'), Foo rngs)’
+      Where: ‘r’ is a rigid type variable bound by
+               the inferred type of
+               bar :: (Head rngs ~ '(r, r'), Foo rngs) => FooData rngs
+               at T12844.hs:13:1-9
+             ‘r'’ is a rigid type variable bound by
+               the inferred type of
+               bar :: (Head rngs ~ '(r, r'), Foo rngs) => FooData rngs
+               at T12844.hs:13:1-9
+             ‘rngs’ is a rigid type variable bound by
+               the inferred type of
+               bar :: (Head rngs ~ '(r, r'), Foo rngs) => FooData rngs
+               at T12844.hs:13:1-9
+             ‘k’ is a rigid type variable bound by
+               the inferred type of
+               bar :: (Head rngs ~ '(r, r'), Foo rngs) => FooData rngs
+               at T12844.hs:13:1-9
+             ‘k1’ is a rigid type variable bound by
+               the inferred type of
+               bar :: (Head rngs ~ '(r, r'), Foo rngs) => FooData rngs
+               at T12844.hs:13:1-9
+    • In the type signature: bar :: _ => FooData rngs
diff --git a/testsuite/tests/partial-sigs/should_compile/all.T b/testsuite/tests/partial-sigs/should_compile/all.T
index b320851..10cdfaa 100644
--- a/testsuite/tests/partial-sigs/should_compile/all.T
+++ b/testsuite/tests/partial-sigs/should_compile/all.T
@@ -68,3 +68,4 @@ test('T11670', normal, compile, [''])
 test('T12156', normal, compile_fail, ['-fdefer-typed-holes'])
 test('T12531', normal, compile, ['-fdefer-typed-holes'])
 test('T12845', normal, compile, [''])
+test('T12844', normal, compile, [''])