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

56 files changed, 701 insertions, 109 deletions

diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs
index 952ea8d..96c3772 100644
--- a/compiler/basicTypes/DataCon.hs
+++ b/compiler/basicTypes/DataCon.hs
@@ -37,7 +37,7 @@ module DataCon (
         dataConStupidTheta,
         dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
         dataConInstOrigArgTys, dataConRepArgTys,
-        dataConFieldLabels, dataConFieldType,
+        dataConFieldLabels, dataConFieldType, dataConFieldType_maybe,
         dataConSrcBangs,
         dataConSourceArity, dataConRepArity,
         dataConIsInfix,
@@ -973,10 +973,16 @@ dataConFieldLabels = dcFields
 
 -- | Extract the type for any given labelled field of the 'DataCon'
 dataConFieldType :: DataCon -> FieldLabelString -> Type
-dataConFieldType con label
-  = case find ((== label) . flLabel . fst) (dcFields con `zip` dcOrigArgTys con) of
+dataConFieldType con label = case dataConFieldType_maybe con label of
       Just (_, ty) -> ty
-      Nothing -> pprPanic "dataConFieldType" (ppr con <+> ppr label)
+      Nothing      -> pprPanic "dataConFieldType" (ppr con <+> ppr label)
+
+-- | Extract the label and type for any given labelled field of the
+-- 'DataCon', or return 'Nothing' if the field does not belong to it
+dataConFieldType_maybe :: DataCon -> FieldLabelString
+                       -> Maybe (FieldLabel, Type)
+dataConFieldType_maybe con label
+  = find ((== label) . flLabel . fst) (dcFields con `zip` dcOrigArgTys con)
 
 -- | Strictness/unpack annotations, from user; or, for imported
 -- DataCons, from the interface file
diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs
index 022cfe7..23c6d68 100644
--- a/compiler/basicTypes/RdrName.hs
+++ b/compiler/basicTypes/RdrName.hs
@@ -46,7 +46,8 @@ module RdrName (
         GlobalRdrEnv, emptyGlobalRdrEnv, mkGlobalRdrEnv, plusGlobalRdrEnv,
         lookupGlobalRdrEnv, extendGlobalRdrEnv, greOccName, shadowNames,
         pprGlobalRdrEnv, globalRdrEnvElts,
-        lookupGRE_RdrName, lookupGRE_Name, lookupGRE_Field_Name, getGRE_NameQualifier_maybes,
+        lookupGRE_RdrName, lookupGRE_Name, lookupGRE_FieldLabel,
+        getGRE_NameQualifier_maybes,
         transformGREs, pickGREs, pickGREsModExp,
 
         -- * GlobalRdrElts
@@ -791,21 +792,32 @@ lookupGRE_RdrName rdr_name env
     Just gres -> pickGREs rdr_name gres
 
 lookupGRE_Name :: GlobalRdrEnv -> Name -> Maybe GlobalRdrElt
+-- ^ Look for precisely this 'Name' in the environment.  This tests
+-- whether it is in scope, ignoring anything else that might be in
+-- scope with the same 'OccName'.
 lookupGRE_Name env name
-  = case [ gre | gre <- lookupGlobalRdrEnv env (nameOccName name)
+  = lookupGRE_Name_OccName env name (nameOccName name)
+
+lookupGRE_FieldLabel :: GlobalRdrEnv -> FieldLabel -> Maybe GlobalRdrElt
+-- ^ Look for a particular record field selector in the environment, where the
+-- selector name and field label may be different: the GlobalRdrEnv is keyed on
+-- the label.  See Note [Parents for record fields] for why this happens.
+lookupGRE_FieldLabel env fl
+  = lookupGRE_Name_OccName env (flSelector fl) (mkVarOccFS (flLabel fl))
+
+lookupGRE_Name_OccName :: GlobalRdrEnv -> Name -> OccName -> Maybe GlobalRdrElt
+-- ^ Look for precisely this 'Name' in the environment, but with an 'OccName'
+-- that might differ from that of the 'Name'.  See 'lookupGRE_FieldLabel' and
+-- Note [Parents for record fields].
+lookupGRE_Name_OccName env name occ
+  = case [ gre | gre <- lookupGlobalRdrEnv env occ
                , gre_name gre == name ] of
       []    -> Nothing
       [gre] -> Just gre
-      gres  -> pprPanic "lookupGRE_Name" (ppr name $$ ppr gres)
+      gres  -> pprPanic "lookupGRE_Name_OccName"
+                        (ppr name $$ ppr occ $$ ppr gres)
                -- See INVARIANT 1 on GlobalRdrEnv
 
-lookupGRE_Field_Name :: GlobalRdrEnv -> Name -> FastString -> [GlobalRdrElt]
--- Used when looking up record fields, where the selector name and
--- field label are different: the GlobalRdrEnv is keyed on the label
-lookupGRE_Field_Name env sel_name lbl
-  = [ gre | gre <- lookupGlobalRdrEnv env (mkVarOccFS lbl),
-            gre_name gre == sel_name ]
-
 
 getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]]
 -- Returns all the qualifiers by which 'x' is in scope
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs
index ddab00c..d42b6b0 100644
--- a/compiler/deSugar/Coverage.hs
+++ b/compiler/deSugar/Coverage.hs
@@ -514,7 +514,7 @@ addTickHsExpr e@(HsConLikeOut con)
   | Just id <- conLikeWrapId_maybe con = do freeVar id; return e
 addTickHsExpr e@(HsIPVar _)      = return e
 addTickHsExpr e@(HsOverLit _)    = return e
-addTickHsExpr e@(HsOverLabel _)  = return e
+addTickHsExpr e@(HsOverLabel{})  = return e
 addTickHsExpr e@(HsLit _)        = return e
 addTickHsExpr (HsLam matchgroup) = liftM HsLam (addTickMatchGroup True matchgroup)
 addTickHsExpr (HsLamCase mgs)    = liftM HsLamCase (addTickMatchGroup True mgs)
diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 443a21e..b367d69 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -1171,6 +1171,10 @@ dsEvTerm (EvSuperClass d n)
              sc_sel_id  = classSCSelId cls n    -- Zero-indexed
        ; return $ Var sc_sel_id `mkTyApps` tys `App` d' }
 
+dsEvTerm (EvSelector sel_id tys tms)
+  = do { tms' <- mapM dsEvTerm tms
+       ; return $ Var sel_id `mkTyApps` tys `mkApps` tms' }
+
 dsEvTerm (EvDelayedError ty msg) = return $ dsEvDelayedError ty msg
 
 dsEvDelayedError :: Type -> FastString -> CoreExpr
diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index 575b510..28254c9 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -259,7 +259,7 @@ dsExpr (HsVar (L _ var))      = return (varToCoreExpr var)
 dsExpr (HsUnboundVar {})      = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
 dsExpr (HsConLikeOut con)     = return (dsConLike con)
 dsExpr (HsIPVar _)            = panic "dsExpr: HsIPVar"
-dsExpr (HsOverLabel _)        = panic "dsExpr: HsOverLabel"
+dsExpr (HsOverLabel{})        = panic "dsExpr: HsOverLabel"
 dsExpr (HsLit lit)            = dsLit lit
 dsExpr (HsOverLit lit)        = dsOverLit lit
 
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index f8572cb..7880474 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1158,7 +1158,7 @@ repE (HsVar (L _ x))            =
         Just (DsSplice e)  -> do { e' <- dsExpr e
                                  ; return (MkC e') } }
 repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
-repE e@(HsOverLabel _) = notHandled "Overloaded labels" (ppr e)
+repE e@(HsOverLabel{}) = notHandled "Overloaded labels" (ppr e)
 
 repE e@(HsRecFld f) = case f of
   Unambiguous _ x -> repE (HsVar (noLoc x))
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index 53b719a..840a5fe 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -980,7 +980,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     -- the instance for IPName derives using the id, so this works if the
     -- above does
     exp (HsIPVar i) (HsIPVar i') = i == i'
-    exp (HsOverLabel l) (HsOverLabel l') = l == l'
+    exp (HsOverLabel l x) (HsOverLabel l' x') = l == l' && x == x'
     exp (HsOverLit l) (HsOverLit l') =
         -- Overloaded lits are equal if they have the same type
         -- and the data is the same.
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 7202452..9ad096e 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -292,9 +292,11 @@ data HsExpr id
   | HsRecFld (AmbiguousFieldOcc id) -- ^ Variable pointing to record selector
                                     -- Not in use after typechecking
 
-  | HsOverLabel FastString   -- ^ Overloaded label (See Note [Overloaded labels]
-                             --   in GHC.OverloadedLabels)
-                             --   NB: Not in use after typechecking
+  | HsOverLabel (Maybe id) FastString
+     -- ^ Overloaded label (Note [Overloaded labels] in GHC.OverloadedLabels)
+     --   @Just id@ means @RebindableSyntax@ is in use, and gives the id of the
+     --   in-scope 'fromLabel'.
+     --   NB: Not in use after typechecking
 
   | HsIPVar   HsIPName       -- ^ Implicit parameter (not in use after typechecking)
   | HsOverLit (HsOverLit id) -- ^ Overloaded literals
@@ -824,7 +826,7 @@ ppr_expr (HsVar (L _ v))  = pprPrefixOcc v
 ppr_expr (HsUnboundVar uv)= pprPrefixOcc (unboundVarOcc uv)
 ppr_expr (HsConLikeOut c) = pprPrefixOcc c
 ppr_expr (HsIPVar v)      = ppr v
-ppr_expr (HsOverLabel l)  = char '#' <> ppr l
+ppr_expr (HsOverLabel _ l)= char '#' <> ppr l
 ppr_expr (HsLit lit)      = ppr lit
 ppr_expr (HsOverLit lit)  = ppr lit
 ppr_expr (HsPar e)        = parens (ppr_lexpr e)
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index e0e060e..175cfbb 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -2485,7 +2485,7 @@ aexp2   :: { LHsExpr RdrName }
         : qvar                          { sL1 $1 (HsVar   $! $1) }
         | qcon                          { sL1 $1 (HsVar   $! $1) }
         | ipvar                         { sL1 $1 (HsIPVar $! unLoc $1) }
-        | overloaded_label              { sL1 $1 (HsOverLabel $! unLoc $1) }
+        | overloaded_label              { sL1 $1 (HsOverLabel Nothing $! unLoc $1) }
         | literal                       { sL1 $1 (HsLit   $! unLoc $1) }
 -- This will enable overloaded strings permanently.  Normally the renamer turns HsString
 -- into HsOverLit when -foverloaded-strings is on.
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index b8959e3..47b78f1 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -353,6 +353,9 @@ basicKnownKeyNames
         -- Implicit Parameters
         ipClassName,
 
+        -- Overloaded record fields
+        hasFieldClassName,
+
         -- Call Stacks
         callStackTyConName,
         emptyCallStackName, pushCallStackName,
@@ -540,6 +543,9 @@ gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type")
 gHC_OVER_LABELS :: Module
 gHC_OVER_LABELS = mkBaseModule (fsLit "GHC.OverloadedLabels")
 
+gHC_RECORDS :: Module
+gHC_RECORDS = mkBaseModule (fsLit "GHC.Records")
+
 mAIN, rOOT_MAIN :: Module
 mAIN            = mkMainModule_ mAIN_NAME
 rOOT_MAIN       = mkMainModule (fsLit ":Main") -- Root module for initialisation
@@ -1387,6 +1393,11 @@ ipClassName :: Name
 ipClassName
   = clsQual gHC_CLASSES (fsLit "IP") ipClassKey
 
+-- Overloaded record fields
+hasFieldClassName :: Name
+hasFieldClassName
+ = clsQual gHC_RECORDS (fsLit "HasField") hasFieldClassNameKey
+
 -- Source Locations
 callStackTyConName, emptyCallStackName, pushCallStackName,
   srcLocDataConName :: Name
@@ -1554,6 +1565,11 @@ monoidClassKey    = mkPreludeClassUnique 47
 ipClassKey :: Unique
 ipClassKey = mkPreludeClassUnique 48
 
+-- Overloaded record fields
+hasFieldClassNameKey :: Unique
+hasFieldClassNameKey = mkPreludeClassUnique 49
+
+
 ---------------- Template Haskell -------------------
 --      THNames.hs: USES ClassUniques 200-299
 -----------------------------------------------------
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 769dff0..4e9192c 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -126,8 +126,12 @@ rnExpr (HsVar (L l v))
 rnExpr (HsIPVar v)
   = return (HsIPVar v, emptyFVs)
 
-rnExpr (HsOverLabel v)
-  = return (HsOverLabel v, emptyFVs)
+rnExpr (HsOverLabel _ v)
+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax
+       ; if rebindable_on
+         then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel"))
+                 ; return (HsOverLabel (Just fromLabel) v, unitFV fromLabel) }
+         else return (HsOverLabel Nothing v, emptyFVs) }
 
 rnExpr (HsLit lit@(HsString src s))
   = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index 2122c70..c18138b 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -618,33 +618,34 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
            ; (rdr_env, lcl_env) <- getRdrEnvs
            ; con_fields <- lookupConstructorFields con
            ; when (null con_fields) (addErr (badDotDotCon con))
-           ; let present_flds = map (occNameFS . rdrNameOcc) $ getFieldLbls flds
+           ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds)
 
                    -- For constructor uses (but not patterns)
                    -- the arg should be in scope locally;
                    -- i.e. not top level or imported
                    -- Eg.  data R = R { x,y :: Int }
                    --      f x = R { .. }   -- Should expand to R {x=x}, not R{x=x,y=y}
-                 arg_in_scope lbl = mkVarUnqual lbl `elemLocalRdrEnv` lcl_env
+                 arg_in_scope lbl = mkRdrUnqual lbl `elemLocalRdrEnv` lcl_env
 
-                 dot_dot_gres = [ (lbl, sel, head gres)
+                 (dot_dot_fields, dot_dot_gres)
+                        = unzip [ (fl, gre)
                                 | fl <- con_fields
-                                , let lbl = flLabel fl
-                                , let sel = flSelector fl
-                                , not (lbl `elem` present_flds)
-                                , let gres = lookupGRE_Field_Name rdr_env sel lbl
-                                , not (null gres)  -- Check selector is in scope
+                                , let lbl = mkVarOccFS (flLabel fl)
+                                , not (lbl `elemOccSet` present_flds)
+                                , Just gre <- [lookupGRE_FieldLabel rdr_env fl]
+                                              -- Check selector is in scope
                                 , case ctxt of
                                     HsRecFieldCon {} -> arg_in_scope lbl
                                     _other           -> True ]
 
-           ; addUsedGREs (map thdOf3 dot_dot_gres)
+           ; addUsedGREs dot_dot_gres
            ; return [ L loc (HsRecField
                         { hsRecFieldLbl = L loc (FieldOcc (L loc arg_rdr) sel)
                         , hsRecFieldArg = L loc (mk_arg loc arg_rdr)
                         , hsRecPun      = False })
-                    | (lbl, sel, _) <- dot_dot_gres
-                    , let arg_rdr = mkVarUnqual lbl ] }
+                    | fl <- dot_dot_fields
+                    , let sel     = flSelector fl
+                    , let arg_rdr = mkVarUnqual (flLabel fl) ] }
 
     check_disambiguation :: Bool -> Maybe Name -> RnM (Maybe Name)
     -- When disambiguation is on, return name of parent tycon.
diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs
index c12fd9a..2de2223 100644
--- a/compiler/typecheck/TcEvidence.hs
+++ b/compiler/typecheck/TcEvidence.hs
@@ -482,6 +482,11 @@ data EvTerm
 
   | EvTypeable Type EvTypeable   -- Dictionary for (Typeable ty)
 
+  | EvSelector Id [Type] [EvTerm] -- Selector id plus the types at which it
+                                  -- should be instantiated, used for HasField
+                                  -- dictionaries; see Note [HasField instances]
+                                  -- in TcInterface
+
   deriving Data.Data
 
 
@@ -784,6 +789,7 @@ evVarsOfTerm (EvDelayedError _ _) = emptyVarSet
 evVarsOfTerm (EvLit _)            = emptyVarSet
 evVarsOfTerm (EvCallStack cs)     = evVarsOfCallStack cs
 evVarsOfTerm (EvTypeable _ ev)    = evVarsOfTypeable ev
+evVarsOfTerm (EvSelector _ _ evs) = mapUnionVarSet evVarsOfTerm evs
 
 evVarsOfTerms :: [EvTerm] -> VarSet
 evVarsOfTerms = mapUnionVarSet evVarsOfTerm
@@ -889,6 +895,7 @@ instance Outputable EvTerm where
   ppr (EvDelayedError ty msg) =     text "error"
                                 <+> sep [ char '@' <> ppr ty, ppr msg ]
   ppr (EvTypeable ty ev)      = ppr ev <+> dcolon <+> text "Typeable" <+> ppr ty
+  ppr (EvSelector sel tys ts) = ppr sel <+> sep [ char '@' <> ppr tys, ppr ts]
 
 instance Outputable EvLit where
   ppr (EvNum n) = integer n
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index b2d7545..18d8df0 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -60,7 +60,6 @@ import TysWiredIn
 import TysPrim( intPrimTy )
 import PrimOp( tagToEnumKey )
 import PrelNames
-import MkId ( proxyHashId )
 import DynFlags
 import SrcLoc
 import Util
@@ -216,21 +215,28 @@ tcExpr e@(HsIPVar x) res_ty
                           unwrapIP $ mkClassPred ipClass [x,ty]
   origin = IPOccOrigin x
 
-tcExpr e@(HsOverLabel l) res_ty  -- See Note [Type-checking overloaded labels]
-  = do { isLabelClass <- tcLookupClass isLabelClassName
-       ; alpha <- newOpenFlexiTyVarTy
-       ; let lbl = mkStrLitTy l
-             pred = mkClassPred isLabelClass [lbl, alpha]
-       ; loc <- getSrcSpanM
-       ; var <- emitWantedEvVar origin pred
-       ; let proxy_arg = L loc (mkHsWrap (mkWpTyApps [typeSymbolKind, lbl])
-                                         (HsVar (L loc proxyHashId)))
-             tm = L loc (fromDict pred (HsVar (L loc var))) `HsApp` proxy_arg
-       ; tcWrapResult e tm alpha res_ty }
+tcExpr e@(HsOverLabel mb_fromLabel l) res_ty
+  = do { -- See Note [Type-checking overloaded labels]
+         loc <- getSrcSpanM
+       ; case mb_fromLabel of
+           Just fromLabel -> tcExpr (applyFromLabel loc fromLabel) res_ty
+           Nothing -> do { isLabelClass <- tcLookupClass isLabelClassName
+                         ; alpha <- newFlexiTyVarTy liftedTypeKind
+                         ; let pred = mkClassPred isLabelClass [lbl, alpha]
+                         ; loc <- getSrcSpanM
+                         ; var <- emitWantedEvVar origin pred
+                         ; tcWrapResult e (fromDict pred (HsVar (L loc var)))
+                                        alpha res_ty } }
   where
-  -- Coerces a dictionary for `IsLabel "x" t` into `Proxy# x -> t`.
+  -- Coerces a dictionary for `IsLabel "x" t` into `t`,
+  -- or `HasField "x" r a into `r -> a`.
   fromDict pred = HsWrap $ mkWpCastR $ unwrapIP pred
   origin = OverLabelOrigin l
+  lbl = mkStrLitTy l
+
+  applyFromLabel loc fromLabel =
+    L loc (HsVar (L loc fromLabel)) `HsAppType`
+      mkEmptyWildCardBndrs (L loc (HsTyLit (HsStrTy NoSourceText l)))
 
 tcExpr (HsLam match) res_ty
   = do  { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty
@@ -265,19 +271,27 @@ tcExpr e@(ExprWithTySig expr sig_ty) res_ty
 {-
 Note [Type-checking overloaded labels]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Recall that (in GHC.OverloadedLabels) we have
+Recall that we have
 
+  module GHC.OverloadedLabels where
     class IsLabel (x :: Symbol) a where
-      fromLabel :: Proxy# x -> a
+      fromLabel :: a
+
+We translate `#foo` to `fromLabel @"foo"`, where we use
+
+ * the in-scope `fromLabel` if `RebindableSyntax` is enabled; or if not
+ * `GHC.OverloadedLabels.fromLabel`.
+
+In the `RebindableSyntax` case, the renamer will have filled in the
+first field of `HsOverLabel` with the `fromLabel` function to use, and
+we simply apply it to the appropriate visible type argument.
 
-When we see an overloaded label like `#foo`, we generate a fresh
-variable `alpha` for the type and emit an `IsLabel "foo" alpha`
-constraint.  Because the `IsLabel` class has a single method, it is
-represented by a newtype, so we can coerce `IsLabel "foo" alpha` to
-`Proxy# "foo" -> alpha` (just like for implicit parameters).  We then
-apply it to `proxy#` of type `Proxy# "foo"`.
+In the `OverloadedLabels` case, when we see an overloaded label like
+`#foo`, we generate a fresh variable `alpha` for the type and emit an
+`IsLabel "foo" alpha` constraint.  Because the `IsLabel` class has a
+single method, it is represented by a newtype, so we can coerce
+`IsLabel "foo" alpha` to `alpha` (just like for implicit parameters).
 
-That is, we translate `#foo` to `fromLabel (proxy# :: Proxy# "foo")`.
 -}
 
 
diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs
index 581795e..6061ecc 100644
--- a/compiler/typecheck/TcHsSyn.hs
+++ b/compiler/typecheck/TcHsSyn.hs
@@ -623,8 +623,7 @@ zonkExpr _ e@(HsConLikeOut {}) = return e
 zonkExpr _ (HsIPVar id)
   = return (HsIPVar id)
 
-zonkExpr _ (HsOverLabel l)
-  = return (HsOverLabel l)
+zonkExpr _ e@HsOverLabel{} = return e
 
 zonkExpr env (HsLit (HsRat f ty))
   = do new_ty <- zonkTcTypeToType env ty
@@ -1445,6 +1444,11 @@ zonkEvTerm env (EvDFunApp df tys tms)
 zonkEvTerm env (EvDelayedError ty msg)
   = do { ty' <- zonkTcTypeToType env ty
        ; return (EvDelayedError ty' msg) }
+zonkEvTerm env (EvSelector sel_id tys tms)
+  = do { sel_id' <- zonkIdBndr env sel_id
+       ; tys'    <- zonkTcTypeToTypes env tys
+       ; tms' <- mapM (zonkEvTerm env) tms
+       ; return (EvSelector sel_id' tys' tms') }
 
 zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable
 zonkEvTypeable env (EvTypeableTyCon ts)
diff --git a/compiler/typecheck/TcInteract.hs b/compiler/typecheck/TcInteract.hs
index e8ac6e9..e01bd64 100644
--- a/compiler/typecheck/TcInteract.hs
+++ b/compiler/typecheck/TcInteract.hs
@@ -20,20 +20,25 @@ import Type
 import InstEnv( DFunInstType, lookupInstEnv, instanceDFunId )
 import CoAxiom( sfInteractTop, sfInteractInert )
 
+import TcMType (newMetaTyVars)
+
 import Var
 import TcType
 import Name
+import RdrName ( lookupGRE_FieldLabel )
 import PrelNames ( knownNatClassName, knownSymbolClassName,
                    typeableClassName, coercibleTyConKey,
+                   hasFieldClassName,
                    heqTyConKey, ipClassKey )
 import TysWiredIn ( typeNatKind, typeSymbolKind, heqDataCon,
                     coercibleDataCon )
 import TysPrim    ( eqPrimTyCon, eqReprPrimTyCon )
-import Id( idType )
+import Id( idType, isNaughtyRecordSelector )
 import CoAxiom ( TypeEqn, CoAxiom(..), CoAxBranch(..), fromBranches )
 import Class
 import TyCon
 import DataCon( dataConWrapId )
+import FieldLabel
 import FunDeps
 import FamInst
 import FamInstEnv
@@ -2185,6 +2190,7 @@ match_class_inst dflags clas tys loc
   | cls_name == typeableClassName     = matchTypeable        clas tys
   | clas `hasKey` heqTyConKey         = matchLiftedEquality       tys
   | clas `hasKey` coercibleTyConKey   = matchLiftedCoercible      tys
+  | cls_name == hasFieldClassName     = matchHasField dflags clas tys loc
   | otherwise                         = matchInstEnv dflags clas tys loc
   where
     cls_name = className clas
@@ -2522,3 +2528,122 @@ matchLiftedCoercible args@[k, t1, t2]
   where
     args' = [k, k, t1, t2]
 matchLiftedCoercible args = pprPanic "matchLiftedCoercible" (ppr args)
+
+
+{- ********************************************************************
+*                                                                     *
+              Class lookup for overloaded record fields
+*                                                                     *
+***********************************************************************-}
+
+{-
+Note [HasField instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we have
+
+    data T y = MkT { foo :: [y] }
+
+and `foo` is in scope.  Then GHC will automatically solve a constraint like
+
+    HasField "foo" (T Int) b
+
+by emitting a new wanted
+
+    T alpha -> [alpha] ~# T Int -> b
+
+and building a HasField dictionary out of the selector function `foo`,
+appropriately cast.
+
+The HasField class is defined (in GHC.Records) thus:
+
+    class HasField (x :: k) r a | x r -> a where
+      getField :: r -> a
+
+Since this is a one-method class, it is represented as a newtype.
+Hence we can solve `HasField "foo" (T Int) b` by taking an expression
+of type `T Int -> b` and casting it using the newtype coercion.
+Note that
+
+    foo :: forall y . T y -> [y]
+
+so the expression we construct is
+
+    foo @alpha |> co
+
+where
+
+    co :: (T alpha -> [alpha]) ~# HasField "foo" (T Int) b
+
+is built from
+
+    co1 :: (T alpha -> [alpha]) ~# (T Int -> b)
+
+which is the new wanted, and
+
+    co2 :: (T Int -> b) ~# HasField "foo" (T Int) b
+
+which can be derived from the newtype coercion.
+
+If `foo` is not in scope, or has a higher-rank or existentially
+quantified type, then the constraint is not solved automatically, but
+may be solved by a user-supplied HasField instance.  Similarly, if we
+encounter a HasField constraint where the field is not a literal
+string, or does not belong to the type, then we fall back on the
+normal constraint solver behaviour.
+-}
+
+-- See Note [HasField instances]
+matchHasField :: DynFlags -> Class -> [Type] -> CtLoc -> TcS LookupInstResult
+matchHasField dflags clas tys loc
+  = do { fam_inst_envs <- getFamInstEnvs
+       ; rdr_env       <- getGlobalRdrEnvTcS
+       ; case tys of
+           -- We are matching HasField {k} x r a...
+           [_k_ty, x_ty, r_ty, a_ty]
+               -- x should be a literal string
+             | Just x <- isStrLitTy x_ty
+               -- r should be an applied type constructor
+             , Just (tc, args) <- tcSplitTyConApp_maybe r_ty
+               -- use representation tycon (if data family); it has the fields
+             , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args)
+               -- x should be a field of r
+             , Just fl <- lookupTyConFieldLabel x r_tc
+               -- the field selector should be in scope
+             , Just gre <- lookupGRE_FieldLabel rdr_env fl
+
+             -> do { sel_id <- tcLookupId (flSelector fl)
+                   ; (tv_prs, preds, sel_ty) <- tcInstType newMetaTyVars sel_id
+
+                         -- The first new wanted constraint equates the actual
+                         -- type of the selector with the type (r -> a) within
+                         -- the HasField x r a dictionary.  The preds will
+                         -- typically be empty, but if the datatype has a
+                         -- "stupid theta" then we have to include it here.
+                   ; let theta = mkPrimEqPred sel_ty (mkFunTy r_ty a_ty) : preds
+
+                         -- Use the equality proof to cast the selector Id to
+                         -- type (r -> a), then use the newtype coercion to cast
+                         -- it to a HasField dictionary.
+                         mk_ev (ev1:evs) = EvSelector sel_id tvs evs `EvCast` co
+                           where
+                             co = mkTcSubCo (evTermCoercion ev1)
+                                      `mkTcTransCo` mkTcSymCo co2
+                         mk_ev [] = panic "matchHasField.mk_ev"
+
+                         Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas)
+                                                              tys
+
+                         tvs = mkTyVarTys (map snd tv_prs)
+
+                     -- The selector must not be "naughty" (i.e. the field
+                     -- cannot have an existentially quantified type), and
+                     -- it must not be higher-rank.
+                   ; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty
+                     then do { addUsedGRE True gre
+                             ; return GenInst { lir_new_theta = theta
+                                              , lir_mk_ev     = mk_ev
+                                              , lir_safe_over = True
+                                              } }
+                     else matchInstEnv dflags clas tys loc }
+
+           _ -> matchInstEnv dflags clas tys loc }
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 31c6dae..c01118b 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -3102,7 +3102,7 @@ exprCtOrigin (HsVar (L _ name)) = OccurrenceOf name
 exprCtOrigin (HsUnboundVar uv)  = UnboundOccurrenceOf (unboundVarOcc uv)
 exprCtOrigin (HsConLikeOut {})  = panic "exprCtOrigin HsConLikeOut"
 exprCtOrigin (HsRecFld f)       = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f)
-exprCtOrigin (HsOverLabel l)    = OverLabelOrigin l
+exprCtOrigin (HsOverLabel _ l)  = OverLabelOrigin l
 exprCtOrigin (HsIPVar ip)       = IPOccOrigin ip
 exprCtOrigin (HsOverLit lit)    = LiteralOrigin lit
 exprCtOrigin (HsLit {})         = Shouldn'tHappenOrigin "concrete literal"
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index dcca49c..14cb9f2 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -18,7 +18,7 @@ module TcSMonad (
     runTcSEqualities,
     nestTcS, nestImplicTcS, setEvBindsTcS,
 
-    runTcPluginTcS, addUsedGREs, deferTcSForAllEq,
+    runTcPluginTcS, addUsedGRE, addUsedGREs, deferTcSForAllEq,
 
     -- Tracing etc
     panicTcS, traceTcS,
@@ -44,6 +44,7 @@ module TcSMonad (
     getTcEvBindsVar, getTcLevel,
     getTcEvBindsAndTCVs, getTcEvBindsMap,
     tcLookupClass,
+    tcLookupId,
 
     -- Inerts
     InertSet(..), InertCans(..),
@@ -92,6 +93,7 @@ module TcSMonad (
     -- MetaTyVars
     newFlexiTcSTy, instFlexi, instFlexiX,
     cloneMetaTyVar, demoteUnfilledFmv,
+    tcInstType,
 
     TcLevel, isTouchableMetaTyVarTcS,
     isFilledMetaTyVar_maybe, isFilledMetaTyVar,
@@ -125,7 +127,7 @@ import FamInstEnv
 import qualified TcRnMonad as TcM
 import qualified TcMType as TcM
 import qualified TcEnv as TcM
-       ( checkWellStaged, topIdLvl, tcGetDefaultTys, tcLookupClass )
+       ( checkWellStaged, topIdLvl, tcGetDefaultTys, tcLookupClass, tcLookupId )
 import PrelNames( heqTyConKey, eqTyConKey )
 import Kind
 import TcType
@@ -2649,12 +2651,19 @@ getLclEnv = wrapTcS $ TcM.getLclEnv
 tcLookupClass :: Name -> TcS Class
 tcLookupClass c = wrapTcS $ TcM.tcLookupClass c
 
+tcLookupId :: Name -> TcS Id
+tcLookupId n = wrapTcS $ TcM.tcLookupId n
+
 -- Setting names as used (used in the deriving of Coercible evidence)
 -- Too hackish to expose it to TcS? In that case somehow extract the used
 -- constructors from the result of solveInteract
 addUsedGREs :: [GlobalRdrElt] -> TcS ()
 addUsedGREs gres = wrapTcS  $ TcM.addUsedGREs gres
 
+addUsedGRE :: Bool -> GlobalRdrElt -> TcS ()
+addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre
+
+
 -- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -2843,6 +2852,14 @@ instFlexiHelper subst tv
              ty'  = mkTyVarTy (mkTcTyVar name kind details)
        ; return (extendTvSubst subst tv ty') }
 
+tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar]))
+                   -- ^ How to instantiate the type variables
+           -> Id   -- ^ Type to instantiate
+           -> TcS ([(Name, TcTyVar)], TcThetaType, TcType) -- ^ Result
+                -- (type vars, preds (incl equalities), rho)
+tcInstType inst_tyvars id = wrapTcS (TcM.tcInstType inst_tyvars id)
+
+
 
 -- Creating and setting evidence variables and CtFlavors
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs
index c2f5d4e..fb6bb60 100644
--- a/compiler/typecheck/TcValidity.hs
+++ b/compiler/typecheck/TcValidity.hs
@@ -1017,6 +1017,9 @@ checkValidInstHead ctxt clas cls_args
                   nameModule (getName clas) == mod)
                  (instTypeErr clas cls_args abstract_class_msg)
 
+       ; when (clas `hasKey` hasFieldClassNameKey) $
+             checkHasFieldInst clas cls_args
+
            -- Check language restrictions;
            -- but not for SPECIALISE instance pragmas
        ; let ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args
@@ -1109,6 +1112,27 @@ instTypeErr cls tys msg
              2 (quotes (pprClassPred cls tys)))
        2 msg
 
+-- | See Note [Validity checking of HasField instances]
+checkHasFieldInst :: Class -> [Type] -> TcM ()
+checkHasFieldInst cls tys@[_k_ty, x_ty, r_ty, _a_ty] =
+  case splitTyConApp_maybe r_ty of
+    Nothing -> whoops (text "Record data type must be specified")
+    Just (tc, _)
+      | isFamilyTyCon tc
+                  -> whoops (text "Record data type may not be a data family")
+      | otherwise -> case isStrLitTy x_ty of
+       Just lbl
+         | isJust (lookupTyConFieldLabel lbl tc)
+                     -> whoops (ppr tc <+> text "already has a field"
+                                       <+> quotes (ppr lbl))
+         | otherwise -> return ()
+       Nothing
+         | null (tyConFieldLabels tc) -> return ()
+         | otherwise -> whoops (ppr tc <+> text "has fields")
+  where
+    whoops = addErrTc . instTypeErr cls tys
+checkHasFieldInst _ tys = pprPanic "checkHasFieldInst" (ppr tys)
+
 {- Note [Casts during validity checking]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider the (bogus)
@@ -1124,6 +1148,26 @@ the middle:
    Eq ((Either |> g) a)
 
 
+Note [Validity checking of HasField instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The HasField class has magic constraint solving behaviour (see Note
+[HasField instances] in TcInteract).  However, we permit users to
+declare their own instances, provided they do not clash with the
+built-in behaviour.  In particular, we forbid:
+
+  1. `HasField _ r _` where r is a variable
+
+  2. `HasField _ (T ...) _` if T is a data family
+     (because it might have fields introduced later)
+
+  3. `HasField x (T ...) _` where x is a variable,
+      if T has any fields at all
+
+  4. `HasField "foo" (T ...) _` if T has a "foo" field
+
+The usual functional dependency checks also apply.
+
+
 Note [Valid 'deriving' predicate]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 validDerivPred checks for OK 'deriving' context.  See Note [Exotic
diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs
index 45efb48..3aa2805 100644
--- a/compiler/types/TyCon.hs
+++ b/compiler/types/TyCon.hs
@@ -23,7 +23,7 @@ module TyCon(
         isVisibleTyConBinder, isInvisibleTyConBinder,
 
         -- ** Field labels
-        tyConFieldLabels, tyConFieldLabelEnv,
+        tyConFieldLabels, lookupTyConFieldLabel,
 
         -- ** Constructing TyCons
         mkAlgTyCon,
@@ -1362,6 +1362,9 @@ tyConFieldLabelEnv tc
   | isAlgTyCon tc = algTcFields tc
   | otherwise     = emptyDFsEnv
 
+-- | Look up a field label belonging to this 'TyCon'
+lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel
+lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) lbl
 
 -- | Make a map from strings to FieldLabels from all the data
 -- constructors of this algebraic tycon
diff --git a/compiler/utils/FastStringEnv.hs b/compiler/utils/FastStringEnv.hs
index a3336ae..14b0859 100644
--- a/compiler/utils/FastStringEnv.hs
+++ b/compiler/utils/FastStringEnv.hs
@@ -24,7 +24,7 @@ module FastStringEnv (
         DFastStringEnv,
 
         -- ** Manipulating these environments
-        mkDFsEnv, emptyDFsEnv, dFsEnvElts,
+        mkDFsEnv, emptyDFsEnv, dFsEnvElts, lookupDFsEnv
     ) where
 
 import UniqFM
@@ -93,3 +93,6 @@ dFsEnvElts = eltsUDFM
 
 mkDFsEnv :: [(FastString,a)] -> DFastStringEnv a
 mkDFsEnv l = listToUDFM l
+
+lookupDFsEnv :: DFastStringEnv a -> FastString -> Maybe a
+lookupDFsEnv = lookupUDFM
diff --git a/libraries/base/GHC/OverloadedLabels.hs b/libraries/base/GHC/OverloadedLabels.hs
index f4a76cf..7e27cf6 100644
--- a/libraries/base/GHC/OverloadedLabels.hs
+++ b/libraries/base/GHC/OverloadedLabels.hs
@@ -1,48 +1,54 @@
-{-# LANGUAGE NoImplicitPrelude
-           , MultiParamTypeClasses
-           , MagicHash
-           , KindSignatures
+{-# LANGUAGE AllowAmbiguousTypes
            , DataKinds
+           , FlexibleInstances
+           , KindSignatures
+           , MultiParamTypeClasses
+           , ScopedTypeVariables
+           , TypeApplications
   #-}
 
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.OverloadedLabels
--- Copyright   :  (c) Adam Gundry 2015
+-- Copyright   :  (c) Adam Gundry 2015-2016
 -- License     :  see libraries/base/LICENSE
 --
 -- Maintainer  :  cvs-ghc@haskell.org
 -- Stability   :  internal
 -- Portability :  non-portable (GHC extensions)
 --
--- This module defines the `IsLabel` class is used by the
--- OverloadedLabels extension.  See the
+-- This module defines the 'IsLabel' class is used by the
+-- @OverloadedLabels@ extension.  See the
 -- <https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/OverloadedLabels wiki page>
 -- for more details.
 --
--- The key idea is that when GHC sees an occurrence of the new
--- overloaded label syntax @#foo@, it is replaced with
+-- When @OverloadedLabels@ is enabled, if GHC sees an occurrence of
+-- the overloaded label syntax @#foo@, it is replaced with
 --
--- > fromLabel (proxy# :: Proxy# "foo") :: alpha
+-- > fromLabel @"foo" :: alpha
 --
 -- plus a wanted constraint @IsLabel "foo" alpha@.
 --
+-- Note that if @RebindableSyntax@ is enabled, the desugaring of
+-- overloaded label syntax will make use of whatever @fromLabel@ is in
+-- scope.
+--
 -----------------------------------------------------------------------------
 
 -- Note [Overloaded labels]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~
 -- An overloaded label is represented by the 'HsOverLabel' constructor
--- of 'HsExpr', which stores a 'FastString'.  It is passed through
--- unchanged by the renamer, and the type-checker transforms it into a
--- call to 'fromLabel'.  See Note [Type-checking overloaded labels] in
--- TcExpr for more details in how type-checking works.
+-- of 'HsExpr', which stores the 'FastString' text of the label and an
+-- optional id for the 'fromLabel' function to use (if
+-- RebindableSyntax is enabled) .  The type-checker transforms it into
+-- a call to 'fromLabel'.  See Note [Type-checking overloaded labels]
+-- in TcExpr for more details in how type-checking works.
 
 module GHC.OverloadedLabels
        ( IsLabel(..)
        ) where
 
 import GHC.Base ( Symbol )
-import GHC.Exts ( Proxy# )
 
 class IsLabel (x :: Symbol) a where
-  fromLabel :: Proxy# x -> a
+  fromLabel :: a
diff --git a/libraries/base/GHC/Records.hs b/libraries/base/GHC/Records.hs
new file mode 100644
index 0000000..43c3931
--- /dev/null
+++ b/libraries/base/GHC/Records.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE AllowAmbiguousTypes
+           , FunctionalDependencies
+           , KindSignatures
+           , MultiParamTypeClasses
+           , PolyKinds
+  #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.Records
+-- Copyright   :  (c) Adam Gundry 2015-2016
+-- License     :  see libraries/base/LICENSE
+--
+-- Maintainer  :  cvs-ghc@haskell.org
+-- Stability   :  internal
+-- Portability :  non-portable (GHC extensions)
+--
+-- This module defines the 'HasField' class used by the
+-- @OverloadedRecordFields@ extension.  See the
+-- <https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields
+-- wiki page> for more details.
+--
+-----------------------------------------------------------------------------
+
+module GHC.Records
+       ( HasField(..)
+       ) where
+
+-- | Constraint representing the fact that the field @x@ belongs to
+-- the record type @r@ and has field type @a@.  This will be solved
+-- automatically, but manual instances may be provided as well.
+class HasField (x :: k) r a | x r -> a where
+  -- | Selector function to extract the field from the record.
+  getField :: r -> a
diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal
index 691dc83..49e23e5 100644
--- a/libraries/base/base.cabal
+++ b/libraries/base/base.cabal
@@ -264,6 +264,7 @@ Library
         GHC.Ptr
         GHC.Read
         GHC.Real
+        GHC.Records
         GHC.RTS.Flags
         GHC.ST
         GHC.StaticPtr
diff --git a/testsuite/driver/extra_files.py b/testsuite/driver/extra_files.py
index a6b04dd..28192c1 100644
--- a/testsuite/driver/extra_files.py
+++ b/testsuite/driver/extra_files.py
@@ -418,6 +418,7 @@ extra_src_files = {
   'overloadedrecfldsfail11': ['OverloadedRecFldsFail11_A.hs'],
   'overloadedrecfldsfail12': ['OverloadedRecFldsFail12_A.hs'],
   'overloadedrecfldsrun02': ['OverloadedRecFldsRun02_A.hs'],
+  'hasfieldfail01': ['HasFieldFail01_A.hs'],
   'p10': ['D.hs'],
   'p11': ['E.hs'],
   'p13': ['P13_A.hs'],
diff --git a/testsuite/tests/overloadedrecflds/ghci/all.T b/testsuite/tests/overloadedrecflds/ghci/all.T
index c67d42f..6a95bb2 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 2aa0a15..2aa0a15 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 3270089..3270089 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 3b5dde1..7bbee54 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 0000000..f7dc113
--- /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 f036ad0..98f16a0 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 0000000..d949074
--- /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 0000000..f2d5586
--- /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 0000000..6eb9870
--- /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 0000000..2b90a1a
--- /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 0000000..93117ee
--- /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 0000000..71192b2
--- /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 361da45..ed68685 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 f938d03..4cd5231 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 0000000..d2d0f16
--- /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 0000000..f47240f
--- /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 0000000..8670986
--- /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 0000000..69aa43a
--- /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 e3b38c2..8c3b992 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 0000000..62e8f4e
--- /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 0000000..965dccf
--- /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 ad70a09..bfd77d3 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 0000000..eb301ba
--- /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 0000000..529b96b
--- /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 0000000..5bfddbb
--- /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 0000000..abc4e3b
--- /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 45c7854..972932c 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 eea8f36..94f8d0c 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 a854d7a..f84a380 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 0000000..25da616
--- /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 0000000..1bfbe7a
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun07.stdout
@@ -0,0 +1,3 @@
+42
+True
+'x'