ghc: implement OverloadedRecordFieldswip/orf

This fully implements the new ORF extension, developed during the Google
Summer of Code 2013, and as described on the wiki:

  https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields

This also updates the Haddock submodule.

Reviewed-by: Simon Peyton Jones <simonpj@microsoft.com>
Signed-off-by: Austin Seipp <austin@well-typed.com>

22 files changed, 1068 insertions, 218 deletions

diff --git a/compiler/typecheck/FamInst.lhs b/compiler/typecheck/FamInst.lhs
index 572874b875..d7f56b29fe 100644
--- a/compiler/typecheck/FamInst.lhs
+++ b/compiler/typecheck/FamInst.lhs
@@ -11,7 +11,7 @@ The @FamInst@ type: family instance heads
 
 module FamInst ( 
         checkFamInstConsistency, tcExtendLocalFamInstEnv,
-	tcLookupFamInst, 
+        tcLookupFamInst, lookupRepTyCon,
         tcGetFamInstEnvs,
         newFamInst
     ) where
@@ -21,8 +21,9 @@ import FamInstEnv
 import InstEnv( roughMatchTcs )
 import Coercion( pprCoAxBranchHdr )
 import LoadIface
-import TypeRep
+import Type
 import TcRnMonad
+import Unify
 import TyCon
 import CoAxiom
 import DynFlags
@@ -35,7 +36,9 @@ import Maybes
 import TcMType
 import TcType
 import Name
+import RnEnv
 import VarSet
+import PrelNames
 import Control.Monad
 import Data.Map (Map)
 import qualified Data.Map as Map
@@ -211,10 +214,15 @@ which implies that :R42T was declared as 'data instance T [a]'.
 
 \begin{code}
 tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe FamInstMatch)
-tcLookupFamInst tycon tys
+tcLookupFamInst tycon _
   | not (isOpenFamilyTyCon tycon)
   = return Nothing
-  | otherwise
+
+tcLookupFamInst fam tys
+  | isRecordsFam fam
+  = tcLookupRecordsFamInst fam tys
+
+tcLookupFamInst tycon tys
   = do { instEnv <- tcGetFamInstEnvs
        ; let mb_match = lookupFamInstEnv instEnv tycon tys 
        ; traceTc "lookupFamInst" ((ppr tycon <+> ppr tys) $$ 
@@ -225,9 +233,45 @@ tcLookupFamInst tycon tys
 	   (match:_) 
               -> return $ Just match
        }
+
+
+-- See Note [Instance scoping for OverloadedRecordFields] in TcFldInsts
+-- and the section on "Looking up record field instances" in RnEnv
+tcLookupRecordsFamInst :: TyCon -> [Type] -> TcM (Maybe FamInstMatch)
+tcLookupRecordsFamInst fam tys
+  | Just (lbl, tc, args) <- tcSplitRecordsArgs tys
+  = do { rep_tc <- lookupRepTyCon tc args
+       ; mb_ax  <- lookupFldInstAxiom lbl tc rep_tc want_get
+       ; return $ do { ax <- mb_ax
+                     ; let fam_inst = fam_inst_for tc ax
+                     ; subst <- tcMatchTys (mkVarSet (fi_tvs fam_inst)) (fi_tys fam_inst) tys
+                     ; return $ FamInstMatch fam_inst (substTyVars subst (fi_tvs fam_inst)) } }
+  where
+    want_get = isFldTyFam fam
+
+    fam_inst_for tc axiom
+      | want_get  = mkImportedFamInst fldTyFamName
+                        [Nothing, Just (tyConName tc)] (toUnbranchedAxiom axiom)
+      | otherwise = mkImportedFamInst updTyFamName
+                        [Nothing, Just (tyConName tc), Nothing] (toUnbranchedAxiom axiom)
+
+tcLookupRecordsFamInst _ _ = return Nothing
+
+lookupRepTyCon :: TyCon -> [Type] -> TcM TyCon
+-- Lookup the representation tycon given a family tycon and its
+-- arguments; returns the original tycon if it is not a data family or
+-- it doesn't have a matching instance.
+lookupRepTyCon tc args
+  | isDataFamilyTyCon tc
+      = do { mb_fi <- tcLookupFamInst tc args
+           ; return $ case mb_fi of
+                        Nothing  -> tc
+                        Just fim -> tcTyConAppTyCon (fi_rhs (fim_instance fim)) }
+  | otherwise = return tc
 \end{code}
 
 
+
 %************************************************************************
 %*									*
 	Extending the family instance environment
@@ -333,4 +377,3 @@ tcGetFamInstEnvs
   = do { eps <- getEps; env <- getGblEnv
        ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) }
 \end{code}
-
diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index e934984383..fe9df456e0 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -21,7 +21,8 @@ module Inst (
        newOverloadedLit, mkOverLit, 
      
        tcGetInsts, tcGetInstEnvs, getOverlapFlag,
-       tcExtendLocalInstEnv, instCallConstraints, newMethodFromName,
+       tcExtendLocalInstEnv,
+       instCallConstraints, newMethodFromName,
        tcSyntaxName,
 
        -- Simple functions over evidence variables
diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index f3d754640f..f8857149ca 100644
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -16,11 +16,11 @@ module TcEnv(
         tcExtendGlobalEnv, tcExtendGlobalEnvImplicit, setGlobalTypeEnv,
         tcExtendGlobalValEnv,
         tcLookupLocatedGlobal, tcLookupGlobal, 
-        tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
+        tcLookupTyCon, tcLookupClass, tcLookupDataCon,
         tcLookupConLike,
         tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
         tcLookupLocatedClass, tcLookupInstance, tcLookupAxiom,
-        
+
         -- Local environment
         tcExtendKindEnv, tcExtendKindEnv2,
         tcExtendTyVarEnv, tcExtendTyVarEnv2, 
@@ -50,7 +50,9 @@ module TcEnv(
         topIdLvl, isBrackStage,
 
         -- New Ids
-        newLocalName, newDFunName, newFamInstTyConName, newFamInstAxiomName,
+        newLocalName, newDFunName, newDFunName',
+        newFamInstTyConName, newFamInstTyConName',
+        newFamInstAxiomName, newFamInstAxiomName',
         mkStableIdFromString, mkStableIdFromName,
         mkWrapperName
   ) where
@@ -134,22 +136,6 @@ tcLookupGlobal name
             Failed msg      -> failWithTc msg
         }}}
 
-tcLookupField :: Name -> TcM Id         -- Returns the selector Id
-tcLookupField name
-  = tcLookupId name     -- Note [Record field lookup]
-
-{- Note [Record field lookup]
-   ~~~~~~~~~~~~~~~~~~~~~~~~~~
-You might think we should have tcLookupGlobal here, since record fields
-are always top level.  But consider
-        f = e { f = True }
-Then the renamer (which does not keep track of what is a record selector
-and what is not) will rename the definition thus
-        f_7 = e { f_7 = True }
-Now the type checker will find f_7 in the *local* type environment, not
-the global (imported) one. It's wrong, of course, but we want to report a tidy
-error, not in TcEnv.notFound.  -}
-
 tcLookupDataCon :: Name -> TcM DataCon
 tcLookupDataCon name = do
     thing <- tcLookupGlobal name
@@ -754,11 +740,14 @@ name, like otber top-level names, and hence must be made with newGlobalBinder.
 
 \begin{code}
 newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
-newDFunName clas tys loc
+newDFunName clas tys = newDFunName' info_string
+  where info_string = occNameString (getOccName clas) ++
+                            concatMap (occNameString.getDFunTyKey) tys
+
+newDFunName' :: String -> SrcSpan -> TcM Name
+newDFunName' info_string loc
   = do  { is_boot <- tcIsHsBoot
         ; mod     <- getModule
-        ; let info_string = occNameString (getOccName clas) ++ 
-                            concatMap (occNameString.getDFunTyKey) tys
         ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)
         ; newGlobalBinder mod dfun_occ loc }
 \end{code}
@@ -771,19 +760,33 @@ newGlobalBinder.
 newFamInstTyConName :: Located Name -> [Type] -> TcM Name
 newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys]
 
+newFamInstTyConName' :: Located Name -> [LHsType RdrName] -> TcM Name
+newFamInstTyConName' (L loc name) tys
+  = mk_fam_inst_name' id loc info_string
+  where
+    info_string = occNameString (getOccName name)
+                      ++ concatMap (getDFunHsTypeKey . unLoc) tys
+
 newFamInstAxiomName :: SrcSpan -> Name -> [CoAxBranch] -> TcM Name
 newFamInstAxiomName loc name branches
   = mk_fam_inst_name mkInstTyCoOcc loc name (map coAxBranchLHS branches)
 
+newFamInstAxiomName' :: SrcSpan -> String -> TcM Name
+newFamInstAxiomName' loc info_string
+  = mk_fam_inst_name' mkInstTyCoOcc loc info_string
+
 mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name
 mk_fam_inst_name adaptOcc loc tc_name tyss
-  = do  { mod   <- getModule
-        ; let info_string = occNameString (getOccName tc_name) ++ 
-                            intercalate "|" ty_strings
-        ; occ   <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
-        ; newGlobalBinder mod (adaptOcc occ) loc }
+  = mk_fam_inst_name' adaptOcc loc info_string
   where
-    ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss
+    info_string = occNameString (getOccName tc_name) ++ intercalate "|" ty_strings
+    ty_strings  = map (concatMap (occNameString . getDFunTyKey)) tyss
+
+mk_fam_inst_name' :: (OccName -> OccName) -> SrcSpan -> String -> TcM Name
+mk_fam_inst_name' adaptOcc loc info_string
+  = do  { mod <- getModule
+        ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
+        ; newGlobalBinder mod (adaptOcc occ) loc }
 \end{code}
 
 Stable names used for foreign exports and annotations.
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 3ca1319a9d..48d7c618b7 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -18,8 +18,10 @@ module TcErrors(
 
 import TcRnTypes
 import TcRnMonad
+import FamInst
 import TcMType
 import TcType
+import TcEnv
 import TypeRep
 import Type
 import Kind ( isKind )
@@ -31,6 +33,7 @@ import TyCon
 import DataCon
 import TcEvidence
 import TysWiredIn       ( coercibleClass )
+import RnEnv
 import Name
 import RdrName          ( lookupGRE_Name )
 import Id 
@@ -1026,9 +1029,10 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
   | null matches  -- No matches but perhaps several unifiers
   = do { let (is_ambig, ambig_msg) = mkAmbigMsg ct
        ; (ctxt, binds_msg) <- relevantBindings True ctxt ct
-       ; traceTc "mk_dict_err" (ppr ct $$ ppr is_ambig $$ ambig_msg)
+       ; records_msg <- mkRecordsMsg
+       ; traceTc "mk_dict_err" (ppr ct $$ ppr is_ambig $$ ambig_msg $$ records_msg)
        ; rdr_env <- getGlobalRdrEnv
-       ; return (ctxt, cannot_resolve_msg rdr_env is_ambig binds_msg ambig_msg) }
+       ; return (ctxt, cannot_resolve_msg rdr_env is_ambig binds_msg ambig_msg records_msg) }
 
   | not safe_haskell   -- Some matches => overlap errors
   = return (ctxt, overlap_msg)
@@ -1043,9 +1047,10 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
     givens      = getUserGivens ctxt
     all_tyvars  = all isTyVarTy tys
 
-    cannot_resolve_msg rdr_env has_ambig_tvs binds_msg ambig_msg
+    cannot_resolve_msg rdr_env has_ambig_tvs binds_msg ambig_msg records_msg
       = vcat [ addArising orig (no_inst_msg $$ coercible_explanation rdr_env)
              , vcat (pp_givens givens)
+             , records_msg
              , ppWhen (has_ambig_tvs && not (null unifiers && null givens))
                (vcat [ ambig_msg, binds_msg, potential_msg ])
              , show_fixes (add_to_ctxt_fixes has_ambig_tvs ++ drv_fixes) ]
@@ -1221,6 +1226,49 @@ mk_dict_err ctxt (ct, (matches, unifiers, safe_haskell))
             ]
         | otherwise = Nothing
 
+    mkRecordsMsg
+      | isRecordsClass clas
+          = do { overloaded <- xoptM Opt_OverloadedRecordFields
+               ; if not overloaded
+                 then return suggest_overloaded
+                 else case (tcSplitTyConApp_maybe r, isStrLitTy f) of
+                        (Just (tc, args), Just lbl) ->
+                            do { rep_tc <- lookupRepTyCon tc args
+                               ; let nice_ty | rep_tc == tc = mkTyConApp tc []
+                                             | otherwise    = r
+                               ; case lookupFsEnv (tyConFieldLabelEnv rep_tc) lbl of
+                                   Nothing -> return $ missing_field lbl nice_ty
+                                   Just fl ->
+                                       do { gbl_env <- getGblEnv
+                                          ; if fieldLabelInScope (tcg_rdr_env gbl_env) tc fl
+                                            then do { sel_id <- tcLookupId (flSelector fl)
+                                                    ; return $ unsuitable_field_type lbl nice_ty
+                                                                 (isNaughtyRecordSelector sel_id) }
+                                            else return $ not_in_scope lbl nice_ty } }
+                        _ -> return empty }
+      | otherwise = return empty
+      where
+        (r:f:_) = tys
+        suggest_overloaded = ptext $ sLit "Perhaps you should enable -XOverloadedRecordFields?"
+
+        missing_field lbl ty
+          = ptext (sLit "The type") <+> quotes (ppr ty)
+            <+> ptext (sLit "does not have a field") <+> quotes (ppr lbl)
+
+        not_in_scope lbl ty
+          = ptext (sLit "The field") <+> quotes (ppr lbl)
+                <+> ptext (sLit "of") <+> quotes (ppr ty)
+                <+> ptext (sLit "is not in scope")
+
+        unsuitable_field_type lbl ty is_existential
+          = hang (ptext (sLit "The field") <+> quotes (ppr lbl)
+                     <+> ptext (sLit "of") <+> quotes (ppr ty)
+                     <+> ptext (sLit "cannot be overloaded,"))
+               2 (ptext (sLit "as its type is") <+> quantifier is_existential
+                                                <+> ptext (sLit "quantified"))
+        quantifier True  = ptext (sLit "existentially")
+        quantifier False = ptext (sLit "universally")
+
 show_fixes :: [SDoc] -> SDoc
 show_fixes []     = empty
 show_fixes (f:fs) = sep [ ptext (sLit "Possible fix:")
diff --git a/compiler/typecheck/TcEvidence.lhs b/compiler/typecheck/TcEvidence.lhs
index a31f66adaa..9776ec11a9 100644
--- a/compiler/typecheck/TcEvidence.lhs
+++ b/compiler/typecheck/TcEvidence.lhs
@@ -740,6 +740,7 @@ evVarsOfTerms = foldr (unionVarSet . evVarsOfTerm) emptyVarSet
 \end{code}
 
 
+
 %************************************************************************
 %*                                                                      *
                   Pretty printing
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 3397b0836a..a305e3070d 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -8,7 +8,8 @@ c%
 module TcExpr ( tcPolyExpr, tcPolyExprNC, tcMonoExpr, tcMonoExprNC,
                 tcInferRho, tcInferRhoNC,
                 tcSyntaxOp, tcCheckId,
-                addExprErrCtxt) where
+                addExprErrCtxt,
+                getFixedTyVars ) where
 
 #include "HsVersions.h"
 
@@ -47,7 +48,8 @@ import Var
 import VarSet
 import VarEnv
 import TysWiredIn
-import TysPrim( intPrimTy )
+import TysPrim
+import MkId
 import PrimOp( tagToEnumKey )
 import PrelNames
 import DynFlags
@@ -632,12 +634,18 @@ In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
         family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
 
 \begin{code}
-tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
-  = ASSERT( notNull upd_fld_names )
-    do  {
+tcExpr (RecordUpd record_expr rbnds _ _ _) res_ty
+  = ASSERT( notNull (hsRecFields rbnds) ) do {
+        -- STEP -1  See Note [Disambiguating record updates]
+        -- After this we know that rbinds is unambiguous
+        rbinds <- disambiguateRecordBinds record_expr rbnds res_ty
+        ; let upd_flds      = hsRecFieldsUnambiguous rbinds
+              upd_fld_occs  = map fst upd_flds
+              upd_fld_names = map snd upd_flds
+
         -- STEP 0
         -- Check that the field names are really field names
-        ; sel_ids <- mapM tcLookupField upd_fld_names
+        ; sel_ids <- mapM tcLookupId upd_fld_names
                         -- The renamer has already checked that
                         -- selectors are all in scope
         ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
@@ -650,12 +658,11 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
         -- Figure out the tycon and data cons from the first field name
         ; let   -- It's OK to use the non-tc splitters here (for a selector)
               sel_id : _  = sel_ids
-              (tycon, _)  = recordSelectorFieldLabel sel_id     -- We've failed already if
+              tycon       = recordSelectorTyCon sel_id          -- We've failed already if
               data_cons   = tyConDataCons tycon                 -- it's not a field label
                 -- NB: for a data type family, the tycon is the instance tycon
 
-              relevant_cons   = filter is_relevant data_cons
-              is_relevant con = all (`elem` dataConFieldLabels con) upd_fld_names
+              relevant_cons   = tyConDataConsWithFields tycon upd_fld_occs
                 -- A constructor is only relevant to this process if
                 -- it contains *all* the fields that are being updated
                 -- Other ones will cause a runtime error if they occur
@@ -663,7 +670,7 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
                 -- Take apart a representative constructor
               con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
               (con1_tvs, _, _, _, con1_arg_tys, _) = dataConFullSig con1
-              con1_flds = dataConFieldLabels con1
+              con1_flds = map flLabel $ dataConFieldLabels con1
               con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs)
 
         -- Step 2
@@ -674,13 +681,10 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
         -- STEP 3    Note [Criteria for update]
         -- Check that each updated field is polymorphic; that is, its type
         -- mentions only the universally-quantified variables of the data con
-        ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
-              upd_flds1_w_tys = filter is_updated flds1_w_tys
-              is_updated (fld,_) = fld `elem` upd_fld_names
-
-              bad_upd_flds = filter bad_fld upd_flds1_w_tys
-              con1_tv_set = mkVarSet con1_tvs
-              bad_fld (fld, ty) = fld `elem` upd_fld_names &&
+        ; let flds1_w_tys  = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
+              bad_upd_flds = filter bad_fld flds1_w_tys
+              con1_tv_set  = mkVarSet con1_tvs
+              bad_fld (fld, ty) = fld `elem` upd_fld_occs &&
                                       not (tyVarsOfType ty `subVarSet` con1_tv_set)
         ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)
 
@@ -691,7 +695,7 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
         -- These are variables that appear in *any* arg of *any* of the
         -- relevant constructors *except* in the updated fields
         --
-        ; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons
+        ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons
               is_fixed_tv tv = tv `elemVarSet` fixed_tvs
 
               mk_inst_ty :: TvSubst -> (TKVar, TcType) -> TcM (TvSubst, TcType)
@@ -733,27 +737,47 @@ tcExpr (RecordUpd record_expr rbinds _ _ _) res_ty
         ; return $ mkHsWrapCo co_res $
           RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
                                    relevant_cons scrut_inst_tys result_inst_tys  }
-  where
-    upd_fld_names = hsRecFields rbinds
+\end{code}
 
-    getFixedTyVars :: [TyVar] -> [DataCon] -> TyVarSet
-    -- These tyvars must not change across the updates
-    getFixedTyVars tvs1 cons
-      = mkVarSet [tv1 | con <- cons
-                      , let (tvs, theta, arg_tys, _) = dataConSig con
-                            flds = dataConFieldLabels con
-                            fixed_tvs = exactTyVarsOfTypes fixed_tys
-                                    -- fixed_tys: See Note [Type of a record update]
-                                        `unionVarSet` tyVarsOfTypes theta
-                                    -- Universally-quantified tyvars that
-                                    -- appear in any of the *implicit*
-                                    -- arguments to the constructor are fixed
-                                    -- See Note [Implict type sharing]
 
-                            fixed_tys = [ty | (fld,ty) <- zip flds arg_tys
-                                            , not (fld `elem` upd_fld_names)]
-                      , (tv1,tv) <- tvs1 `zip` tvs      -- Discards existentials in tvs
-                      , tv `elemVarSet` fixed_tvs ]
+When typechecking a use of an overloaded record field, we need to
+construct an appropriate instantiation of
+
+    field :: forall p r n t . Accessor p r n t => Proxy# n -> p r t
+
+so we supply
+
+    p = metavariable
+    r = metavariable
+    t = metavariable
+    n = field label
+
+    Accessor p r n t = wanted constraint
+    Proxy# n         = proxy#
+
+and end up with something of type p r t.
+
+\begin{code}
+tcExpr (HsOverloadedRecFld lbl) res_ty
+  = do { p <- newFlexiTyVarTy (mkArrowKind liftedTypeKind
+                                  (mkArrowKind liftedTypeKind liftedTypeKind))
+       ; r <- newFlexiTyVarTy liftedTypeKind
+       ; t <- newFlexiTyVarTy liftedTypeKind
+       ; accessorClass <- tcLookupClass accessorClassName
+       ; acs_var <- emitWanted origin (mkClassPred accessorClass [p, r, n, t])
+       ; field   <- tcLookupId fieldName
+       ; loc     <- getSrcSpanM
+       ; let wrap      = mkWpEvVarApps [acs_var] <.> mkWpTyApps [p, r, n, t]
+             proxy_arg = noLoc (mkHsWrap (mkWpTyApps [typeSymbolKind, n])
+                                         (HsVar proxyHashId))
+             tm        = L loc (mkHsWrap wrap (HsVar field)) `HsApp` proxy_arg
+       ; tcWrapResult tm (mkAppTys p [r, t]) res_ty }
+  where
+    n      = mkStrLitTy lbl
+    origin = OccurrenceOfRecSel (mkVarUnqual lbl)
+
+tcExpr (HsSingleRecFld f sel_name) res_ty
+    = tcCheckRecSelId f sel_name res_ty
 \end{code}
 
 %************************************************************************
@@ -958,6 +982,11 @@ tcInferFun (L loc (HsVar name))
                -- Don't wrap a context around a plain Id
        ; return (L loc fun, ty) }
 
+tcInferFun (L loc (HsSingleRecFld lbl name))
+  = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId lbl name)
+               -- Don't wrap a context around a plain Id
+       ; return (L loc fun, ty) }
+
 tcInferFun fun
   = do { (fun, fun_ty) <- tcInfer (tcMonoExpr fun)
 
@@ -1006,7 +1035,7 @@ tcSyntaxOp :: CtOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
 -- Typecheck a syntax operator, checking that it has the specified type
 -- The operator is always a variable at this stage (i.e. renamer output)
 -- This version assumes res_ty is a monotype
-tcSyntaxOp orig (HsVar op) res_ty = do { (expr, rho) <- tcInferIdWithOrig orig op
+tcSyntaxOp orig (HsVar op) res_ty = do { (expr, rho) <- tcInferIdWithOrig orig (nameRdrName op) op
                                        ; tcWrapResult expr rho res_ty }
 tcSyntaxOp _ other         _      = pprPanic "tcSyntaxOp" (ppr other)
 \end{code}
@@ -1050,16 +1079,26 @@ tcCheckId name res_ty
        ; addErrCtxtM (funResCtxt False (HsVar name) actual_res_ty res_ty) $
          tcWrapResult expr actual_res_ty res_ty }
 
+tcCheckRecSelId :: RdrName -> Name -> TcRhoType -> TcM (HsExpr TcId)
+tcCheckRecSelId lbl name res_ty
+  = do { (expr, actual_res_ty) <- tcInferRecSelId lbl name
+       ; addErrCtxtM (funResCtxt False (HsSingleRecFld lbl name) actual_res_ty res_ty) $
+         tcWrapResult expr actual_res_ty res_ty }
+
 ------------------------
 tcInferId :: Name -> TcM (HsExpr TcId, TcRhoType)
 -- Infer type, and deeply instantiate
-tcInferId n = tcInferIdWithOrig (OccurrenceOf n) n
+tcInferId n = tcInferIdWithOrig (OccurrenceOf n) (nameRdrName n) n
+
+tcInferRecSelId :: RdrName -> Name -> TcM (HsExpr TcId, TcRhoType)
+tcInferRecSelId lbl n = tcInferIdWithOrig (OccurrenceOfRecSel lbl) lbl n
 
 ------------------------
-tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcRhoType)
+tcInferIdWithOrig :: CtOrigin -> RdrName -> Name ->
+                         TcM (HsExpr TcId, TcRhoType)
 -- Look up an occurrence of an Id, and instantiate it (deeply)
 
-tcInferIdWithOrig orig id_name
+tcInferIdWithOrig orig lbl id_name
   = do { id <- lookup_id
        ; (id_expr, id_rho) <- instantiateOuter orig id
        ; (wrap, rho) <- deeplyInstantiate orig id_rho
@@ -1093,7 +1132,7 @@ tcInferIdWithOrig orig id_name
     bad_patsyn name = ppr name <+>  ptext (sLit "used in an expression, but it's a non-bidirectional pattern synonym")
 
     check_naughty id
-      | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel id)
+      | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)
       | otherwise                  = return ()
 
 ------------------------
@@ -1369,6 +1408,136 @@ naughtiness in both branches.  c.f. TcTyClsBindings.mkAuxBinds.
 %*                                                                      *
 %************************************************************************
 
+\begin{code}
+getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [DataCon] -> TyVarSet
+-- These tyvars must not change across the updates
+getFixedTyVars upd_fld_occs tvs1 cons
+      = mkVarSet [tv1 | con <- cons
+                      , let (tvs, theta, arg_tys, _) = dataConSig con
+                            flds = dataConFieldLabels con
+                            fixed_tvs = exactTyVarsOfTypes fixed_tys
+                                    -- fixed_tys: See Note [Type of a record update]
+                                        `unionVarSet` tyVarsOfTypes theta
+                                    -- Universally-quantified tyvars that
+                                    -- appear in any of the *implicit*
+                                    -- arguments to the constructor are fixed
+                                    -- See Note [Implict type sharing]
+
+                            fixed_tys = [ty | (fl, ty) <- zip flds arg_tys
+                                            , not (flLabel fl `elem` upd_fld_occs)]
+                      , (tv1,tv) <- tvs1 `zip` tvs      -- Discards existentials in tvs
+                      , tv `elemVarSet` fixed_tvs ]
+\end{code}
+
+
+Note [Disambiguating record updates]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+If the -XOverloadedRecordFields extension is used, the renamer may not
+be able to determine exactly which fields are being updated. Consider:
+
+        data S = MkS { foo :: Int }
+        data T = MkT { foo :: Int, bar :: Int }
+        data U = MkU { bar :: Int }
+
+        f x = x { foo = 3, bar = 2 }
+
+        g :: T -> T
+        g x = x { foo = 3 }
+
+        h x = (x :: T) { foo = 3 }
+
+In this situation, the renamer sees an update of `foo` but doesn't
+know which parent datatype is in use. In this case, the
+`hsRecFieldSel` field of the `HsRecField` stores a list of candidates
+as (parent, selector name) pairs. The disambiguateRecordBinds function
+tries to determine the parent in three ways:
+
+1. Check for types that have all the fields being updated. In the
+   example, `f` must be updating `T` because neither `S` nor `U` have
+   both fields. This may also discover that no suitable type exists.
+
+2. Use the type being pushed in, if it is already a TyConApp. Thus `g`
+   is obviously an update to `T`.
+
+3. Use the type signature of the record expression, if it exists and
+   is a TyConApp. Thus `h` is an update to `T`.
+
+We could add further tests, of a more heuristic nature. For example,
+rather than looking for an explicit signature, we could try to infer
+the type of the record expression, in case we are lucky enough to get
+a TyConApp straight away. However, it might be hard for programmers to
+predict whether a particular update is sufficiently obvious for the
+signature to be omitted.
+
+\begin{code}
+disambiguateRecordBinds :: LHsExpr Name -> HsRecFields Name a -> Type
+                                 -> TcM (HsRecFields Name a)
+disambiguateRecordBinds record_expr rbnds res_ty
+  | unambiguous = return rbnds -- Always the case if OverloadedRecordFields is off
+  | otherwise   = do
+      { ps <- possibleParents orig_upd_flds
+      ; case ps of
+          []  -> failWithTc (noPossibleParents rbnds)
+          [p] -> chooseParent p rbnds
+          _ | Just p <- tyconOf res_ty -> chooseParent p rbnds
+          _ | Just sig_ty <- obviousSig (unLoc record_expr) ->
+                 do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
+                    ; case tyconOf sig_tc_ty of
+                        Just p  -> chooseParent p rbnds
+                        Nothing -> failWithTc badOverloadedUpdate }
+          _ -> failWithTc badOverloadedUpdate }
+  where
+    orig_upd_flds = hsRecFields rbnds
+    unambiguous   = all (isLeft . snd) orig_upd_flds
+    tyconOf       = fmap tyConName . tyConAppTyCon_maybe
+    isLeft        = either (const True) (const False)
+
+    -- Calculate the list of possible parent tycons, by taking the
+    -- intersection of the possibilities for each field.
+    possibleParents :: [(FieldLabelString, Either Name [(Name, Name)])] -> RnM [Name]
+    possibleParents xs = fmap (foldr1 intersect) (mapM (parentsFor . snd) xs)
+
+    -- Unambiguous fields have a single possible parent: their actual
+    -- parent.  Ambiguous fields record their possible parents for us.
+    parentsFor :: Either Name [(Name, Name)] -> RnM [Name]
+    parentsFor (Left name) = do { id <- tcLookupId name
+                                ; ASSERT (isRecordSelector id)
+                                    return [tyConName (recordSelectorTyCon id)] }
+    parentsFor (Right xs)  = return (map fst xs)
+
+    -- Make all the fields unambiguous by choosing the given parent.
+    -- Fails with an error if any of the ambiguous fields cannot have
+    -- that parent, e.g. if the user writes
+    --     r { x = e } :: T
+    -- where T does not have field x.
+    chooseParent :: Name -> HsRecFields Name arg -> RnM (HsRecFields Name arg)
+    chooseParent p rbnds | null orphans = return (rbnds { rec_flds = rec_flds' })
+                         | otherwise    = failWithTc (orphanFields p orphans)
+      where
+        (orphans, rec_flds') = partitionWith pickParent (rec_flds rbnds)
+
+        -- Returns Right fld' if fld can have parent p, or Left lbl if
+        -- not.  For an unambigous field, we don't need to check again
+        -- that it has the correct parent, because possibleParents
+        -- will have returned that single parent.
+        pickParent :: HsRecField Name arg ->
+                          Either (Located RdrName) (HsRecField Name arg)
+        pickParent fld@(HsRecField{ hsRecFieldSel = Left _ }) = Right fld
+        pickParent fld@(HsRecField{ hsRecFieldSel = Right xs })
+            = case lookup p xs of
+                  Just name -> Right (fld{ hsRecFieldSel = Left name })
+                  Nothing   -> Left (hsRecFieldLbl fld)
+
+    -- A type signature on the record expression must be "obvious",
+    -- i.e. the outermost constructor ignoring parentheses.
+    obviousSig :: HsExpr Name -> Maybe (LHsType Name)
+    obviousSig (ExprWithTySig _ ty) = Just ty
+    obviousSig (HsPar p)            = obviousSig (unLoc p)
+    obviousSig _                    = Nothing
+
+\end{code}
+
+
 Game plan for record bindings
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1. Find the TyCon for the bindings, from the first field label.
@@ -1397,22 +1566,25 @@ tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
   = do  { mb_binds <- mapM do_bind rbinds
         ; return (HsRecFields (catMaybes mb_binds) dd) }
   where
-    flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
-    do_bind fld@(HsRecField { hsRecFieldId = L loc field_lbl, hsRecFieldArg = rhs })
+    flds_w_tys = zipEqual "tcRecordBinds" (map flLabel $ dataConFieldLabels data_con) arg_tys
+    do_bind fld@(HsRecField { hsRecFieldLbl = L loc lbl, hsRecFieldSel = Left sel_name, hsRecFieldArg = rhs })
       | Just field_ty <- assocMaybe flds_w_tys field_lbl
       = addErrCtxt (fieldCtxt field_lbl)        $
         do { rhs' <- tcPolyExprNC rhs field_ty
-           ; let field_id = mkUserLocal (nameOccName field_lbl)
-                                        (nameUnique field_lbl)
+           ; let field_id = mkUserLocal (nameOccName sel_name)
+                                        (nameUnique sel_name)
                                         field_ty loc
                 -- Yuk: the field_id has the *unique* of the selector Id
                 --          (so we can find it easily)
                 --      but is a LocalId with the appropriate type of the RHS
                 --          (so the desugarer knows the type of local binder to make)
-           ; return (Just (fld { hsRecFieldId = L loc field_id, hsRecFieldArg = rhs' })) }
+           ; return (Just (fld { hsRecFieldSel = Left field_id, hsRecFieldArg = rhs' })) }
       | otherwise
       = do { addErrTc (badFieldCon (RealDataCon data_con) field_lbl)
            ; return Nothing }
+      where
+        field_lbl = occNameFS $ rdrNameOcc lbl
+    do_bind _ = panic "tcRecordBinds/do_bind: field with no selector"
 
 checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
 checkMissingFields data_con rbinds
@@ -1434,24 +1606,22 @@ checkMissingFields data_con rbinds
 
   where
     missing_s_fields
-        = [ fl | (fl, str) <- field_info,
+        = [ flLabel fl | (fl, str) <- field_info,
                  isBanged str,
-                 not (fl `elem` field_names_used)
+                 not (fl `elemField` field_names_used)
           ]
     missing_ns_fields
-        = [ fl | (fl, str) <- field_info,
+        = [ flLabel fl | (fl, str) <- field_info,
                  not (isBanged str),
-                 not (fl `elem` field_names_used)
+                 not (fl `elemField` field_names_used)
           ]
 
-    field_names_used = hsRecFields rbinds
+    field_names_used = hsRecFieldsUnambiguous rbinds
     field_labels     = dataConFieldLabels data_con
+    field_info       = zipEqual "missingFields" field_labels field_strs
+    field_strs       = dataConStrictMarks data_con
 
-    field_info = zipEqual "missingFields"
-                          field_labels
-                          field_strs
-
-    field_strs = dataConStrictMarks data_con
+    fl `elemField` flds = any (\ fl' -> flSelector fl == snd fl') flds
 \end{code}
 
 %************************************************************************
@@ -1469,7 +1639,7 @@ exprCtxt :: LHsExpr Name -> SDoc
 exprCtxt expr
   = hang (ptext (sLit "In the expression:")) 2 (ppr expr)
 
-fieldCtxt :: Name -> SDoc
+fieldCtxt :: FieldLabelString -> SDoc
 fieldCtxt field_name
   = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
 
@@ -1510,7 +1680,7 @@ funResCtxt has_args fun fun_res_ty env_ty tidy_env
           Just (tc, _) -> isAlgTyCon tc
           Nothing      -> False
 
-badFieldTypes :: [(Name,TcType)] -> SDoc
+badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc
 badFieldTypes prs
   = hang (ptext (sLit "Record update for insufficiently polymorphic field")
                          <> plural prs <> colon)
@@ -1536,7 +1706,7 @@ badFieldsUpd rbinds data_cons
 
             -- Each field, together with a list indicating which constructors
             -- have all the fields so far.
-            growingSets :: [(Name, [Bool])]
+            growingSets :: [(FieldLabelString, [Bool])]
             growingSets = scanl1 combine membership
             combine (_, setMem) (field, fldMem)
               = (field, zipWith (&&) setMem fldMem)
@@ -1549,13 +1719,13 @@ badFieldsUpd rbinds data_cons
     (members, nonMembers) = partition (or . snd) membership
 
     -- For each field, which constructors contain the field?
-    membership :: [(Name, [Bool])]
+    membership :: [(FieldLabelString, [Bool])]
     membership = sortMembership $
         map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $
-          hsRecFields rbinds
+          map (occNameFS . getOccName . snd) $ hsRecFieldsUnambiguous rbinds
 
-    fieldLabelSets :: [Set.Set Name]
-    fieldLabelSets = map (Set.fromList . dataConFieldLabels) data_cons
+    fieldLabelSets :: [Set.Set FieldLabelString]
+    fieldLabelSets = map (Set.fromList . map flLabel . dataConFieldLabels) data_cons
 
     -- Sort in order of increasing number of True, so that a smaller
     -- conflicting set can be found.
@@ -1591,7 +1761,7 @@ Finding the smallest subset is hard, so the code here makes
 a decent stab, no more.  See Trac #7989. 
 
 \begin{code}
-naughtyRecordSel :: TcId -> SDoc
+naughtyRecordSel :: RdrName -> SDoc
 naughtyRecordSel sel_id
   = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+>
     ptext (sLit "as a function due to escaped type variables") $$
@@ -1601,7 +1771,7 @@ notSelector :: Name -> SDoc
 notSelector field
   = hsep [quotes (ppr field), ptext (sLit "is not a record selector")]
 
-missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
+missingStrictFields :: DataCon -> [FieldLabelString] -> SDoc
 missingStrictFields con fields
   = header <> rest
   where
@@ -1612,10 +1782,26 @@ missingStrictFields con fields
     header = ptext (sLit "Constructor") <+> quotes (ppr con) <+>
              ptext (sLit "does not have the required strict field(s)")
 
-missingFields :: DataCon -> [FieldLabel] -> SDoc
+missingFields :: DataCon -> [FieldLabelString] -> SDoc
 missingFields con fields
   = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:")
         <+> pprWithCommas ppr fields
 
 -- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args))
+
+noPossibleParents :: HsRecFields Name a -> SDoc
+noPossibleParents rbinds
+  = hang (ptext (sLit "No type has all these fields:"))
+       2 (pprQuotedList fields)
+  where
+    fields = map fst (hsRecFields rbinds)
+
+badOverloadedUpdate :: SDoc
+badOverloadedUpdate = ptext (sLit "Record update is ambiguous, and requires a type signature")
+
+orphanFields :: Name -> [Located RdrName] -> SDoc
+orphanFields p flds
+  = hang (ptext (sLit "Type") <+> ppr p <+>
+             ptext (sLit "does not have field") <> plural flds <> colon)
+       2 (pprQuotedList flds)
 \end{code}
diff --git a/compiler/typecheck/TcFldInsts.lhs b/compiler/typecheck/TcFldInsts.lhs
new file mode 100644
index 0000000000..1f94049114
--- /dev/null
+++ b/compiler/typecheck/TcFldInsts.lhs
@@ -0,0 +1,468 @@
+%
+% (c) Adam Gundry 2013
+%
+
+TcFldInsts: Creating instances for OverloadedRecordFields
+
+For notes on the implementation of OverloadedRecordFields, see
+https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/Implementation
+
+See also GHC.Records in the base library.
+
+\begin{code}
+module TcFldInsts ( makeOverloadedRecFldInsts ) where
+
+#include "HsVersions.h"
+
+import HsSyn
+import TcBinds
+import TcInstDcls
+import TcRnMonad
+import TcValidity
+import TcSimplify
+import TcMType
+import TcType
+import InstEnv
+import FamInstEnv
+import TcEnv
+import TcExpr
+import MkCore     ( pAT_ERROR_ID )
+import Type
+import TysWiredIn
+import TypeRep
+import TyCon
+import CoAxiom
+import DataCon
+import Var
+import VarSet
+import PrelNames
+
+import Bag
+import BasicTypes
+import FastString
+import Id
+import MkId
+import IdInfo
+import Name
+import NameSet
+import RdrName
+import Outputable
+import SrcLoc
+import Util
+
+import Maybes     ( isNothing )
+import qualified Data.ByteString as BS
+\end{code}
+
+
+Note [Instance scoping for OverloadedRecordFields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+For the OverloadedRecordFields classes and type families, the
+instances in scope for a given module correspond exactly to the fields
+in scope in that module. To achieve this, instances are not exported
+using the normal mechanism (extending tcg_insts and
+tcg_fam_insts). Instead, only the dfun ids and axioms are exported
+(via tcg_binds for dfuns, and tcg_axioms for axioms). Special code in
+the constraint solver looks up the relevant instances.
+
+The difference between tcg_fam_insts and tcg_axioms is that the former
+will export the family instance as well as the underlying axiom,
+whereas the latter will export only the underlying axiom. Similar
+distinctions arise in ModGuts and the InteractiveContext.
+
+
+Note [Availability of type-changing update]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When generating instances of the Upd class and the UpdTy family for a
+field `f` of a datatype `T a b c`, we must decide which variables may
+be changed when the field is updated. For example, in
+
+    data T a b c = MkT { foo :: (a, b), bar :: a }
+
+an update to `foo` must keep `a` the same, since `a` occurs in the
+type of `bar`, but the update may change `b`.  Thus we generate:
+
+    instance t ~ (a, b') => Upd (T a b c) "foo" t
+    type instance UpdTy (T a b c) "foo" (a, b') = T a b' c
+
+As `c` does not occur in the type of `foo`, updates must keep it the
+same. This is slightly annoying, because a traditional record update
+`r { foo = (x, y) }` could change the type. It is a consequence of the
+fact that
+
+    type instance UpdTy (T a b c) "foo" (a, b') = T a b' c'
+
+makes no sense, because `c'` isn't bound anywhere.
+
+In general, a type variable can be changed when a field is updated
+provided that:
+
+(1) It is not 'fixed', i.e. it does not occur in the type of a
+    different field of a relevant data constructor, just as in
+    Note [Type of a record update] in TcExpr. (A relevant data
+    constructor is one that has the field being updated.)
+    In the example above, `a` is fixed.
+
+(2) It occurs in the type of the field being updated. In the example
+    above, `c` does not occur in the type of the field.
+
+(3) At least one of the variable's occurrences in the field type is
+    'rigid' (not under a type family).
+
+For an example of why (3) restricts update to variables with at least
+one rigid occurrence, consider the following:
+
+    type family G a
+    data T a = MkT { foo :: G a }
+
+Without the restriction, we would generate this:
+
+    type instance UpdTy (T a) "foo" (G b) = T b
+
+But we can't sensibly pattern-match on type families!
+
+On the other hand, this is okay:
+
+    data U a = MkU { foo :: a -> G a }
+
+While we cannot match on the type family, we can replace it with an
+unused variable, and make use of the rigid occurrence:
+
+    type instance UpdTy (U a) "foo" (b -> z) = U b
+
+
+Note that we have to be particularly careful with kind variables when
+PolyKinds is enabled, since the conditions above apply also to them.
+Consider the following definition, with kinds made explicit:
+
+    data FC (x :: BOX)(y :: BOX)(f :: x -> *)(g :: y -> x)(a :: y) :: * where
+        FC :: { runFC :: f (g a) } -> FC x y f g a
+
+The obvious UpdTy instance is this:
+
+    type instance UpdTy (FC x y f g a) "runFC" (f' (g' a')) = FC x' y' f' g' a'
+
+But this is bogus, because the kind variables x' and y' are not bound
+on the left-hand side!
+
+Similarly, kind variables may or may not be fixed. In the following
+example, updates to fields of U may change their types or kinds, while
+updates to fields of V may change the types but not the kinds:
+
+    data T (a :: x -> *)(b :: x) :: * where
+        MkT :: a b -> T a b
+
+    data U (a :: x -> *)(b :: x)(c :: y -> *)(d :: y)
+        = MkU { bar :: T a b, baz :: T c d }
+
+    data V (a :: x -> *)(b :: x)(c :: x -> *)(d :: x)
+        = MkV { bar :: T a b, baz :: T c d }
+
+
+\begin{code}
+-- | Contains Has and Upd class instances, and FldTy and UpdTy axioms,
+-- in that order. Left means that they are bogus (because the field is
+-- higher-rank or existential); Right gives the real things.
+type FldInstDetails = Either (Name, Name, Name, Name)
+                             (InstInfo Name, InstInfo Name,
+                                 CoAxiom Unbranched, CoAxiom Unbranched)
+
+-- | Create and typecheck instances from datatype and data instance
+-- declarations in the module being compiled.
+makeOverloadedRecFldInsts :: [TyClGroup Name] -> [LInstDecl Name]
+                          -> TcM TcGblEnv
+makeOverloadedRecFldInsts tycl_decls inst_decls
+    = do { fld_insts <- mapM makeRecFldInstsFor flds'
+         ; tcFldInsts fld_insts }
+  where
+    (_, flds) = hsTyClDeclsBinders tycl_decls inst_decls
+    flds'     = map (\ (x, y, z) -> (occNameFS (rdrNameOcc x), y, z)) flds
+
+
+-- | Given a (label, selector name, tycon name) triple, construct the
+-- appropriate Has, Upd, FldTy and UpdTy instances.
+makeRecFldInstsFor :: (FieldLabelString, Name, Name) -> TcM (Name, FldInstDetails)
+makeRecFldInstsFor (lbl, sel_name, tycon_name)
+  = do { rep_tc <- lookupRepTyConOfSelector tycon_name sel_name
+
+       -- Find a relevant data constructor (one that has this field)
+       -- and extract information from the FieldLabel.
+       ; let relevant_cons = tyConDataConsWithFields rep_tc [lbl]
+             dc            = ASSERT (notNull relevant_cons) head relevant_cons
+             (fl, fld_ty0) = dataConFieldLabel dc lbl
+             data_ty0      = dataConOrigResTy dc
+             is_existential = not (tyVarsOfType fld_ty0
+                                      `subVarSet` tyVarsOfType data_ty0)
+             FieldLabel _ _ _ has_name upd_name get_name set_name = fl
+
+       -- If the field is universally or existentially quantified,
+       -- don't generate any instances.
+       ; (_, mb) <- tryTc (checkValidMonoType fld_ty0)
+       ; if isNothing mb || is_existential
+         then return (sel_name, Left (has_name, upd_name, get_name, set_name))
+         else do
+
+           -- Freshen the type variables in the constituent types
+           { let univ_tvs     = dataConUnivTyVars dc
+           ; (subst0, tyvars) <- tcInstSkolTyVars (univ_tvs ++ dataConExTyVars dc)
+           ; let n            = mkStrLitTy lbl
+                 r            = substTy subst0 (mkFamilyTyConApp rep_tc
+                                                   (mkTyVarTys univ_tvs))
+                 data_ty      = substTy subst0 data_ty0
+                 fld_ty       = substTy subst0 fld_ty0
+                 eq_spec      = substTys subst0 (eqSpecPreds (dataConEqSpec dc))
+                 stupid_theta = substTys subst0 (dataConStupidTheta dc)
+           ; b <- mkTyVar <$> newSysName (mkVarOcc "b") <*> pure liftedTypeKind
+
+           -- Generate Has instance:
+           --     instance (b ~ fld_ty, theta) => Has r n b
+           ; has_inst <- mkHasInstInfo has_name sel_name lbl n tyvars
+                             (eq_spec ++ stupid_theta) r fld_ty b
+
+           -- Generate FldTy instance:
+           --     type instance FldTy data_ty n = fld_ty
+           ; get_ax <- mkAxiom get_name fldTyFamName [data_ty, n] fld_ty
+
+           -- Generate Upd instance:
+           --     instance (b ~ fld_ty', theta) => Upd r n b
+           -- See Note [Availability of type-changing update]
+           ; (subst, tyvars') <- updatingSubst lbl relevant_cons tyvars
+                                     (rigidTyVarsOfType fld_ty)
+           ; let fld_ty'  = substTy subst fld_ty
+                 data_ty' = substTy subst data_ty
+                 stupid_theta' = substTys subst stupid_theta
+           ; upd_inst <- mkUpdInstInfo upd_name lbl n
+                             (eq_spec ++ stupid_theta ++ stupid_theta')
+                             r b tyvars' fld_ty' relevant_cons rep_tc
+
+           -- Generate UpdTy instance:
+           --     type instance UpdTy data_ty n hull_ty = data_ty'
+           -- See Note [Calculating the hull type]
+           ; hull_ty <- hullType fld_ty'
+           ; set_ax  <- mkAxiom set_name updTyFamName
+                            [data_ty, n, hull_ty] data_ty'
+
+           -- ; dumpDerivingInfo (hang (text "Overloaded record field instances:")
+           --                  2 (vcat [ppr has_inst, ppr get_ax,
+           --                           ppr upd_inst, ppr set_ax]))
+
+           ; return (sel_name, Right (has_inst, upd_inst, get_ax, set_ax)) } }
+
+  where
+
+    -- | Make InstInfo for Has thus:
+    --     instance forall b tyvars . (b ~ fld_ty, theta) => Has t n b where
+    --         getField _ = sel_name
+    mkHasInstInfo dfun_name sel_name lbl n tyvars theta t fld_ty b
+        = do { hasClass <- tcLookupClass recordHasClassName
+             ; let theta' = mkEqPred (mkTyVarTy b) fld_ty : theta
+                   dfun   = mkDictFunId dfun_name (b:tyvars) theta' hasClass args
+             ; cls_inst <- mkFreshenedClsInst dfun (b:tyvars) hasClass args
+             ; return (InstInfo cls_inst inst_bind) }
+      where
+        args = [t, n, mkTyVarTy b]
+        inst_bind = InstBindings bind [] [] True
+          where
+            bind  = unitBag $ noLoc $ (mkTopFunBind Generated (noLoc getFieldName) [match])
+                                          { bind_fvs = placeHolderNames }
+            match = mkSimpleMatch [nlWildPat]
+                        (noLoc (HsSingleRecFld (mkVarUnqual lbl) sel_name))
+
+
+    -- | Make InstInfo for Upd thus:
+    --     instance forall b tyvars' . (b ~ fld_ty', theta) => Upd t n b where
+    --         setField _ (MkT fld1 ... fldn) x = MkT fld1 ... x ... fldn
+    --  fld_ty' is fld_ty with fresh tyvars (if type-changing update is possible)
+    --  It would be nicer to use record-update syntax, but that isn't
+    --  possible because of Trac #2595.
+    mkUpdInstInfo dfun_name lbl n theta t b tyvars' fld_ty' relevant_cons rep_tc
+        = do { updClass   <- tcLookupClass recordUpdClassName
+             ; let args   = [t, n, mkTyVarTy b]
+                   theta' = mkEqPred (mkTyVarTy b) fld_ty' : theta
+                   dfun   = mkDictFunId dfun_name (b:tyvars') theta' updClass args
+             ; cls_inst   <- mkFreshenedClsInst dfun (b:tyvars') updClass args
+             ; matches    <- mapM matchCon relevant_cons
+             ; return (InstInfo cls_inst (inst_bind matches)) }
+      where
+        matchCon con
+          = do { x <- newSysName (mkVarOcc "x")
+               ; vars <- mapM (newSysName . mkVarOccFS . flLabel) (dataConFieldLabels con)
+               ; let con_name = dataConName con
+                     vars'    = map replace_lbl vars
+                     replace_lbl v = if occNameFS (nameOccName v) == lbl then x else v
+               ; return $ mkSimpleMatch [nlWildPat, nlConVarPat con_name vars, nlVarPat x]
+                                        (nlHsVarApps con_name vars') }
+
+        inst_bind matches = InstBindings bind [] [] True
+          where
+            bind = unitBag $ noLoc $ (mkTopFunBind Generated (noLoc setFieldName) all_matches)
+                                         { bind_fvs = placeHolderNames }
+            all_matches | all dealt_with cons = matches
+                        | otherwise           = matches ++ [default_match]
+            default_match = mkSimpleMatch [nlWildPat, nlWildPat, nlWildPat] $
+                                nlHsApp (nlHsVar (getName pAT_ERROR_ID))
+                                        (nlHsLit (HsStringPrim msg))
+            msg = unsafeMkByteString "setField|overloaded record update: "
+                      `BS.append` fastStringToByteString lbl
+            cons = tyConDataCons rep_tc
+            dealt_with con = con `elem` relevant_cons
+                                 || dataConCannotMatch inst_tys con
+            inst_tys = substTyVars (mkTopTvSubst (dataConEqSpec dc))
+                                   (dataConUnivTyVars dc)
+            dc = head relevant_cons
+
+
+    -- | Make a class instance with freshened type variables.
+    -- See Note [Template tyvars are fresh] in InstEnv.
+    mkFreshenedClsInst dfun tyvars clas tys
+      = do { (subst, tyvars') <- tcInstSkolTyVars tyvars
+           ; return $ mkLocalInstance dfun (NoOverlap False) tyvars' clas
+                          (substTys subst tys) }
+
+
+    -- | Make an axiom corresponding to the type family instance
+    --    type instance fam_name args = result
+    mkAxiom ax_name fam_name args result
+      = do { fam <- tcLookupTyCon fam_name
+           ; let tyvars = varSetElems (tyVarsOfTypes (result:args))
+           ; (subst, tyvars') <- tcInstSkolTyVars tyvars
+           ; return $ mkSingleCoAxiom ax_name tyvars' fam (substTys subst args)
+                                                          (substTy subst result) }
+
+
+-- | Given a tycon name and a record selector belonging to that tycon,
+-- return the representation tycon that contains the selector.
+lookupRepTyConOfSelector :: Name -> Name -> TcM TyCon
+lookupRepTyConOfSelector tycon_name sel_name
+  = do { tc <- tcLookupTyCon tycon_name
+       ; if (isDataFamilyTyCon tc)
+         then do { sel_id <- tcLookupId sel_name
+                 ; ASSERT (isRecordSelector sel_id)
+                   return (recordSelectorTyCon sel_id) }
+         else return tc }
+
+-- | Compute a substitution that replaces each tyvar with a fresh
+-- variable, if it can be updated; also returns a list of all the
+-- tyvars (old and new). See Note [Availability of type-changing update]
+updatingSubst :: FieldLabelString -> [DataCon] -> [TyVar] -> TyVarSet ->
+                         TcM (TvSubst, [TyVar])
+updatingSubst lbl relevant_cons tyvars fld_tvs
+      = do { (subst, tyvarss) <- mapAccumLM updateTyVar emptyTvSubst tyvars
+           ; return (subst, concat tyvarss) }
+      where
+        fixed_tvs    = getFixedTyVars [lbl] tyvars relevant_cons
+        changeable x = x `elemVarSet` fld_tvs && not (x `elemVarSet` fixed_tvs)
+
+        updateTyVar :: TvSubst -> TyVar -> TcM (TvSubst, [TyVar])
+        updateTyVar subst tv
+          | changeable tv = do { (subst', tv') <- tcInstSkolTyVar noSrcSpan False subst tv
+                               ; return (subst', [tv,tv']) }
+          | otherwise     = return (subst, [tv])
+
+
+rigidTyVarsOfType :: Type -> VarSet
+-- ^ Returns free type (not kind) variables of a type, that are not
+-- under a type family application.
+rigidTyVarsOfType (TyVarTy v)         = unitVarSet v
+rigidTyVarsOfType (TyConApp tc tys)   | isDecomposableTyCon tc = rigidTyVarsOfTypes tys
+                                      | otherwise              = emptyVarSet
+rigidTyVarsOfType (LitTy {})          = emptyVarSet
+rigidTyVarsOfType (FunTy arg res)     = rigidTyVarsOfType arg `unionVarSet` rigidTyVarsOfType res
+rigidTyVarsOfType (AppTy fun arg)     = rigidTyVarsOfType fun `unionVarSet` rigidTyVarsOfType arg
+rigidTyVarsOfType (ForAllTy tyvar ty) = delVarSet (rigidTyVarsOfType ty) tyvar
+                                            `unionVarSet` rigidTyVarsOfType (tyVarKind tyvar)
+
+rigidTyVarsOfTypes :: [Type] -> TyVarSet
+rigidTyVarsOfTypes tys = foldr (unionVarSet . rigidTyVarsOfType) emptyVarSet tys
+\end{code}
+
+
+Note [Calculating the hull type]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+UpdTy must not pattern-match on type families (see Note
+[Availability of type-changing update]). For example, given the
+datatype
+
+    data T a b = MkT { foo :: (a, Int, F b) }
+
+we generate
+
+    type instance UpdTy (T a b) "foo" (a', Int, x) = T a' b
+
+rather than
+
+    type instance UpdTy (T a b) "foo" (a', Int, F b') = T a' b'.
+
+This is accomplished by the `hullType` function, which returns a type
+in which all the type family subexpressions have been replaced with
+fresh variables.
+
+\begin{code}
+hullType :: Type -> TcM Type
+hullType ty@(TyVarTy _)      = return ty
+hullType (AppTy f s)         = AppTy <$> hullType f <*> hullType s
+hullType ty@(TyConApp tc tys)
+  | isDecomposableTyCon tc   = TyConApp tc <$> mapM hullType tys
+  | otherwise                = mkTyVarTy <$> (mkTyVar <$> newSysName (mkVarOcc "x")
+                                                      <*> pure (typeKind ty))
+hullType (FunTy t u)         = FunTy <$> hullType t <*> hullType u
+hullType (ForAllTy v ty)     = ForAllTy v <$> hullType ty
+hullType ty@(LitTy _)        = return ty
+\end{code}
+
+
+Note [Bogus instances]
+~~~~~~~~~~~~~~~~~~~~~~
+When a field's type is universally or existentially quantified, we
+cannot generate instances for it.  Just like naughty record selectors
+(see Note [Naughty record selectors] in TcTyClsDcls), we build bogus
+Ids in place of such instances, so that we can detect this when
+looking for them. This means we have to be a little careful when
+looking up the instances: the bogus Ids are just vanilla bindings of
+(), not DFunIds or CoAxioms.
+
+\begin{code}
+-- | Typecheck the generated Has, Upd, FldTy and UpdTy instances.
+-- This adds the dfuns and axioms to the global environment, but does
+-- not add user-visible instances.
+tcFldInsts :: [(Name, FldInstDetails)] -> TcM TcGblEnv
+tcFldInsts fld_insts
+    = updGblEnv (\env -> env { tcg_axioms = axioms ++ tcg_axioms env }) $
+        tcExtendGlobalEnvImplicit things $
+                 -- Invoke the constraint solver to find uses of
+                 -- fields now rather than later
+              do { (binds, lie) <- captureConstraints $ tcInstDecls2 [] inst_infos
+                 ; ev_binds     <- simplifyTop lie
+
+                 -- See Note [Bogus instances]
+                 ; let (bogus_sigs, bogus_binds) = mapAndUnzip mkBogusId bogus_insts
+                 ; env <- tcRecSelBinds $ ValBindsOut bogus_binds bogus_sigs
+
+                   -- Don't count the generated instances as uses of the field
+                 ; updMutVar (tcg_used_selectors env)
+                             (\s -> delListFromNameSet s (map fst fld_insts))
+
+                 ; ASSERT2( isEmptyBag ev_binds , ppr ev_binds)
+                   return $ env { tcg_binds = tcg_binds env `unionBags` binds } }
+  where
+    has_upd (_, Right (has, upd, _, _)) = [has, upd]
+    has_upd _                           = []
+
+    get_set (_, Right (_, _, get, set)) = [get, set]
+    get_set _                           = []
+
+    inst_infos = concatMap has_upd fld_insts
+    axioms     = concatMap (map toBranchedAxiom . get_set) fld_insts
+    things     = map ACoAxiom axioms
+                     ++ map (AnId . is_dfun . iSpec) inst_infos
+
+    bogus (_, Left (has, upd, get, set)) = [has, upd, get, set]
+    bogus _            = []
+    bogus_insts = concatMap bogus fld_insts
+
+    mkBogusId :: Name -> (LSig Name, (RecFlag, LHsBinds Name))
+    mkBogusId n = (noLoc (IdSig bogus_id), (NonRecursive, unitBag (noLoc bind)))
+      where
+        bogus_id = mkExportedLocalVar VanillaId n unitTy vanillaIdInfo
+        bind     = mkTopFunBind Generated (noLoc n) [mkSimpleMatch [] (mkLHsTupleExpr [])]
+\end{code}
diff --git a/compiler/typecheck/TcGenDeriv.lhs b/compiler/typecheck/TcGenDeriv.lhs
index 7031e54f6f..ed8217976a 100644
--- a/compiler/typecheck/TcGenDeriv.lhs
+++ b/compiler/typecheck/TcGenDeriv.lhs
@@ -990,7 +990,7 @@ gen_Read_binds get_fixity loc tycon
         field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
 
         con_arity    = dataConSourceArity data_con
-        labels       = dataConFieldLabels data_con
+        labels       = map flLabel $ dataConFieldLabels data_con
         dc_nm        = getName data_con
         is_infix     = dataConIsInfix data_con
         is_record    = length labels > 0
@@ -1043,7 +1043,7 @@ gen_Read_binds get_fixity loc tycon
                  | otherwise
                  = ident_h_pat lbl_str
                  where
-                   lbl_str = occNameString (getOccName lbl)
+                   lbl_str = unpackFS lbl
 \end{code}
 
 
@@ -1104,7 +1104,7 @@ gen_Show_binds get_fixity loc tycon
              arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed
              con_pat       = nlConVarPat data_con_RDR bs_needed
              nullary_con   = con_arity == 0
-             labels        = dataConFieldLabels data_con
+             labels        = map flLabel $ dataConFieldLabels data_con
              lab_fields    = length labels
              record_syntax = lab_fields > 0
 
@@ -1127,8 +1127,7 @@ gen_Show_binds get_fixity loc tycon
                         -- space after the '=' is necessary, but it
                         -- seems tidier to have them both sides.
                  where
-                   occ_nm   = getOccName l
-                   nm       = wrapOpParens (occNameString occ_nm)
+                   nm       = wrapOpParens (unpackFS l)
 
              show_args               = zipWith show_arg bs_needed arg_tys
              (show_arg1:show_arg2:_) = show_args
@@ -1380,7 +1379,7 @@ gen_Data_binds dflags loc tycon
                nlList  labels,                            -- Field labels
            nlHsVar fixity]                                -- Fixity
 
-        labels   = map (nlHsLit . mkHsString . getOccString)
+        labels   = map (nlHsLit . HsString . flLabel)
                        (dataConFieldLabels dc)
         dc_occ   = getOccName dc
         is_infix = isDataSymOcc dc_occ
diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs
index d9d92ba2ea..6b068fbc28 100644
--- a/compiler/typecheck/TcGenGenerics.lhs
+++ b/compiler/typecheck/TcGenGenerics.lhs
@@ -30,7 +30,7 @@ import DataCon
 import TyCon
 import FamInstEnv       ( FamInst, FamFlavor(..), mkSingleCoAxiom )
 import FamInst
-import Module           ( Module, moduleName, moduleNameString )
+import Module
 import IfaceEnv         ( newGlobalBinder )
 import Name      hiding ( varName )
 import RdrName
@@ -704,30 +704,28 @@ mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds)
                                                      , nlHsIntLit (toInteger n)]
 
         allSelBinds   = map (map selBinds) datasels
-        selBinds s    = mkBag [(selName_RDR, selName_matches s)]
+        selBinds s    = mkBag [(selName_RDR, mkStringLHS s)]
 
         loc           = srcLocSpan (getSrcLoc tycon)
-        mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))]
+        mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (HsString s))]
         datacons      = tyConDataCons tycon
-        datasels      = map dataConFieldLabels datacons
+        datasels      = map (map flLabel . dataConFieldLabels) datacons
 
         tyConName_user = case tyConFamInst_maybe tycon of
                            Just (ptycon, _) -> tyConName ptycon
                            Nothing          -> tyConName tycon
 
-        dtName_matches     = mkStringLHS . occNameString . nameOccName
+        dtName_matches     = mkStringLHS . occNameFS . nameOccName
                            $ tyConName_user
-        moduleName_matches = mkStringLHS . moduleNameString . moduleName 
+        moduleName_matches = mkStringLHS . moduleNameFS . moduleName
                            . nameModule . tyConName $ tycon
         isNewtype_matches  = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
 
-        conName_matches     c = mkStringLHS . occNameString . nameOccName
+        conName_matches     c = mkStringLHS . occNameFS . nameOccName
                               . dataConName $ c
         conFixity_matches   c = [mkSimpleHsAlt nlWildPat (fixity c)]
         conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)]
 
-        selName_matches     s = mkStringLHS (occNameString (nameOccName s))
-
 
 --------------------------------------------------------------------------------
 -- Dealing with sums
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 59b42ea673..5dd3485e5f 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -951,9 +951,9 @@ zonkRecFields env (HsRecFields flds dd)
         ; return (HsRecFields flds' dd) }
   where
     zonk_rbind fld
-      = do { new_id   <- wrapLocM (zonkIdBndr env) (hsRecFieldId fld)
+      = do { new_id   <- zonkIdBndr env (unLoc (hsRecFieldId fld))
            ; new_expr <- zonkLExpr env (hsRecFieldArg fld)
-           ; return (fld { hsRecFieldId = new_id, hsRecFieldArg = new_expr }) }
+           ; return (fld { hsRecFieldSel = Left new_id, hsRecFieldArg = new_expr }) }
 
 -------------------------------------------------------------------------
 mapIPNameTc :: (a -> TcM b) -> Either HsIPName a -> TcM (Either HsIPName b)
diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs
index eed906898b..f3ef74bc42 100644
--- a/compiler/typecheck/TcHsType.lhs
+++ b/compiler/typecheck/TcHsType.lhs
@@ -62,6 +62,7 @@ import TysPrim ( liftedTypeKindTyConName, constraintKindTyConName )
 import Class
 import Name
 import NameEnv
+import RdrName
 import TysWiredIn
 import BasicTypes
 import SrcLoc
@@ -73,7 +74,7 @@ import FastString
 import Util
 
 import Control.Monad ( unless, when, zipWithM )
-import PrelNames( ipClassName, funTyConKey )
+import PrelNames
 \end{code}
 
 
@@ -372,6 +373,19 @@ tc_hs_type hs_ty@(HsOpTy ty1 (_, l_op@(L _ op)) ty2) exp_kind
        ; return (mkNakedAppTys op' tys') }
          -- mkNakedAppTys: see Note [Zonking inside the knot]
 
+tc_hs_type hs_ty@(HsAppTy ty1 (L loc (HsRecTy flds))) exp_kind
+  = do { ty1' <- tc_lhs_type ty1 ekLifted
+       ; cs <- setSrcSpan loc $ mapM (checkRecordField ty1') flds
+       ; checkExpectedKind hs_ty constraintKind exp_kind
+       ; return (mkTupleTy ConstraintTuple cs) }
+  where
+    checkRecordField :: Type -> ConDeclField Name -> TcM Type
+    checkRecordField r (ConDeclField lbl _ ty _)
+      = do { ty'      <- tc_lhs_type ty ekLifted
+           ; hasClass <- tcLookupClass recordHasClassName
+           ; let n = mkStrLitTy (occNameFS (rdrNameOcc (unLoc lbl)))
+           ; return $ mkClassPred hasClass [r, n, ty'] }
+
 tc_hs_type hs_ty@(HsAppTy ty1 ty2) exp_kind
 --  | L _ (HsTyVar fun) <- fun_ty
 --  , fun `hasKey` funTyConKey
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index fc1842908d..138c6f536f 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -49,7 +49,7 @@ import VarEnv
 import VarSet 
 import CoreUnfold ( mkDFunUnfolding )
 import CoreSyn    ( Expr(Var, Type), CoreExpr, mkTyApps, mkVarApps )
-import PrelNames  ( tYPEABLE_INTERNAL, typeableClassName, oldTypeableClassNames )
+import PrelNames
 
 import Bag
 import BasicTypes
@@ -654,6 +654,7 @@ tcDataFamInstDecl mb_clsinfo
     (L loc decl@(DataFamInstDecl
        { dfid_pats = pats
        , dfid_tycon = fam_tc_name
+       , dfid_rep_tycon = rep_tc_name
        , dfid_defn = defn@HsDataDefn { dd_ND = new_or_data, dd_cType = cType
                                      , dd_ctxt = ctxt, dd_cons = cons } }))
   = setSrcSpan loc             $
@@ -683,7 +684,6 @@ tcDataFamInstDecl mb_clsinfo
        ; h98_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta cons
 
          -- Construct representation tycon
-       ; rep_tc_name <- newFamInstTyConName fam_tc_name pats'
        ; axiom_name  <- newImplicitBinder rep_tc_name mkInstTyCoOcc
        ; let orig_res_ty = mkTyConApp fam_tc pats'
 
diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index b8c4c8107e..1a35788990 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -1835,6 +1835,10 @@ matchClassInst _ clas [ _k, ty1, ty2 ] loc
       traceTcS "matchClassInst returned" $ ppr ev
       return ev
 
+matchClassInst _ clas tys loc
+  | isRecordsClass clas
+  = matchRecordsClassInst clas tys loc
+
 matchClassInst inerts clas tys loc
    = do { dflags <- getDynFlags
         ; untch <- getUntouchables
@@ -1864,7 +1868,7 @@ matchClassInst inerts clas tys loc
                                 text "witness" <+> ppr dfun_id
                                                <+> ppr (idType dfun_id) ]
                                   -- Record that this dfun is needed
-                        ; match_one dfun_id inst_tys }
+                        ; match_one dfun_id inst_tys pred loc }
 
             (matches, _, _)    -- More than one matches
                                -- Defer any reactions of a multitude
@@ -1876,21 +1880,6 @@ matchClassInst inerts clas tys loc
    where
      pred = mkClassPred clas tys
 
-     match_one :: DFunId -> [Maybe TcType] -> TcS LookupInstResult
-                  -- See Note [DFunInstType: instantiating types] in InstEnv
-     match_one dfun_id mb_inst_tys
-       = do { checkWellStagedDFun pred dfun_id loc
-            ; (tys, dfun_phi) <- instDFunType dfun_id mb_inst_tys
-            ; let (theta, _) = tcSplitPhiTy dfun_phi
-            ; if null theta then
-                  return (GenInst [] (EvDFunApp dfun_id tys []))
-              else do
-            { evc_vars <- instDFunConstraints loc theta
-            ; let new_ev_vars = freshGoals evc_vars
-                      -- new_ev_vars are only the real new variables that can be emitted
-                  dfun_app = EvDFunApp dfun_id tys (getEvTerms evc_vars)
-            ; return $ GenInst new_ev_vars dfun_app } }
-
      givens_for_this_clas :: Cts
      givens_for_this_clas
          = filterBag isGivenCt (findDictsByClass (inert_dicts $ inert_cans inerts) clas)
@@ -1915,6 +1904,21 @@ matchClassInst inerts clas tys loc
                            -- by the overlap check with the instance environment.
      matchable _tys ct = pprPanic "Expecting dictionary!" (ppr ct)
 
+match_one :: DFunId -> [Maybe TcType] -> PredType -> CtLoc -> TcS LookupInstResult
+                  -- See Note [DFunInstType: instantiating types] in InstEnv
+match_one dfun_id mb_inst_tys pred loc
+       = do { checkWellStagedDFun pred dfun_id loc
+            ; (tys, dfun_phi) <- instDFunType dfun_id mb_inst_tys
+            ; let (theta, _) = tcSplitPhiTy dfun_phi
+            ; if null theta then
+                  return (GenInst [] (EvDFunApp dfun_id tys []))
+              else do
+            { evc_vars <- instDFunConstraints loc theta
+            ; let new_ev_vars = freshGoals evc_vars
+                      -- new_ev_vars are only the real new variables that can be emitted
+                  dfun_app = EvDFunApp dfun_id tys (getEvTerms evc_vars)
+            ; return $ GenInst new_ev_vars dfun_app } }
+
 -- See Note [Coercible Instances]
 -- Changes to this logic should likely be reflected in coercible_msg in TcErrors.
 getCoercibleInst :: CtLoc -> TcType -> TcType -> TcS LookupInstResult
@@ -2125,3 +2129,32 @@ overlapping checks. There we are interested in validating the following principl
 
 But for the Given Overlap check our goal is just related to completeness of
 constraint solving.
+
+
+\begin{code}
+-- See Note [Instance scoping for OverloadedRecordFields] in TcFldInsts
+-- and the section on "Looking up record field instances" in RnEnv
+matchRecordsClassInst :: Class -> [Type] -> CtLoc -> TcS LookupInstResult
+matchRecordsClassInst clas tys loc
+  | Just (lbl, tc, args) <- tcSplitRecordsArgs tys
+    = do { rep_tc <- lookupRepTyCon tc args
+         ; mb_dfun  <- lookupFldInstDFun lbl tc rep_tc (isHasClass clas)
+         ; case mb_dfun of
+             Nothing   -> return NoInstance
+             Just dfun ->
+                 -- We've got the right DFun, now we just need to line
+                 -- up the types correctly. For example, we might have
+                 --     dfun_72 :: forall a b c . c ~ [a] => Has (T a b) "f" c
+                 -- and want to match
+                 --     Has (T x y) "f" z
+                 -- so we split up the DFun's type and use tcMatchTys to
+                 -- generate the substitution [x |-> a, y |-> b, z |-> c].
+                 let (tvs, _, _, tmpl_tys) = tcSplitDFunTy (idType dfun)
+                 in case tcMatchTys (mkVarSet tvs) tmpl_tys tys of
+                      Just subst -> let mb_inst_tys = map (lookupTyVar subst) tvs
+                                        pred        = mkClassPred clas tys
+                                    in match_one dfun mb_inst_tys pred loc
+                      Nothing -> pprPanic "matchClassInst" (ppr clas $$ ppr tvs $$ ppr tmpl_tys $$ ppr tys) }
+
+matchRecordsClassInst _ _ _ = return NoInstance
+\end{code}
diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 0b2a200867..c9d26d6531 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -31,6 +31,7 @@ import Id
 import Var
 import Name
 import NameSet
+import RdrName
 import TcEnv
 --import TcExpr
 import TcMType
@@ -950,15 +951,17 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside
   = do	{ (rpats', res) <- tcMultiple tc_field rpats penv thing_inside
 	; return (RecCon (HsRecFields rpats' dd), res) }
   where
-    tc_field :: Checker (HsRecField FieldLabel (LPat Name)) (HsRecField TcId (LPat TcId))
-    tc_field (HsRecField field_lbl pat pun) penv thing_inside
-      = do { (sel_id, pat_ty) <- wrapLocFstM find_field_ty field_lbl
+    tc_field :: Checker (HsRecField Name (LPat Name)) (HsRecField TcId (LPat TcId))
+    tc_field (HsRecField (L loc lbl) (Left sel_name) pat pun) penv thing_inside
+      = do { sel_id <- tcLookupId sel_name
+           ; pat_ty <- setSrcSpan loc $ find_field_ty (occNameFS (rdrNameOcc lbl))
 	   ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside
-	   ; return (HsRecField sel_id pat' pun, res) }
+	   ; return (HsRecField (L loc lbl) (Left sel_id) pat' pun, res) }
+    tc_field _ _ _ = panic "tcConArgs/tc_field missing field selector name"
 
-    find_field_ty :: FieldLabel -> TcM (Id, TcType)
-    find_field_ty field_lbl
-	= case [ty | (f,ty) <- field_tys, f == field_lbl] of
+    find_field_ty :: FieldLabelString -> TcM TcType
+    find_field_ty lbl
+	= case [ty | (fl, ty) <- field_tys, flLabel fl == lbl] of
 
 		-- No matching field; chances are this field label comes from some
 		-- other record type (or maybe none).  If this happens, just fail,
@@ -966,13 +969,12 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside
 		--	f (R { foo = (a,b) }) = a+b
 		-- If foo isn't one of R's fields, we don't want to crash when
 		-- typechecking the "a+b".
-	   [] -> failWith (badFieldCon con_like field_lbl)
+           [] -> failWith (badFieldCon con_like lbl)
 
 		-- The normal case, when the field comes from the right constructor
 	   (pat_ty : extras) ->
 		ASSERT( null extras )
-		do { sel_id <- tcLookupField field_lbl
-		   ; return (sel_id, pat_ty) }
+		return pat_ty
 
     field_tys :: [(FieldLabel, TcType)]
     field_tys = case con_like of
@@ -1138,7 +1140,7 @@ existentialLetPat
 	  text "I can't handle pattern bindings for existential or GADT data constructors.",
 	  text "Instead, use a case-expression, or do-notation, to unpack the constructor."]
 
-badFieldCon :: ConLike -> Name -> SDoc
+badFieldCon :: ConLike -> FieldLabelString -> SDoc
 badFieldCon con field
   = hsep [ptext (sLit "Constructor") <+> quotes (ppr con),
 	  ptext (sLit "does not have field"), quotes (ppr field)]
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 5b39132254..86a02a95d4 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -49,6 +49,7 @@ import TcEnv
 import TcRules
 import TcForeign
 import TcInstDcls
+import TcFldInsts
 import TcIface
 import TcMType
 import MkIface
@@ -331,7 +332,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
        --          (b) tcExtCoreBindings doesn't need anything
        --              (in fact, it might not even need to be in the scope of
        --               this tcg_env at all)
-   (tc_envs, _bndrs) <- getLocalNonValBinders emptyFsEnv {- no fixity decls -}
+   (_, tc_envs, _bndrs, _) <- getLocalNonValBinders emptyFsEnv {- no fixity decls -}
                                               (mkFakeGroup ldecls) ;
    setEnvs tc_envs $ do {
 
@@ -373,6 +374,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
                                 mg_tcs       = tcg_tcs tcg_env,
                                 mg_insts     = tcg_insts tcg_env,
                                 mg_fam_insts = tcg_fam_insts tcg_env,
+                                mg_axioms    = tcg_axioms tcg_env,
                                 mg_inst_env  = tcg_inst_env tcg_env,
                                 mg_fam_inst_env = tcg_fam_inst_env tcg_env,
                                 mg_patsyns      = [], -- TODO
@@ -602,6 +604,11 @@ tcRnHsBootDecls decls
              <- tcTyClsInstDecls emptyModDetails tycl_decls inst_decls deriv_decls
         ; setGblEnv tcg_env     $ do {
 
+                -- Create overloaded record field instances
+        ; traceTc "Tc3a (boot)" empty
+        ; tcg_env <- makeOverloadedRecFldInsts tycl_decls inst_decls
+        ; setGblEnv tcg_env       $ do {
+
                 -- Typecheck value declarations
         ; traceTc "Tc5" empty
         ; val_ids <- tcHsBootSigs val_binds
@@ -621,7 +628,7 @@ tcRnHsBootDecls decls
               }
 
         ; setGlobalTypeEnv gbl_env type_env2
-   }}
+   }}}
    ; traceTc "boot" (ppr lie); return gbl_env }
 
 badBootDecl :: String -> Located decl -> TcM ()
@@ -855,7 +862,7 @@ checkBootTyCon tc1 tc2
       =  dataConName c1 == dataConName c2
       && dataConIsInfix c1 == dataConIsInfix c2
       && eqListBy eqHsBang (dataConStrictMarks c1) (dataConStrictMarks c2)
-      && dataConFieldLabels c1 == dataConFieldLabels c2
+      && map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2)
       && eqType (dataConUserType c1) (dataConUserType c2)
 
     eqClosedFamilyAx (CoAxiom { co_ax_branches = branches1 })
@@ -967,6 +974,10 @@ tcTopSrcDecls boot_details
             <- tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls ;
         setGblEnv tcg_env       $ do {
 
+                -- Create overloaded record field instances
+        traceTc "Tc3a" empty ;
+        tcg_env <- makeOverloadedRecFldInsts tycl_decls inst_decls ;
+        setGblEnv tcg_env       $ do {
 
                 -- Generate Applicative/Monad proposal (AMP) warnings
         traceTc "Tc3b" empty ;
@@ -1038,7 +1049,7 @@ tcTopSrcDecls boot_details
 
         addUsedRdrNames fo_rdr_names ;
         return (tcg_env', tcl_env)
-    }}}}}}
+    }}}}}}}
   where
     gre_to_rdr_name :: GlobalRdrElt -> [RdrName] -> [RdrName]
         -- For *imported* newtype data constructors, we want to
@@ -1254,8 +1265,8 @@ runTcInteractive hsc_env thing_inside
                                                (extendFamInstEnvList (tcg_fam_inst_env gbl_env)
                                                                      ic_finsts)
                                                home_fam_insts
-                         , tcg_field_env    = RecFields (mkNameEnv con_fields)
-                                                        (mkNameSet (concatMap snd con_fields))
+                         , tcg_axioms       = ic_axs
+                         , tcg_field_env    = mkNameEnv con_fields
                               -- setting tcg_field_env is necessary
                               -- to make RecordWildCards work (test: ghci049)
                          , tcg_fix_env      = ic_fix_env icxt
@@ -1270,6 +1281,7 @@ runTcInteractive hsc_env thing_inside
     icxt                  = hsc_IC hsc_env
     (ic_insts, ic_finsts) = ic_instances icxt
     ty_things             = ic_tythings icxt
+    ic_axs                = ic_axioms icxt
 
     type_env1 = mkTypeEnvWithImplicits ty_things
     type_env  = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts)
@@ -1280,7 +1292,6 @@ runTcInteractive hsc_env thing_inside
                  | ATyCon t <- ty_things
                  , c <- tyConDataCons t ]
 
-
 #ifdef GHCI
 -- | The returned [Id] is the list of new Ids bound by this statement. It can
 -- be used to extend the InteractiveContext via extendInteractiveContext.
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 01c9d36cf3..0fb182f879 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -84,6 +84,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
  = do { errs_var     <- newIORef (emptyBag, emptyBag) ;
         tvs_var      <- newIORef emptyVarSet ;
         keep_var     <- newIORef emptyNameSet ;
+        used_sel_var <- newIORef emptyNameSet ;
         used_rdr_var <- newIORef Set.empty ;
         th_var       <- newIORef False ;
         th_splice_var<- newIORef False ;
@@ -119,7 +120,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                 tcg_src            = hsc_src,
                 tcg_rdr_env        = emptyGlobalRdrEnv,
                 tcg_fix_env        = emptyNameEnv,
-                tcg_field_env      = RecFields emptyNameEnv emptyNameSet,
+                tcg_field_env      = emptyNameEnv,
                 tcg_default        = Nothing,
                 tcg_type_env       = emptyNameEnv,
                 tcg_type_env_var   = type_env_var,
@@ -130,6 +131,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                 tcg_th_splice_used = th_splice_var,
                 tcg_exports        = [],
                 tcg_imports        = emptyImportAvails,
+                tcg_used_selectors = used_sel_var,
                 tcg_used_rdrnames  = used_rdr_var,
                 tcg_dus            = emptyDUs,
 
@@ -146,6 +148,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                 tcg_tcs            = [],
                 tcg_insts          = [],
                 tcg_fam_insts      = [],
+                tcg_axioms         = [],
                 tcg_rules          = [],
                 tcg_fords          = [],
                 tcg_vects          = [],
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 0355dab9c7..ffdef7c75d 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -26,7 +26,7 @@ module TcRnTypes(
         IfGblEnv(..), IfLclEnv(..),
 
         -- Ranamer types
-        ErrCtxt, RecFieldEnv(..),
+        ErrCtxt, RecFieldEnv,
         ImportAvails(..), emptyImportAvails, plusImportAvails,
         WhereFrom(..), mkModDeps,
 
@@ -90,8 +90,9 @@ import TcEvidence
 import Type
 import Class    ( Class )
 import TyCon    ( TyCon )
+import DataCon  ( DataCon, FieldLabel, dataConUserType, dataConOrigArgTys )
+import CoAxiom
 import ConLike  ( ConLike(..) )
-import DataCon  ( DataCon, dataConUserType, dataConOrigArgTys )
 import PatSyn   ( PatSyn, patSynId )
 import TcType
 import Annotations
@@ -255,6 +256,7 @@ data TcGblEnv
 
         tcg_dus :: DefUses,   -- ^ What is defined in this module and what is used.
         tcg_used_rdrnames :: TcRef (Set RdrName),
+        tcg_used_selectors :: TcRef NameSet,
           -- See Note [Tracking unused binding and imports]
 
         tcg_keep :: TcRef NameSet,
@@ -329,8 +331,12 @@ data TcGblEnv
         tcg_warns     :: Warnings,          -- ...Warnings and deprecations
         tcg_anns      :: [Annotation],      -- ...Annotations
         tcg_tcs       :: [TyCon],           -- ...TyCons and Classes
+                                                  -- (for data families, includes both
+                                                  -- family tycons and instance tycons)
         tcg_insts     :: [ClsInst],         -- ...Instances
         tcg_fam_insts :: [FamInst],         -- ...Family instances
+        tcg_axioms    :: [CoAxiom Branched], -- ...Axioms without family instances
+                                                   -- See Note [Instance scoping for OverloadedRecordFields] in TcFldInsts
         tcg_rules     :: [LRuleDecl Id],    -- ...Rules
         tcg_fords     :: [LForeignDecl Id], -- ...Foreign import & exports
         tcg_vects     :: [LVectDecl Id],    -- ...Vectorisation declarations
@@ -351,13 +357,9 @@ data TcGblEnv
 instance ContainsModule TcGblEnv where
     extractModule env = tcg_mod env
 
-data RecFieldEnv
-  = RecFields (NameEnv [Name])  -- Maps a constructor name *in this module*
-                                -- to the fields for that constructor
-              NameSet           -- Set of all fields declared *in this module*;
-                                -- used to suppress name-shadowing complaints
-                                -- when using record wild cards
-                                -- E.g.  let fld = e in C {..}
+type RecFieldEnv = NameEnv [FieldLabel]
+        -- Maps a constructor name *in this module*
+        -- to the fields for that constructor.
         -- This is used when dealing with ".." notation in record
         -- construction and pattern matching.
         -- The FieldEnv deals *only* with constructors defined in *this*
@@ -367,7 +369,7 @@ data RecFieldEnv
 
 Note [Tracking unused binding and imports]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-We gather two sorts of usage information
+We gather three sorts of usage information
  * tcg_dus (defs/uses)
       Records *defined* Names (local, top-level)
           and *used*    Names (local or imported)
@@ -387,6 +389,13 @@ We gather two sorts of usage information
       is esssential in deciding whether a particular import decl
       is unnecessary.  This info isn't present in Names.
 
+ * tcg_used_selectors
+      Records the Names of record selectors that are used during
+      typechecking (by the OverloadedRecordFields extension). These
+      may otherwise be missed from tcg_used_rdrnames as they need
+      not actually occur in the source text: they might be needed
+      only to satisfy a Has constraint, for example.
+
 
 %************************************************************************
 %*                                                                      *
@@ -1774,6 +1783,7 @@ data CtOrigin
 
   -- All the others are for *wanted* constraints
   | OccurrenceOf Name           -- Occurrence of an overloaded identifier
+  | OccurrenceOfRecSel RdrName  -- Occurrence of a record selector
   | AppOrigin                   -- An application of some kind
 
   | SpecPragOrigin Name         -- Specialisation pragma for identifier
@@ -1823,6 +1833,7 @@ pprO :: CtOrigin -> SDoc
 pprO (GivenOrigin sk)      = ppr sk
 pprO FlatSkolOrigin        = ptext (sLit "a given flatten-skolem")
 pprO (OccurrenceOf name)   = hsep [ptext (sLit "a use of"), quotes (ppr name)]
+pprO (OccurrenceOfRecSel name) = hsep [ptext (sLit "a use of the record selector"), quotes (ppr name)]
 pprO AppOrigin             = ptext (sLit "an application")
 pprO (SpecPragOrigin name) = hsep [ptext (sLit "a specialisation pragma for"), quotes (ppr name)]
 pprO (IPOccOrigin name)    = hsep [ptext (sLit "a use of implicit parameter"), quotes (ppr name)]
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 51f4945564..1d53a645b0 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -55,7 +55,9 @@ module TcSMonad (
 
     getInstEnvs, getFamInstEnvs,                -- Getting the environments
     getTopEnv, getGblEnv, getTcEvBinds, getUntouchables,
-    getTcEvBindsMap, getTcSTyBindsMap,
+    getTcEvBindsMap, getTcSTyBinds, getTcSTyBindsMap,
+
+    lookupFldInstDFun, lookupRepTyCon,
 
     lookupFlatEqn, newFlattenSkolem,            -- Flatten skolems
 
@@ -100,13 +102,14 @@ import HscTypes
 
 import Inst
 import InstEnv
-import FamInst
+import qualified FamInst
 import FamInstEnv
 
 import qualified TcRnMonad as TcM
 import qualified TcMType as TcM
 import qualified TcEnv as TcM
        ( checkWellStaged, topIdLvl, tcGetDefaultTys )
+import qualified RnEnv
 import Kind
 import TcType
 import DynFlags
@@ -116,6 +119,7 @@ import CoAxiom(sfMatchFam)
 import TcEvidence
 import Class
 import TyCon
+import FieldLabel
 
 import Name
 import RdrName (RdrName, GlobalRdrEnv)
@@ -1338,6 +1342,14 @@ getGblEnv = wrapTcS $ TcM.getGblEnv
 addUsedRdrNamesTcS :: [RdrName] -> TcS ()
 addUsedRdrNamesTcS names = wrapTcS  $ addUsedRdrNames names
 
+lookupFldInstDFun :: FieldLabelString -> TyCon -> TyCon
+                  -> Bool -> TcS (Maybe DFunId)
+lookupFldInstDFun lbl tc rep_tc which
+  = wrapTcS $ RnEnv.lookupFldInstDFun lbl tc rep_tc which
+
+lookupRepTyCon :: TyCon -> [Type] -> TcS TyCon
+lookupRepTyCon tc args = wrapTcS $ FamInst.lookupRepTyCon tc args
+
 -- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]
 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
@@ -1826,7 +1838,7 @@ maybeSym NotSwapped co = co
 
 
 matchOpenFam :: TyCon -> [Type] -> TcS (Maybe FamInstMatch)
-matchOpenFam tycon args = wrapTcS $ tcLookupFamInst tycon args
+matchOpenFam tycon args = wrapTcS $ FamInst.tcLookupFamInst tycon args
 
 matchFam :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType))
 -- Given (F tys) return (ty, co), where co :: F tys ~ ty
diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index 7fce241edb..09f8d2737a 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -1276,7 +1276,7 @@ reifyDataCon tys dc
        ; r_arg_tys <- reifyTypes arg_tys'
 
        ; let main_con | not (null fields)
-                      = TH.RecC name (zip3 (map reifyName fields) stricts r_arg_tys)
+                      = TH.RecC name (zip3 (map (reifyName . flSelector) fields) stricts r_arg_tys)
                       | dataConIsInfix dc
                       = ASSERT( length arg_tys == 2 )
                         TH.InfixC (s1,r_a1) name (s2,r_a2)
diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index f11295a7d0..7df909bf0d 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -56,6 +56,8 @@ import Module
 import Name
 import NameSet
 import NameEnv
+import RdrName
+import RnEnv
 import Outputable
 import Maybes
 import Unify
@@ -180,11 +182,11 @@ tcTyClGroup boot_details tyclds
 
 tcAddImplicits :: [TyThing] -> TcM TcGblEnv
 tcAddImplicits tyclss
- = tcExtendGlobalEnvImplicit implicit_things $
-   tcRecSelBinds rec_sel_binds
+ = do { rec_sel_binds <- mkRecSelBinds tyclss
+      ; tcExtendGlobalEnvImplicit implicit_things $
+            tcRecSelBinds rec_sel_binds }
  where
    implicit_things = concatMap implicitTyThings tyclss
-   rec_sel_binds   = mkRecSelBinds tyclss
 
 zipRecTyClss :: [(Name, Kind)]
              -> [TyThing]           -- Knot-tied
@@ -1152,8 +1154,9 @@ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl        -- Data types
               do { ctxt    <- tcHsContext hs_ctxt
                  ; details <- tcConArgs new_or_data hs_details
                  ; res_ty  <- tcConRes hs_res_ty
-                 ; let (is_infix, field_lbls, btys) = details
-                       (arg_tys, stricts)           = unzip btys
+                 ; field_lbls <- lookupConstructorFields (unLoc name)
+                 ; let (is_infix, btys)   = details
+                       (arg_tys, stricts) = unzip btys
                  ; return (ctxt, arg_tys, res_ty, is_infix, field_lbls, stricts) }
 
              -- Generalise the kind variables (returning quantified TcKindVars)
@@ -1186,20 +1189,19 @@ tcConDecl new_or_data rep_tycon tmpl_tvs res_tmpl        -- Data types
                 --      that way checkValidDataCon can complain if it's wrong.
        }
 
-tcConArgs :: NewOrData -> HsConDeclDetails Name -> TcM (Bool, [Name], [(TcType, HsBang)])
+tcConArgs :: NewOrData -> HsConDeclDetails Name -> TcM (Bool, [(TcType, HsBang)])
 tcConArgs new_or_data (PrefixCon btys)
   = do { btys' <- mapM (tcConArg new_or_data) btys
-       ; return (False, [], btys') }
+       ; return (False, btys') }
 tcConArgs new_or_data (InfixCon bty1 bty2)
   = do { bty1' <- tcConArg new_or_data bty1
        ; bty2' <- tcConArg new_or_data bty2
-       ; return (True, [], [bty1', bty2']) }
+       ; return (True, [bty1', bty2']) }
 tcConArgs new_or_data (RecCon fields)
   = do { btys' <- mapM (tcConArg new_or_data) btys
-       ; return (False, field_names, btys') }
+       ; return (False, btys') }
   where
-    field_names = map (unLoc . cd_fld_name) fields
-    btys        = map cd_fld_type fields
+    btys = map cd_fld_type fields
 
 tcConArg :: NewOrData -> LHsType Name -> TcM (TcType, HsBang)
 tcConArg new_or_data bty
@@ -1414,7 +1416,7 @@ checkValidTyCon tc
     data_cons = tyConDataCons tc
 
     groups = equivClasses cmp_fld (concatMap get_fields data_cons)
-    cmp_fld (f1,_) (f2,_) = f1 `compare` f2
+    cmp_fld (f1,_) (f2,_) = flLabel f1 `compare` flLabel f2
     get_fields con = dataConFieldLabels con `zip` repeat con
         -- dataConFieldLabels may return the empty list, which is fine
 
@@ -1442,15 +1444,16 @@ checkValidTyCon tc
         where
         (tvs1, _, _, res1) = dataConSig con1
         ts1 = mkVarSet tvs1
-        fty1 = dataConFieldType con1 label
+        fty1 = dataConFieldType con1 lbl
+        lbl = flLabel label
 
         checkOne (_, con2)    -- Do it bothways to ensure they are structurally identical
-            = do { checkFieldCompat label con1 con2 ts1 res1 res2 fty1 fty2
-                 ; checkFieldCompat label con2 con1 ts2 res2 res1 fty2 fty1 }
+            = do { checkFieldCompat lbl con1 con2 ts1 res1 res2 fty1 fty2
+                 ; checkFieldCompat lbl con2 con1 ts2 res2 res1 fty2 fty1 }
             where
                 (tvs2, _, _, res2) = dataConSig con2
                 ts2 = mkVarSet tvs2
-                fty2 = dataConFieldType con2 label
+                fty2 = dataConFieldType con2 lbl
     check_fields [] = panic "checkValidTyCon/check_fields []"
 
 checkValidClosedCoAxiom :: CoAxiom Branched -> TcM ()
@@ -1470,7 +1473,7 @@ checkValidClosedCoAxiom (CoAxiom { co_ax_branches = branches, co_ax_tc = tc })
               addErrTc $ inaccessibleCoAxBranch tc cur_branch
             ; return (cur_branch : prev_branches) }
 
-checkFieldCompat :: Name -> DataCon -> DataCon -> TyVarSet
+checkFieldCompat :: FieldLabelString -> DataCon -> DataCon -> TyVarSet
                  -> Type -> Type -> Type -> Type -> TcM ()
 checkFieldCompat fld con1 con2 tvs1 res1 res2 fty1 fty2
   = do  { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)
@@ -1821,35 +1824,35 @@ must bring the default method Ids into scope first (so they can be seen
 when typechecking the [d| .. |] quote, and typecheck them later.
 
 \begin{code}
-mkRecSelBinds :: [TyThing] -> HsValBinds Name
+mkRecSelBinds :: [TyThing] -> TcM (HsValBinds Name)
 -- NB We produce *un-typechecked* bindings, rather like 'deriving'
 --    This makes life easier, because the later type checking will add
 --    all necessary type abstractions and applications
 mkRecSelBinds tycons
-  = ValBindsOut [(NonRecursive, b) | b <- binds] sigs
-  where
-    (sigs, binds) = unzip rec_sels
-    rec_sels = map mkRecSelBind [ (tc,fld)
-                                | ATyCon tc <- tycons
-                                , fld <- tyConFields tc ]
+  = do { let rec_sels = map mkRecSelBind [ (tc, fl)
+                                         | ATyCon tc <- tycons
+                                         , fl <- tyConFieldLabels tc ]
+       ; let (sigs, binds) = unzip rec_sels
+       ; return $ ValBindsOut [(NonRecursive, b) | b <- binds] sigs }
 
 mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name)
-mkRecSelBind (tycon, sel_name)
+mkRecSelBind (tycon, fl)
   = (L loc (IdSig sel_id), unitBag (L loc sel_bind))
   where
-    loc    = getSrcSpan sel_name
-    sel_id = Var.mkExportedLocalVar rec_details sel_name
+    lbl      = flLabel fl
+    sel_name = flSelector fl
+    loc      = getSrcSpan sel_name
+    sel_id   = Var.mkExportedLocalVar rec_details sel_name
                                     sel_ty vanillaIdInfo
     rec_details = RecSelId { sel_tycon = tycon, sel_naughty = is_naughty }
 
     -- Find a representative constructor, con1
     all_cons     = tyConDataCons tycon
-    cons_w_field = [ con | con <- all_cons
-                   , sel_name `elem` dataConFieldLabels con ]
+    cons_w_field = tyConDataConsWithFields tycon [lbl]
     con1 = ASSERT( not (null cons_w_field) ) head cons_w_field
 
     -- Selector type; Note [Polymorphic selectors]
-    field_ty   = dataConFieldType con1 sel_name
+    field_ty   = dataConFieldType con1 lbl
     data_ty    = dataConOrigResTy con1
     data_tvs   = tyVarsOfType data_ty
     is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs)
@@ -1872,7 +1875,8 @@ mkRecSelBind (tycon, sel_name)
                                  (L loc (HsVar field_var))
     mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields)
     rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }
-    rec_field  = HsRecField { hsRecFieldId = sel_lname
+    rec_field  = HsRecField { hsRecFieldLbl = L loc (mkVarUnqual lbl)
+                            , hsRecFieldSel = Left sel_name
                             , hsRecFieldArg = L loc (VarPat field_var)
                             , hsRecPun = False }
     sel_lname = L loc sel_name
@@ -1899,14 +1903,7 @@ mkRecSelBind (tycon, sel_name)
     inst_tys = substTyVars (mkTopTvSubst (dataConEqSpec con1)) (dataConUnivTyVars con1)
 
     unit_rhs = mkLHsTupleExpr []
-    msg_lit = HsStringPrim $ unsafeMkByteString $
-              occNameString (getOccName sel_name)
-
----------------
-tyConFields :: TyCon -> [FieldLabel]
-tyConFields tc
-  | isAlgTyCon tc = nub (concatMap dataConFieldLabels (tyConDataCons tc))
-  | otherwise     = []
+    msg_lit = HsStringPrim (fastStringToByteString lbl)
 \end{code}
 
 Note [Polymorphic selectors]
@@ -2036,13 +2033,13 @@ tcAddClosedTypeFamilyDeclCtxt tc
     ctxt = ptext (sLit "In the equations for closed type family") <+>
            quotes (ppr tc)
 
-resultTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc
+resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc
 resultTypeMisMatch field_name con1 con2
   = vcat [sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2,
                 ptext (sLit "have a common field") <+> quotes (ppr field_name) <> comma],
           nest 2 $ ptext (sLit "but have different result types")]
 
-fieldTypeMisMatch :: Name -> DataCon -> DataCon -> SDoc
+fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc
 fieldTypeMisMatch field_name con1 con2
   = sep [ptext (sLit "Constructors") <+> ppr con1 <+> ptext (sLit "and") <+> ppr con2,
          ptext (sLit "give different types for field"), quotes (ppr field_name)]
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 08c7a627ce..d4be5e3181 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -52,6 +52,7 @@ module TcType (
   tcInstHeadTyNotSynonym, tcInstHeadTyAppAllTyVars,
   tcGetTyVar_maybe, tcGetTyVar,
   tcSplitSigmaTy, tcDeepSplitSigmaTy_maybe,
+  tcSplitRecordsArgs,
 
   ---------------------------------
   -- Predicates.
@@ -168,6 +169,7 @@ import VarEnv
 import PrelNames
 import TysWiredIn
 import BasicTypes
+import FieldLabel
 import Util
 import Maybes
 import ListSetOps
@@ -985,6 +987,13 @@ tcInstHeadTyAppAllTyVars ty
 
     get_tv (TyVarTy tv)  = Just tv      -- through synonyms
     get_tv _             = Nothing
+
+tcSplitRecordsArgs :: [Type] -> Maybe (FieldLabelString, TyCon, [Type])
+tcSplitRecordsArgs (r:n:_)
+  | Just lbl <- isStrLitTy n
+  , Just (tc, tys) <- tcSplitTyConApp_maybe r
+  = Just (lbl, tc, tys)
+tcSplitRecordsArgs _ = Nothing
 \end{code}
 
 \begin{code}
diff --git a/compiler/typecheck/TcValidity.lhs b/compiler/typecheck/TcValidity.lhs
index 84453eb700..c08f3558fd 100644
--- a/compiler/typecheck/TcValidity.lhs
+++ b/compiler/typecheck/TcValidity.lhs
@@ -35,6 +35,7 @@ import HsSyn            -- HsType
 import TcRnMonad        -- TcType, amongst others
 import FunDeps
 import Name
+import PrelNames
 import VarEnv
 import VarSet
 import ErrUtils
@@ -752,7 +753,7 @@ checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM ()
 checkValidInstHead ctxt clas cls_args
   = do { dflags <- getDynFlags
 
-       ; checkTc (clas `notElem` abstractClasses)
+       ; checkTc (classKey clas `notElem` abstractClasses)
                  (instTypeErr clas cls_args abstract_class_msg)
 
            -- Check language restrictions; 
@@ -808,8 +809,9 @@ checkValidInstHead ctxt clas cls_args
     abstract_class_msg =
                 text "The class is abstract, manual instances are not permitted."
 
-abstractClasses :: [ Class ]
-abstractClasses = [ coercibleClass ] -- See Note [Coercible Instances]
+abstractClasses :: [ Unique ]
+abstractClasses = [ classKey coercibleClass, recordHasClassNameKey, recordUpdClassNameKey ]
+                  -- See Note [Coercible Instances]
 
 instTypeErr :: Class -> [Type] -> SDoc -> SDoc
 instTypeErr cls tys msg
@@ -1108,7 +1110,11 @@ checkValidTyFamInst mb_clsinfo fam_tc
                     (CoAxBranch { cab_tvs = tvs, cab_lhs = typats
                                 , cab_rhs = rhs, cab_loc = loc })
   = setSrcSpan loc $ 
-    do { checkValidFamPats fam_tc tvs typats
+    do { -- Check it's not an OverloadedRecordFields family
+       ; checkTc (not (isRecordsFam fam_tc))
+                 (recordsFamInstErr fam_tc)
+
+       ; checkValidFamPats fam_tc tvs typats
 
          -- The right-hand side is a tau type
        ; checkValidMonoType rhs
@@ -1214,6 +1220,11 @@ famPatErr fam_tc tvs pats
 nestedMsg, smallerAppMsg :: SDoc
 nestedMsg     = ptext (sLit "Nested type family application")
 smallerAppMsg = ptext (sLit "Application is no smaller than the instance head")
+
+recordsFamInstErr :: TyCon -> SDoc
+recordsFamInstErr fam_tc
+  = hang (ptext (sLit "Illegal type instance declaration for") <+> quotes (ppr fam_tc))
+       2 (ptext (sLit "(Use -XOverloadedRecordFields instead.)"))
 \end{code}
 
 %************************************************************************