[commit: ghc] master: Use actual universal tvs in check for naughty record selectors (9077120)

[git at git.haskell.org]

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

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

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

commit 9077120918b78f5152bf3596fe6df07b91cead79
Author: Matthew Pickering <matthewtpickering at gmail.com>
Date:   Fri Jun 23 11:40:50 2017 -0400

    Use actual universal tvs in check for naughty record selectors
    
    The naughty record selector check means to limit selectors which would
    lead to existential tyvars escaping their scope. With record pattern
    synonyms, there are situations where universal tyvars don't appear in
    the result type, for example:
    
    ```
    pattern ReadP :: Read a => a -> String
    pattern ReadP{readp} <- (read -> readp)
    ```
    
    This is a similar issue to #11224 where we assumed that we can decide
    which variables are universal and which are existential by the syntactic
    check of seeing which appear in the result type. The fix is to use
    `univ_tvs` from `conLikeFullSig` rather than the previous approximation.
    But we must also remember to apply `EqSpec`s so we use the free
    variables from `inst_tys` which is precisely `univ_tvs` with `EqSpecs`
    applied.
    
    Reviewers: austin, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: rwbarton, thomie
    
    Differential Revision: https://phabricator.haskell.org/D3649


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

9077120918b78f5152bf3596fe6df07b91cead79
 compiler/typecheck/TcTyDecls.hs                      | 2 +-
 testsuite/tests/patsyn/should_run/records-run.hs     | 7 +++++++
 testsuite/tests/patsyn/should_run/records-run.stdout | 1 +
 3 files changed, 9 insertions(+), 1 deletion(-)

diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs
index df33bb0..68e15fb 100644
--- a/compiler/typecheck/TcTyDecls.hs
+++ b/compiler/typecheck/TcTyDecls.hs
@@ -846,7 +846,7 @@ mkOneRecordSelector all_cons idDetails fl
 
     -- Selector type; Note [Polymorphic selectors]
     field_ty   = conLikeFieldType con1 lbl
-    data_tvs   = tyCoVarsOfTypeWellScoped data_ty
+    data_tvs   = tyCoVarsOfTypesWellScoped inst_tys
     data_tv_set= mkVarSet data_tvs
     is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set)
     (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty
diff --git a/testsuite/tests/patsyn/should_run/records-run.hs b/testsuite/tests/patsyn/should_run/records-run.hs
index 19a6bb2..1719045 100644
--- a/testsuite/tests/patsyn/should_run/records-run.hs
+++ b/testsuite/tests/patsyn/should_run/records-run.hs
@@ -1,4 +1,6 @@
 {-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
 
 module Main where
 
@@ -6,9 +8,14 @@ pattern Bi{a, b} = (a, b)
 
 foo = ("a","b")
 
+pattern ReadP :: Read a => a -> String
+pattern ReadP {readp} <- (read -> readp)
+
 main = do
   print foo
   print (a foo)
   print (b foo)
   print (foo {a = "c"})
   print (foo {a = "fst", b = "snd"})
+
+  print (readp @Int "5")
diff --git a/testsuite/tests/patsyn/should_run/records-run.stdout b/testsuite/tests/patsyn/should_run/records-run.stdout
index a0878c7..e76be9c 100644
--- a/testsuite/tests/patsyn/should_run/records-run.stdout
+++ b/testsuite/tests/patsyn/should_run/records-run.stdout
@@ -3,3 +3,4 @@
 "b"
 ("c","b")
 ("fst","snd")
+5