[commit: ghc] wip/hasfield: Do not solve HasField constraints where the field is naughty or higher-rank (eb6f660)

[git at git.haskell.org]

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

On branch  : wip/hasfield
Link       : http://ghc.haskell.org/trac/ghc/changeset/eb6f660b85c7d0ac173b314c8b30fd3a045efe6b/ghc

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

commit eb6f660b85c7d0ac173b314c8b30fd3a045efe6b
Author: Adam Gundry <adam at well-typed.com>
Date:   Tue Dec 22 16:34:59 2015 +0000

    Do not solve HasField constraints where the field is naughty or higher-rank


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

eb6f660b85c7d0ac173b314c8b30fd3a045efe6b
 compiler/typecheck/TcInteract.hs                         |  8 ++++++--
 testsuite/tests/overloadedrecflds/should_fail/all.T      |  1 +
 .../overloadedrecflds/should_fail/hasfieldfail02.hs      | 16 ++++++++++++++++
 .../overloadedrecflds/should_fail/hasfieldfail02.stderr  | 14 ++++++++++++++
 4 files changed, 37 insertions(+), 2 deletions(-)

diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index c0e37b0..d246b15 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -29,7 +29,7 @@ import PrelNames ( knownNatClassName, knownSymbolClassName,
 import TysWiredIn ( ipClass, typeNatKind, typeSymbolKind, heqDataCon,
                     coercibleDataCon )
 import TysPrim    ( eqPrimTyCon, eqReprPrimTyCon, mkProxyPrimTy )
-import Id( idType )
+import Id( idType, isNaughtyRecordSelector )
 import CoAxiom ( Eqn, CoAxiom(..), CoAxBranch(..), fromBranches )
 import Class
 import TyCon
@@ -2154,6 +2154,10 @@ matchHasField clas tys@[x_ty, r_ty, a_ty]
              inst_field_ty = substTy tenv field_ty
              theta = mkTyConApp eqPrimTyCon [liftedTypeKind, liftedTypeKind, inst_field_ty, a_ty ]
 
+       ; if isNaughtyRecordSelector sel_id || not (isTauTy inst_field_ty)
+         then return NoInstance
+         else do {
+
        ; let mk_ev [ev] = EvCast (EvExpr (mkHsLamConst proxy_ty (mkFunTy r_ty a_ty) body)) (mkTcSymCo ax)
                where
                 proxy_ty = mkProxyPrimTy typeSymbolKind x_ty
@@ -2166,7 +2170,7 @@ matchHasField clas tys@[x_ty, r_ty, a_ty]
                          , lir_mk_ev     = mk_ev
                          , lir_safe_over = True
                          })
-       } }
+       } } }
 matchHasField _ _ = return NoInstance
 
 mkHsLamConst :: Type -> Type -> HsExpr Id -> HsExpr Id
diff --git a/testsuite/tests/overloadedrecflds/should_fail/all.T b/testsuite/tests/overloadedrecflds/should_fail/all.T
index 9f5b780..5f378e9 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/all.T
+++ b/testsuite/tests/overloadedrecflds/should_fail/all.T
@@ -33,3 +33,4 @@ test('T11167_ambiguous_fixity',
 test('hasfieldfail01',
      extra_clean(['HasFieldFail01_A.hi', 'HasFieldFail01_A.o']),
      multimod_compile_fail, ['hasfieldfail01', ''])
+test('hasfieldfail02', normal, compile_fail, [''])
diff --git a/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.hs b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.hs
new file mode 100644
index 0000000..d3175d2
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE DataKinds, ExistentialQuantification, MagicHash, RankNTypes #-}
+
+import GHC.Prim (Proxy#, proxy#)
+import GHC.Records (HasField(..))
+
+data T = MkT { foo :: forall a . a -> a }
+data U = forall b . MkU { bar :: b }
+
+-- This should fail because foo is higher-rank.
+x = getField (proxy# :: Proxy# "foo") (MkT id)
+
+-- This should fail because bar is a naughty record selector (it
+-- involves an existential).
+y = getField (proxy# :: Proxy# "bar") (MkU True)
+
+main = return ()
diff --git a/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.stderr b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.stderr
new file mode 100644
index 0000000..aea9fea
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.stderr
@@ -0,0 +1,14 @@
+
+hasfieldfail02.hs:10:5: error:
+    • No instance for (HasField "foo" T a1)
+        arising from a use of ‘getField’
+    • In the expression: getField (proxy# :: Proxy# "foo") (MkT id)
+      In an equation for ‘x’:
+          x = getField (proxy# :: Proxy# "foo") (MkT id)
+
+hasfieldfail02.hs:14:5: error:
+    • No instance for (HasField "bar" U a0)
+        arising from a use of ‘getField’
+    • In the expression: getField (proxy# :: Proxy# "bar") (MkU True)
+      In an equation for ‘y’:
+          y = getField (proxy# :: Proxy# "bar") (MkU True)