Implement HasField constraint solving and modify OverloadedLabels

This implements automatic constraint solving for the new HasField class
and modifies the existing OverloadedLabels extension, as described in
the GHC proposal
(https://github.com/ghc-proposals/ghc-proposals/pull/6). Per the current
form of the proposal, it does *not* currently introduce a separate
`OverloadedRecordFields` extension.

This replaces D1687.

The users guide documentation still needs to be written, but I'll do
that after the implementation is merged, in case there are further
design changes.

Test Plan: new and modified tests in overloadedrecflds

Reviewers: simonpj, goldfire, dfeuer, bgamari, austin, hvr

Reviewed By: bgamari

Subscribers: maninalift, dfeuer, ysangkok, thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D2708

31 files changed, 315 insertions, 27 deletions

diff --git a/testsuite/tests/overloadedrecflds/ghci/all.T b/testsuite/tests/overloadedrecflds/ghci/all.T
index c67d42f1a8..6a95bb2744 100644
--- a/testsuite/tests/overloadedrecflds/ghci/all.T
+++ b/testsuite/tests/overloadedrecflds/ghci/all.T
@@ -1,2 +1,2 @@
-test('overloadedrecfldsghci01', combined_output, ghci_script, ['overloadedrecfldsghci01.script'])
+test('duplicaterecfldsghci01', combined_output, ghci_script, ['duplicaterecfldsghci01.script'])
 test('overloadedlabelsghci01', combined_output, ghci_script, ['overloadedlabelsghci01.script'])
diff --git a/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.script b/testsuite/tests/overloadedrecflds/ghci/duplicaterecfldsghci01.script
index 2aa0a15be8..2aa0a15be8 100644
--- a/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.script
+++ b/testsuite/tests/overloadedrecflds/ghci/duplicaterecfldsghci01.script
diff --git a/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.stdout b/testsuite/tests/overloadedrecflds/ghci/duplicaterecfldsghci01.stdout
index 3270089b9c..3270089b9c 100644
--- a/testsuite/tests/overloadedrecflds/ghci/overloadedrecfldsghci01.stdout
+++ b/testsuite/tests/overloadedrecflds/ghci/duplicaterecfldsghci01.stdout
diff --git a/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.script b/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.script
index 3b5dde1800..7bbee54e9d 100644
--- a/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.script
+++ b/testsuite/tests/overloadedrecflds/ghci/overloadedlabelsghci01.script
@@ -2,11 +2,12 @@
 :t #x
 :m + GHC.OverloadedLabels
 :seti -XFlexibleInstances -XFlexibleContexts -XTypeFamilies -XMultiParamTypeClasses
-instance IsLabel x [Char] where fromLabel _ = "hello"
-instance (s ~ [Char], t ~ [Char]) => IsLabel x (s -> t) where fromLabel _ = (++ " world")
+instance IsLabel x [Char] where fromLabel = "hello"
+instance {-# OVERLAPS #-} (s ~ [Char]) => IsLabel x (s -> [Char]) where fromLabel = (++ " world")
 #x :: String
-#x #y
+#x #y :: String
 :{
 #x
 "goodbye"
+ :: String
 :}
diff --git a/testsuite/tests/overloadedrecflds/should_fail/HasFieldFail01_A.hs b/testsuite/tests/overloadedrecflds/should_fail/HasFieldFail01_A.hs
new file mode 100644
index 0000000000..f7dc113525
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/HasFieldFail01_A.hs
@@ -0,0 +1,3 @@
+module HasFieldFail01_A where
+
+data T = MkT { foo :: Int }
diff --git a/testsuite/tests/overloadedrecflds/should_fail/all.T b/testsuite/tests/overloadedrecflds/should_fail/all.T
index f036ad0b63..98f16a056b 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/all.T
+++ b/testsuite/tests/overloadedrecflds/should_fail/all.T
@@ -18,8 +18,15 @@ test('overloadedrecfldsfail12', [], multimod_compile_fail,
 test('overloadedrecfldsfail13', normal, compile_fail, [''])
 test('overloadedrecfldsfail14', normal, compile_fail, [''])
 test('overloadedlabelsfail01', normal, compile_fail, [''])
+test('overloadedlabelsfail02', normal, compile_fail, [''])
+test('overloadedlabelsfail03', normal, compile_fail, [''])
 test('T11103', normal, compile_fail, [''])
 test('T11167_ambiguous_fixity', [], multimod_compile_fail,
      ['T11167_ambiguous_fixity', ''])
 test('T13132_duplicaterecflds', normal, compile_fail, [''])
 test('NoParent', normal, compile_fail, [''])
+test('hasfieldfail01',
+     extra_clean(['HasFieldFail01_A.hi', 'HasFieldFail01_A.o']),
+     multimod_compile_fail, ['hasfieldfail01', ''])
+test('hasfieldfail02', normal, compile_fail, [''])
+test('hasfieldfail03', normal, compile_fail, [''])
diff --git a/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.hs b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.hs
new file mode 100644
index 0000000000..d949074ab5
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE DataKinds, MagicHash, TypeFamilies, TypeApplications #-}
+
+import HasFieldFail01_A (T(MkT))
+
+import GHC.Records (HasField(..))
+
+-- This should fail to solve the HasField constraint, because foo is
+-- not in scope.
+main = print (getField @"foo" (MkT 42) :: Int)
diff --git a/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.stderr b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.stderr
new file mode 100644
index 0000000000..f2d5586103
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail01.stderr
@@ -0,0 +1,11 @@
+[1 of 2] Compiling HasFieldFail01_A ( HasFieldFail01_A.hs, HasFieldFail01_A.o )
+[2 of 2] Compiling Main             ( hasfieldfail01.hs, hasfieldfail01.o )
+
+hasfieldfail01.hs:9:15: error:
+    • No instance for (HasField "foo" T Int)
+        arising from a use of ‘getField’
+    • In the first argument of ‘print’, namely
+        ‘(getField @"foo" (MkT 42) :: Int)’
+      In the expression: print (getField @"foo" (MkT 42) :: Int)
+      In an equation for ‘main’:
+          main = print (getField @"foo" (MkT 42) :: Int)
diff --git a/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.hs b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.hs
new file mode 100644
index 0000000000..6eb9870fcd
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE DataKinds, ExistentialQuantification, MagicHash, RankNTypes,
+             TypeApplications #-}
+
+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 @"foo" (MkT id)
+
+-- This should fail because bar is a naughty record selector (it
+-- involves an existential).
+y = getField @"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 0000000000..2b90a1a987
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail02.stderr
@@ -0,0 +1,13 @@
+
+hasfieldfail02.hs:10:5: error:
+    • No instance for (HasField "foo" T a1)
+        arising from a use of ‘getField’
+    • In the expression: getField @"foo" (MkT id)
+      In an equation for ‘x’:
+          x = getField @"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 @"bar" (MkU True)
+      In an equation for ‘y’: y = getField @"bar" (MkU True)
diff --git a/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail03.hs b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail03.hs
new file mode 100644
index 0000000000..93117ee9b9
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail03.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE DataKinds, FlexibleInstances, MultiParamTypeClasses,
+             TypeFamilies #-}
+
+import GHC.Records (HasField(..))
+
+data T = MkT { foo :: Int, bar :: Int }
+
+-- This is far too polymorphic
+instance HasField "woo" a Bool where
+  getField = const True
+
+-- This conflicts with the built-in instance
+instance HasField "foo" T Int where
+  getField = foo
+
+-- So does this
+instance HasField "bar" T Bool where
+  getField = const True
+
+-- This doesn't conflict because there is no "baz" field in T
+instance HasField "baz" T Bool where
+  getField = const True
+
+-- Bool has no fields, so this is okay
+instance HasField a Bool Bool where
+  getField = id
+
+
+data family V a b c d
+data instance V x Int y [z] = MkVInt { baz :: (x, y, z, Bool) }
+
+-- Data families cannot have HasField instances, because they may get
+-- fields defined later on
+instance HasField "baz" (V a b c d) Bool where
+  getField = const True
+
+-- Function types can have HasField instances, in case it's useful
+instance HasField "woo" (a -> b) Bool where
+  getField = const True
diff --git a/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail03.stderr b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail03.stderr
new file mode 100644
index 0000000000..71192b2a98
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/hasfieldfail03.stderr
@@ -0,0 +1,21 @@
+
+hasfieldfail03.hs:9:10: error:
+    • Illegal instance declaration for ‘HasField "woo" a Bool’
+        Record data type must be specified
+    • In the instance declaration for ‘HasField "woo" a Bool’
+
+hasfieldfail03.hs:13:10: error:
+    • Illegal instance declaration for ‘HasField "foo" T Int’
+        T already has a field ‘foo’
+    • In the instance declaration for ‘HasField "foo" T Int’
+
+hasfieldfail03.hs:17:10: error:
+    • Illegal instance declaration for ‘HasField "bar" T Bool’
+        T already has a field ‘bar’
+    • In the instance declaration for ‘HasField "bar" T Bool’
+
+hasfieldfail03.hs:34:10: error:
+    • Illegal instance declaration for
+        ‘HasField "baz" (V a b c d) Bool’
+        Record data type may not be a data family
+    • In the instance declaration for ‘HasField "baz" (V a b c d) Bool’
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.hs
index 361da45086..ed68685d6d 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.hs
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.hs
@@ -5,8 +5,9 @@ import GHC.OverloadedLabels
 -- No instance for (OverloadedLabel "x" t0)
 a = #x
 
--- No instance for (OverloadedLabel "x" (t0 -> t1), OverloadedLabel "y" t0)
-b = #x #y
+-- No instance for (OverloadedLabel "x" Int)
+b :: Int
+b = #x
 
 -- Could not deduce (OverloadedLabel "y" t) from (OverloadedLabel "x" t)
 c :: IsLabel "x" t => t
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr
index f938d03169..4cd52315f0 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail01.stderr
@@ -1,31 +1,22 @@
 
 overloadedlabelsfail01.hs:6:5: error:
-    • No instance for (IsLabel "x" t2)
+    • No instance for (IsLabel "x" t0)
         arising from the overloaded label ‘#x’
     • In the expression: #x
       In an equation for ‘a’: a = #x
 
-overloadedlabelsfail01.hs:9:5: error:
-    • No instance for (IsLabel "x" (t1 -> t0))
+overloadedlabelsfail01.hs:10:5: error:
+    • No instance for (IsLabel "x" Int)
         arising from the overloaded label ‘#x’
-        (maybe you haven't applied a function to enough arguments?)
     • In the expression: #x
-      In the expression: #x #y
-      In an equation for ‘b’: b = #x #y
+      In an equation for ‘b’: b = #x
 
-overloadedlabelsfail01.hs:9:8: error:
-    • No instance for (IsLabel "y" t1)
-        arising from the overloaded label ‘#y’
-    • In the first argument of ‘#x’, namely ‘#y’
-      In the expression: #x #y
-      In an equation for ‘b’: b = #x #y
-
-overloadedlabelsfail01.hs:13:5: error:
+overloadedlabelsfail01.hs:14:5: error:
     • Could not deduce (IsLabel "y" t)
         arising from the overloaded label ‘#y’
       from the context: IsLabel "x" t
         bound by the type signature for:
                    c :: IsLabel "x" t => t
-        at overloadedlabelsfail01.hs:12:1-23
+        at overloadedlabelsfail01.hs:13:1-23
     • In the expression: #y
       In an equation for ‘c’: c = #y
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail02.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail02.hs
new file mode 100644
index 0000000000..d2d0f16ed4
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail02.hs
@@ -0,0 +1,3 @@
+{-# LANGUAGE OverloadedLabels, RebindableSyntax #-}
+
+main = #oops
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail02.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail02.stderr
new file mode 100644
index 0000000000..f47240fa9a
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail02.stderr
@@ -0,0 +1,2 @@
+
+overloadedlabelsfail02.hs:3:8: error: Not in scope: ‘fromLabel’
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail03.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail03.hs
new file mode 100644
index 0000000000..86709868fc
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail03.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE OverloadedLabels, RebindableSyntax #-}
+
+main = #foo
+  where
+    fromLabel = ()
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail03.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail03.stderr
new file mode 100644
index 0000000000..69aa43af40
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedlabelsfail03.stderr
@@ -0,0 +1,10 @@
+
+overloadedlabelsfail03.hs:3:8: error:
+    • Cannot apply expression of type ‘()’
+      to a visible type argument ‘"foo"’
+    • In the expression: #foo
+      In an equation for ‘main’:
+          main
+            = #foo
+            where
+                fromLabel = ()
diff --git a/testsuite/tests/overloadedrecflds/should_run/OverloadedLabelsRun04_A.hs b/testsuite/tests/overloadedrecflds/should_run/OverloadedLabelsRun04_A.hs
index e3b38c245e..8c3b992b8e 100644
--- a/testsuite/tests/overloadedrecflds/should_run/OverloadedLabelsRun04_A.hs
+++ b/testsuite/tests/overloadedrecflds/should_run/OverloadedLabelsRun04_A.hs
@@ -5,4 +5,4 @@ import GHC.OverloadedLabels
 import Language.Haskell.TH
 
 instance IsLabel x (Q [Dec]) where
-  fromLabel _ = [d| main = putStrLn "Ok" |]
+  fromLabel = [d| main = putStrLn "Ok" |]
diff --git a/testsuite/tests/overloadedrecflds/should_run/T12243.hs b/testsuite/tests/overloadedrecflds/should_run/T12243.hs
new file mode 100644
index 0000000000..62e8f4e5fd
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/T12243.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE AllowAmbiguousTypes
+           , DataKinds
+           , ExplicitForAll
+           , KindSignatures
+           , OverloadedLabels
+           , RebindableSyntax
+           , ScopedTypeVariables
+           , ImplicitPrelude
+  #-}
+
+import GHC.TypeLits (Symbol, KnownSymbol, symbolVal)
+import Data.Proxy
+
+foo = #foo
+  where
+    fromLabel :: forall (x :: Symbol) . ()
+    fromLabel = ()
+
+bar = #bar
+  where
+    fromLabel :: forall (x :: Symbol) . KnownSymbol x => String
+    fromLabel = symbolVal (Proxy :: Proxy x)
+
+main = do print foo
+          print bar
diff --git a/testsuite/tests/overloadedrecflds/should_run/T12243.stdout b/testsuite/tests/overloadedrecflds/should_run/T12243.stdout
new file mode 100644
index 0000000000..965dccfa73
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/T12243.stdout
@@ -0,0 +1,2 @@
+()
+"bar"
diff --git a/testsuite/tests/overloadedrecflds/should_run/all.T b/testsuite/tests/overloadedrecflds/should_run/all.T
index ad70a098c2..bfd77d35e4 100644
--- a/testsuite/tests/overloadedrecflds/should_run/all.T
+++ b/testsuite/tests/overloadedrecflds/should_run/all.T
@@ -6,9 +6,13 @@ test('overloadedrecfldsrun03', normal, compile_and_run, [''])
 test('overloadedrecfldsrun04', omit_ways(prof_ways), compile_and_run, [''])
 test('overloadedrecfldsrun05', normal, compile_and_run, [''])
 test('overloadedrecfldsrun06', normal, compile_and_run, [''])
+test('overloadedrecfldsrun07', normal, compile_and_run, [''])
 test('overloadedrecflds_generics', normal, compile_and_run, [''])
 test('overloadedlabelsrun01', normal, compile_and_run, [''])
 test('overloadedlabelsrun02', normal, compile_and_run, [''])
 test('overloadedlabelsrun03', normal, compile_and_run, [''])
 test('overloadedlabelsrun04', [omit_ways(prof_ways)], multimod_compile_and_run,
      ['overloadedlabelsrun04', config.ghc_th_way_flags])
+test('hasfieldrun01', normal, compile_and_run, [''])
+test('hasfieldrun02', normal, compile_and_run, [''])
+test('T12243', normal, compile_and_run, [''])
diff --git a/testsuite/tests/overloadedrecflds/should_run/hasfieldrun01.hs b/testsuite/tests/overloadedrecflds/should_run/hasfieldrun01.hs
new file mode 100644
index 0000000000..eb301baf17
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/hasfieldrun01.hs
@@ -0,0 +1,51 @@
+{-# LANGUAGE DataKinds
+           , DatatypeContexts
+           , FlexibleInstances
+           , GADTs
+           , MultiParamTypeClasses
+           , TypeFamilies
+           , TypeApplications
+  #-}
+
+import GHC.Records (HasField(..))
+
+type family B where B = Bool
+
+data T = MkT { foo :: Int, bar :: B }
+
+data U a b = MkU { baf :: a }
+
+data family V a b c d
+data instance V x Int y [z] = MkVInt { baz :: (x, y, z, Bool) }
+
+data W a where
+  MkW :: { woo :: a } -> W [a]
+
+data Eq a => X a = MkX { xoo :: a }
+data Y a = Eq a => MkY { yoo :: a }
+
+t = MkT 42 True
+
+u :: U Char Char
+u = MkU 'x'
+
+v = MkVInt (42, 'x', True, False)
+
+w = MkW True
+
+x = MkX True
+
+y = MkY True
+
+-- A virtual foo field for U
+instance HasField "foo" (U a b) [Char] where
+  getField _ = "virtual"
+
+main = do print (getField @"foo" t)
+          print (getField @"bar" t)
+          print (getField @"baf" u)
+          print (getField @"foo" u)
+          print (getField @"baz" v)
+          print (getField @"woo" w)
+          print (getField @"xoo" x)
+          print (getField @"yoo" y)
diff --git a/testsuite/tests/overloadedrecflds/should_run/hasfieldrun01.stdout b/testsuite/tests/overloadedrecflds/should_run/hasfieldrun01.stdout
new file mode 100644
index 0000000000..529b96bce8
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/hasfieldrun01.stdout
@@ -0,0 +1,8 @@
+42
+True
+'x'
+"virtual"
+(42,'x',True,False)
+True
+True
+True
diff --git a/testsuite/tests/overloadedrecflds/should_run/hasfieldrun02.hs b/testsuite/tests/overloadedrecflds/should_run/hasfieldrun02.hs
new file mode 100644
index 0000000000..5bfddbbe33
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/hasfieldrun02.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE DuplicateRecordFields, OverloadedLabels,
+             ExistentialQuantification,
+             FlexibleInstances, MultiParamTypeClasses,
+             ScopedTypeVariables, TypeApplications #-}
+
+import GHC.OverloadedLabels
+import GHC.Records
+
+data S = MkS { foo :: Int }
+data T x y z = forall b . MkT { foo :: y, bar :: b }
+
+instance HasField x r a => IsLabel x (r -> a) where
+  fromLabel = getField @x
+
+main = do print (#foo (MkS 42))
+          print (#foo (MkT True False))
diff --git a/testsuite/tests/overloadedrecflds/should_run/hasfieldrun02.stdout b/testsuite/tests/overloadedrecflds/should_run/hasfieldrun02.stdout
new file mode 100644
index 0000000000..abc4e3b957
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/hasfieldrun02.stdout
@@ -0,0 +1,2 @@
+42
+True
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.hs
index 45c7854e64..972932c3c2 100644
--- a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.hs
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun01.hs
@@ -11,10 +11,10 @@
 import GHC.OverloadedLabels
 
 instance IsLabel "true" Bool where
-  fromLabel _ = True
+  fromLabel = True
 
 instance IsLabel "false" Bool where
-  fromLabel _ = False
+  fromLabel = False
 
 a :: IsLabel "true" t => t
 a = #true
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun02.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun02.hs
index eea8f36d40..94f8d0c877 100644
--- a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun02.hs
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun02.hs
@@ -20,7 +20,7 @@ import Data.Proxy ( Proxy(..) )
 import GHC.TypeLits ( Symbol )
 
 instance x ~ y => IsLabel x (Proxy y) where
-  fromLabel _ = Proxy
+  fromLabel = Proxy
 
 data Elem (x :: Symbol) g where
   Top :: Elem x (x ': g)
@@ -45,7 +45,7 @@ data Tm g where
 deriving instance Show (Tm g)
 
 instance IsElem x g => IsLabel x (Tm g) where
-  fromLabel _ = Var (which :: Elem x g)
+  fromLabel = Var (which :: Elem x g)
 
 lam :: Proxy x -> Tm (x ': g) -> Tm g
 lam _ = Lam
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun03.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun03.hs
index a854d7ae07..f84a3802f5 100644
--- a/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun03.hs
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedlabelsrun03.hs
@@ -15,7 +15,7 @@ import Data.Proxy ( Proxy(..) )
 import GHC.TypeLits ( KnownSymbol, symbolVal )
 
 instance (KnownSymbol x, c ~ Char) => IsLabel x [c] where
-  fromLabel _ = symbolVal (Proxy :: Proxy x)
+  fromLabel = symbolVal (Proxy :: Proxy x)
 
 main = do putStrLn #x
           print $ #x ++ #y
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun07.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun07.hs
new file mode 100644
index 0000000000..25da616583
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun07.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE DataKinds
+           , FlexibleContexts
+           , FlexibleInstances
+           , GADTs
+           , MultiParamTypeClasses
+           , OverloadedLabels
+           , PolyKinds
+           , ScopedTypeVariables
+           , TypeApplications
+           , TypeOperators
+           , UndecidableInstances
+  #-}
+
+import GHC.OverloadedLabels
+import GHC.Records
+import GHC.TypeLits
+
+data Label (x :: Symbol) = Label
+data Labelled x a = Label x := a
+
+data Rec :: [(k, *)] -> * where
+  Nil  :: Rec '[]
+  (:>) :: Labelled x a -> Rec xs -> Rec ('(x, a) ': xs)
+infixr 5 :>
+
+instance {-# OVERLAPS #-} a ~ b => HasField foo (Rec ('(foo, a) ': xs)) b where
+  getField ((_ := v) :> _) = v
+
+instance HasField foo (Rec xs) b => HasField foo (Rec ('(bar, a) ': xs)) b where
+  getField (_ :> vs) = getField @foo vs
+
+instance y ~ x => IsLabel y (Label x) where
+  fromLabel = Label
+
+instance HasField x r a => IsLabel x (r -> a) where
+  fromLabel = getField @x
+
+x :: Rec '[ '("foo", Int), '("bar", Bool)]
+x = #foo := 42 :> #bar := True :> Nil
+
+y = #bar := 'x' :> undefined
+
+main = do print (#foo x)
+          print (#bar x)
+          print (#bar y)
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun07.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun07.stdout
new file mode 100644
index 0000000000..1bfbe7af2c
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun07.stdout
@@ -0,0 +1,3 @@
+42
+True
+'x'