[commit: ghc] ghc-8.0: Fix inference of partial signatures (4212674)

[git at git.haskell.org]

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

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/4212674ba92971734eec064809f8e1a45bca992a/ghc

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

commit 4212674ba92971734eec064809f8e1a45bca992a
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
    
    (cherry picked from commit 1bfff60fc57cd564382b86bdfb1f2764ca15d44f)


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

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

diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs
index a1ad6be..dddae3e 100644
--- a/compiler/typecheck/TcBinds.hs
+++ b/compiler/typecheck/TcBinds.hs
@@ -778,8 +778,11 @@ chooseInferredQuantifiers inferred_theta tau_tvs qtvs
   | PartialSig { sig_cts = extra } <- bndr_info
   , Just loc <- extra
   = 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 = pickQuantifiablePreds free_tvs annotated_theta 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..b7b9a71
--- /dev/null
+++ b/testsuite/tests/partial-sigs/should_compile/T12844.stderr
@@ -0,0 +1,6 @@
+
+T12844.hs:12:9: warning: [-Wpartial-type-signatures (in -Wdefault)]
+    Found constraint wildcard ‘_’ standing for ‘(Head rngs ~ '(r, r'),
+                                                 Foo rngs)’
+    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 3cec3e0..e5f266b 100644
--- a/testsuite/tests/partial-sigs/should_compile/all.T
+++ b/testsuite/tests/partial-sigs/should_compile/all.T
@@ -64,3 +64,4 @@ test('T11016', normal, compile, [''])
 test('T11192', normal, compile, [''])
 test('T12156', normal, compile_fail, ['-fdefer-typed-holes'])
 test('T12531', normal, compile, ['-fdefer-typed-holes'])
+test('T12844', normal, compile, [''])