[commit: ghc] ghc-8.0: Fix #11512 by getting visibility right for methods (4c64da0)

[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/4c64da079d6009f8da7877c86c12ac5212c15d3e/ghc

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

commit 4c64da079d6009f8da7877c86c12ac5212c15d3e
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date:   Wed Mar 16 23:37:30 2016 -0400

    Fix #11512 by getting visibility right for methods
    
    Test case: typecheck/should_compile/T11512
    
    (cherry picked from commit f4f315a37470ce86e3eadeb328d0d3a9242f3097)


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

4c64da079d6009f8da7877c86c12ac5212c15d3e
 compiler/basicTypes/MkId.hs                           | 19 ++++++++++++++-----
 compiler/typecheck/TcExpr.hs                          |  5 ++++-
 .../tests/dependent/should_compile/RaeJobTalk.hs      |  4 ++--
 testsuite/tests/typecheck/should_compile/T11512.hs    | 11 +++++++++++
 testsuite/tests/typecheck/should_compile/all.T        |  1 +
 5 files changed, 32 insertions(+), 8 deletions(-)

diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs
index 92d6b5e..5bab875 100644
--- a/compiler/basicTypes/MkId.hs
+++ b/compiler/basicTypes/MkId.hs
@@ -262,9 +262,6 @@ Then the top-level type for op is
               forall b. Ord b =>
               a -> b -> b
 
-This is unlike ordinary record selectors, which have all the for-alls
-at the outside.  When dealing with classes it's very convenient to
-recover the original type signature from the class op selector.
 -}
 
 mkDictSelId :: Name          -- Name of one of the *value* selectors
@@ -278,11 +275,23 @@ mkDictSelId name clas
     new_tycon      = isNewTyCon tycon
     [data_con]     = tyConDataCons tycon
     tyvars         = dataConUnivTyVars data_con
+    tc_binders     = tyConBinders tycon
     arg_tys        = dataConRepArgTys data_con  -- Includes the dictionary superclasses
     val_index      = assoc "MkId.mkDictSelId" (sel_names `zip` [0..]) name
 
-    sel_ty = mkSpecForAllTys tyvars (mkFunTy (mkClassPred clas (mkTyVarTys tyvars))
-                                             (getNth arg_tys val_index))
+    sel_ty = mkForAllTys (zipWith mk_binder tc_binders tyvars) $
+             mkFunTy (mkClassPred clas (mkTyVarTys tyvars)) $
+             getNth arg_tys val_index
+
+      -- copy the visibility from the tycon binders. Consider:
+      --   class C a where foo :: Proxy a
+      -- In the type of foo, `a` must be Specified but `k` must be Invisible
+    mk_binder tc_binder tyvar
+      | Invisible <- binderVisibility tc_binder
+      = mkNamedBinder Invisible tyvar
+      | otherwise
+      = mkNamedBinder Specified tyvar   -- don't just copy from tc_binder, because
+                                        -- tc_binders can be Visible
 
     base_info = noCafIdInfo
                 `setArityInfo`         1
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 23d0de9..4d6a109 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -1175,7 +1175,10 @@ tcArgs fun orig_fun_ty fun_orig orig_args herald
            ; case tcSplitForAllTy_maybe upsilon_ty of
                Just (binder, inner_ty)
                  | Just tv <- binderVar_maybe binder ->
-                 ASSERT( binderVisibility binder == Specified )
+                 ASSERT2( binderVisibility binder == Specified
+                        , (vcat [ ppr fun_ty, ppr upsilon_ty, ppr binder
+                                , ppr inner_ty, pprTvBndr tv
+                                , ppr (binderVisibility binder) ]) )
                  do { let kind = tyVarKind tv
                     ; ty_arg <- tcHsTypeApp hs_ty_arg kind
                     ; let insted_ty = substTyWithUnchecked [tv] [ty_arg] inner_ty
diff --git a/testsuite/tests/dependent/should_compile/RaeJobTalk.hs b/testsuite/tests/dependent/should_compile/RaeJobTalk.hs
index 705c0ef..c03503d 100644
--- a/testsuite/tests/dependent/should_compile/RaeJobTalk.hs
+++ b/testsuite/tests/dependent/should_compile/RaeJobTalk.hs
@@ -217,7 +217,7 @@ instance TyConAble RuntimeRep    where tyCon = RuntimeRep
 
 -- Can't just define Typeable the way we want, because the instances
 -- overlap. So we have to mock up instance chains via closed type families.
-class Typeable' (a :: k) (b :: Bool) where
+class Typeable' a (b :: Bool) where
   typeRep' :: TypeRep a
 
 type family CheckPrim a where
@@ -236,7 +236,7 @@ instance (Typeable a, Typeable b) => Typeable' (a b) 'False where
   typeRep' = TyApp typeRep typeRep
 
 typeRep :: forall a. Typeable a => TypeRep a
-typeRep = typeRep' @_ @_ @(CheckPrim a) -- RAE: #11512 says we need the extra @_.
+typeRep = typeRep' @_ @(CheckPrim a)
 
 -----------------------------
 -- Useful instances
diff --git a/testsuite/tests/typecheck/should_compile/T11512.hs b/testsuite/tests/typecheck/should_compile/T11512.hs
new file mode 100644
index 0000000..49100e0
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T11512.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE PolyKinds, TypeApplications, ScopedTypeVariables #-}
+
+module Bug where
+
+import Data.Proxy
+
+class C a where
+  foo :: Proxy a
+
+bar :: forall a. C a => Proxy a
+bar = foo @a
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 98f6ef0..f1403da 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -507,3 +507,4 @@ test('T11246', normal, compile, [''])
 test('T11608', normal, compile, [''])
 test('T11401', normal, compile, [''])
 test('T11699', normal, compile, [''])
+test('T11512', normal, compile, [''])