Disambiguate record selectors by type signature

This makes DuplicateRecordFields more liberal in when it will
accept ambiguous record selectors, making use of type information in a
similar way to updates. See Note [Disambiguating record fields] for more
details. I've also refactored how record updates are disambiguated.

Test Plan: New and amended tests in overloadedrecflds

Reviewers: simonpj, goldfire, bgamari, austin

Subscribers: thomie

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

22 files changed, 336 insertions, 127 deletions

diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs
index f47843aa06..2e278fd2ca 100644
--- a/compiler/deSugar/DsExpr.hs
+++ b/compiler/deSugar/DsExpr.hs
@@ -711,7 +711,7 @@ dsExpr (EViewPat      {})  = panic "dsExpr:EViewPat"
 dsExpr (ELazyPat      {})  = panic "dsExpr:ELazyPat"
 dsExpr (HsType        {})  = panic "dsExpr:HsType"
 dsExpr (HsDo          {})  = panic "dsExpr:HsDo"
-dsExpr (HsSingleRecFld{})  = panic "dsExpr: HsSingleRecFld"
+dsExpr (HsRecFld      {})  = panic "dsExpr:HsRecFld"
 
 
 findField :: [LHsRecField Id arg] -> Name -> [arg]
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index ad1d5016cc..90dcea427e 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -1073,6 +1073,10 @@ repE (HsVar x)            =
                                ; return (MkC e') } }
 repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
 
+repE e@(HsRecFld f) = case f of
+  Unambiguous _ x -> repE (HsVar x)
+  Ambiguous{}     -> notHandled "Ambiguous record selectors" (ppr e)
+
         -- Remember, we're desugaring renamer output here, so
         -- HsOverlit can definitely occur
 repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
@@ -1241,7 +1245,7 @@ repUpdFields = repList fieldExpQTyConName rep_fld
       Unambiguous _ sel_name -> do { fn <- lookupLOcc (L l sel_name)
                                    ; e  <- repLE (hsRecFieldArg fld)
                                    ; repFieldExp fn e }
-      _                      -> notHandled "ambiguous record updates" (ppr fld)
+      _                      -> notHandled "Ambiguous record updates" (ppr fld)
 
 
 
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index 0b62d1f2c8..84264b448f 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -135,7 +135,7 @@ data HsExpr id
                              -- Turned into HsVar by type checker, to support deferred
                              --   type errors.  (The HsUnboundVar only has an OccName.)
 
-  | HsSingleRecFld (FieldOcc id) -- ^ Variable that corresponds to a record selector
+  | HsRecFld (AmbiguousFieldOcc id) -- ^ Variable pointing to record selector
 
   | HsIPVar   HsIPName       -- ^ Implicit parameter
   | HsOverLit (HsOverLit id) -- ^ Overloaded literals
@@ -801,7 +801,7 @@ ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
 ppr_expr (HsArrForm op _ args)
   = hang (ptext (sLit "(|") <+> ppr_lexpr op)
          4 (sep (map (pprCmdArg.unLoc) args) <+> ptext (sLit "|)"))
-ppr_expr (HsSingleRecFld f) = ppr f
+ppr_expr (HsRecFld f) = ppr f
 
 pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc
 pprExternalSrcLoc (StringLiteral _ src,(n1,n2),(n3,n4))
@@ -853,7 +853,7 @@ hsExprNeedsParens (HsRnBracketOut {}) = False
 hsExprNeedsParens (HsTcBracketOut {}) = False
 hsExprNeedsParens (HsDo sc _ _)
        | isListCompExpr sc            = False
-hsExprNeedsParens (HsSingleRecFld{})  = False
+hsExprNeedsParens (HsRecFld{})        = False
 hsExprNeedsParens _ = True
 
 
@@ -866,7 +866,7 @@ isAtomicHsExpr (HsIPVar {})      = True
 isAtomicHsExpr (HsUnboundVar {}) = True
 isAtomicHsExpr (HsWrap _ e)      = isAtomicHsExpr e
 isAtomicHsExpr (HsPar e)         = isAtomicHsExpr (unLoc e)
-isAtomicHsExpr (HsSingleRecFld{}) = True
+isAtomicHsExpr (HsRecFld{})      = True
 isAtomicHsExpr _                 = False
 
 {-
diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index b37d836403..3fd6f73202 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -324,6 +324,8 @@ data HsRecField' id arg = HsRecField {
 -- The typechecker will determine the particular selector:
 --
 --     hsRecFieldLbl = Unambiguous "x" $sel:x:MkS  :: AmbiguousFieldOcc Id
+--
+-- See also Note [Disambiguating record fields] in TcExpr.
 
 hsRecFields :: HsRecFields id arg -> [PostRn id id]
 hsRecFields rbinds = map (unLoc . hsRecFieldSel . unLoc) (rec_flds rbinds)
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index 17e1050691..73f961c84b 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -587,7 +587,8 @@ mkFieldOcc rdr = FieldOcc rdr PlaceHolder
 -- (for unambiguous occurrences) or the typechecker (for ambiguous
 -- occurrences).
 --
--- See Note [HsRecField and HsRecUpdField] in HsPat
+-- See Note [HsRecField and HsRecUpdField] in HsPat and
+-- Note [Disambiguating record fields] in TcExpr.
 data AmbiguousFieldOcc name
   = Unambiguous RdrName (PostRn name name)
   | Ambiguous   RdrName (PostTc name name)
@@ -615,7 +616,7 @@ unambiguousFieldOcc :: AmbiguousFieldOcc Id -> FieldOcc Id
 unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel
 unambiguousFieldOcc (Ambiguous   rdr sel) = FieldOcc rdr sel
 
-ambiguousFieldOcc :: FieldOcc Id -> AmbiguousFieldOcc Id
+ambiguousFieldOcc :: FieldOcc name -> AmbiguousFieldOcc name
 ambiguousFieldOcc (FieldOcc rdr sel) = Unambiguous rdr sel
 
 {-
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index 1ed55ba64b..0404013f0f 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -16,6 +16,7 @@ module RnEnv (
         lookupGlobalOccRn, lookupGlobalOccRn_maybe,
         lookupOccRn_overloaded, lookupGlobalOccRn_overloaded,
         reportUnboundName, unknownNameSuggestions,
+        addNameClashErrRn,
 
         HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
         lookupSigCtxtOccRn,
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index b4c63f3d93..e633f523c8 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -94,7 +94,8 @@ rnUnboundVar v
                 ; return (HsVar n, emptyFVs) } }
 
 rnExpr (HsVar v)
-  = do { mb_name <- lookupOccRn_overloaded False v
+  = do { opt_DuplicateRecordFields <- xoptM Opt_DuplicateRecordFields
+       ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v
        ; case mb_name of {
            Nothing -> rnUnboundVar v ;
            Just (Left name)
@@ -104,9 +105,11 @@ rnExpr (HsVar v)
 
               | otherwise
               -> finishHsVar name ;
-           Just (Right (f:fs)) -> ASSERT( null fs )
-                                  return (HsSingleRecFld f, unitFV (selectorFieldOcc f)) ;
-           Just (Right [])                 -> error "runExpr/HsVar" } }
+           Just (Right [f])        -> return (HsRecFld (ambiguousFieldOcc f)
+                                             , unitFV (selectorFieldOcc f)) ;
+           Just (Right fs@(_:_:_)) -> return (HsRecFld (Ambiguous v PlaceHolder)
+                                             , mkFVs (map selectorFieldOcc fs));
+           Just (Right [])         -> error "runExpr/HsVar" } }
 
 rnExpr (HsIPVar v)
   = return (HsIPVar v, emptyFVs)
diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs
index 6637156d2b..f5005740df 100644
--- a/compiler/rename/RnPat.hs
+++ b/compiler/rename/RnPat.hs
@@ -672,7 +672,7 @@ rnHsRecUpdFields flds
       = do { let lbl = rdrNameAmbiguousFieldOcc f
            ; sel <- setSrcSpan loc $
                       -- Defer renaming of overloaded fields to the typechecker
-                      -- See Note [Disambiguating record updates] in TcExpr
+                      -- See Note [Disambiguating record fields] in TcExpr
                       if overload_ok
                           then do { mb <- lookupGlobalOccRn_overloaded overload_ok lbl
                                   ; case mb of
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index fe9e0cb5bd..5295ed967f 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -28,7 +28,9 @@ import BasicTypes
 import Inst
 import TcBinds
 import FamInst          ( tcGetFamInstEnvs, tcLookupDataFamInst )
-import RnEnv            ( addUsedGRE )
+import FamInstEnv       ( FamInstEnvs )
+import RnEnv            ( addUsedGRE, addNameClashErrRn
+                        , unknownSubordinateErr )
 import TcEnv
 import TcArrows
 import TcMatches
@@ -693,7 +695,7 @@ following.
 tcExpr (RecordUpd record_expr rbnds _ _ _ _ ) res_ty
   = ASSERT( notNull rbnds )
     do  {
-        -- STEP -1  See Note [Disambiguating record updates]
+        -- STEP -1  See Note [Disambiguating record fields]
         -- After this we know that rbinds is unambiguous
         rbinds <- disambiguateRecordBinds record_expr rbnds res_ty
         ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds
@@ -826,7 +828,7 @@ tcExpr (RecordUpd record_expr rbnds _ _ _ _ ) res_ty
           RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
                     relevant_cons scrut_inst_tys result_inst_tys req_wrap }
 
-tcExpr (HsSingleRecFld f) res_ty
+tcExpr (HsRecFld f) res_ty
     = tcCheckRecSelId f res_ty
 
 {-
@@ -973,6 +975,14 @@ tcApp (L loc (HsVar fun)) args res_ty
   , [arg1,arg2] <- args
   = tcSeq loc fun arg1 arg2 res_ty
 
+-- Look for applications of ambiguous record selectors to arguments
+-- with type signatures, see Note [Disambiguating record fields]
+tcApp (L loc (HsRecFld (Ambiguous lbl _))) args@(L _ arg:_) res_ty
+  | Just sig_ty <- obviousSig arg
+  = do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
+       ; sel_name <- disambiguateSelector lbl sig_tc_ty
+       ; tcApp (L loc (HsRecFld (Unambiguous lbl sel_name))) args res_ty }
+
 tcApp fun args res_ty
   = do  {   -- Type-check the function
         ; (fun1, fun_tau) <- tcInferFun fun
@@ -1011,7 +1021,7 @@ tcInferFun (L loc (HsVar name))
                -- Don't wrap a context around a plain Id
        ; return (L loc fun, ty) }
 
-tcInferFun (L loc (HsSingleRecFld f))
+tcInferFun (L loc (HsRecFld f))
   = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f)
                -- Don't wrap a context around a plain Id
        ; return (L loc fun, ty) }
@@ -1108,19 +1118,27 @@ tcCheckId name res_ty
        ; addErrCtxtM (funResCtxt False (HsVar name) actual_res_ty res_ty) $
          tcWrapResult expr actual_res_ty res_ty }
 
-tcCheckRecSelId :: FieldOcc Name -> TcRhoType -> TcM (HsExpr TcId)
-tcCheckRecSelId f res_ty
+tcCheckRecSelId :: AmbiguousFieldOcc Name -> TcRhoType -> TcM (HsExpr TcId)
+tcCheckRecSelId f@(Unambiguous _ _) res_ty
   = do { (expr, actual_res_ty) <- tcInferRecSelId f
-       ; addErrCtxtM (funResCtxt False (HsSingleRecFld f) actual_res_ty res_ty) $
+       ; addErrCtxtM (funResCtxt False (HsRecFld f) actual_res_ty res_ty) $
          tcWrapResult expr actual_res_ty res_ty }
+tcCheckRecSelId (Ambiguous lbl _) res_ty
+  = case tcSplitFunTy_maybe res_ty of
+      Nothing       -> ambiguousSelector lbl
+      Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg
+                          ; tcCheckRecSelId (Unambiguous lbl sel_name) res_ty }
 
 ------------------------
 tcInferId :: Name -> TcM (HsExpr TcId, TcRhoType)
 -- Infer type, and deeply instantiate
 tcInferId n = tcInferIdWithOrig (OccurrenceOf n) (nameRdrName n) n
 
-tcInferRecSelId :: FieldOcc Name -> TcM (HsExpr TcId, TcRhoType)
-tcInferRecSelId (FieldOcc lbl sel) = tcInferIdWithOrig (OccurrenceOfRecSel lbl) lbl sel
+tcInferRecSelId :: AmbiguousFieldOcc Name -> TcM (HsExpr TcId, TcRhoType)
+tcInferRecSelId (Unambiguous lbl sel)
+  = tcInferIdWithOrig (OccurrenceOfRecSel lbl) lbl sel
+tcInferRecSelId (Ambiguous lbl _)
+  = ambiguousSelector lbl
 
 ------------------------
 tcInferIdWithOrig :: CtOrigin -> RdrName -> Name ->
@@ -1407,15 +1425,15 @@ getFixedTyVars upd_fld_occs univ_tvs cons
                       , tv `elemVarSet` fixed_tvs ]
 
 {-
-Note [Disambiguating record updates]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Disambiguating record fields]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 
 When the -XDuplicateRecordFields extension is used, and the renamer
-encounters a record update that it cannot immediately disambiguate
-(because it involves fields that belong to multiple datatypes), it
-will defer resolution of the ambiguity to the typechecker.  In this
-case, the `hsRecUpdFieldSel` field of the `HsRecUpdField` stores a
-list of candidate selectors.
+encounters a record selector or update that it cannot immediately
+disambiguate (because it involves fields that belong to multiple
+datatypes), it will defer resolution of the ambiguity to the
+typechecker.  In this case, the `Ambiguous` constructor of
+`AmbiguousFieldOcc` is used.
 
 Consider the following definitions:
 
@@ -1423,9 +1441,31 @@ Consider the following definitions:
         data T = MkT { foo :: Int, bar :: Int }
         data U = MkU { bar :: Int, baz :: Int }
 
-When the renamer sees an update of `foo`, it will not know which
-parent datatype is in use.  The `disambiguateRecordBinds` function
-tries to determine the parent in three ways:
+When the renamer sees `foo` as a selector or an update, it will not
+know which parent datatype is in use.
+
+For selectors, there are two possible ways to disambiguate:
+
+1. Check if the pushed-in type is a function whose domain is a
+   datatype, for example:
+
+       f s = (foo :: S -> Int) s
+
+       g :: T -> Int
+       g = foo
+
+    This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`.
+
+2. Check if the selector is applied to an argument that has a type
+   signature, for example:
+
+       h = foo (s :: S)
+
+    This is checked by `tcApp`.
+
+
+Updates are slightly more complex.  The `disambiguateRecordBinds`
+function tries to determine the parent datatype in three ways:
 
 1. Check for types that have all the fields being updated. For example:
 
@@ -1450,10 +1490,13 @@ tries to determine the parent in three ways:
 
         h x = (x :: T) { foo = 3 }
 
+
 Note that we do not look up the types of variables being updated, and
 no constraint-solving is performed, so for example the following will
 be rejected as ambiguous:
 
+     let bad (s :: S) = foo s
+
      let r :: T
          r = blah
      in r { foo = 3 }
@@ -1462,107 +1505,162 @@ be rejected as ambiguous:
 
 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.
+the type of the argument to a selector or the record expression being
+updated, 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. Moreover, this might change the behaviour of typechecker in
+non-obvious ways.
+
+See also Note [HsRecField and HsRecUpdField] in HsPat.
 -}
 
+-- Given a RdrName that refers to multiple record fields, and the type
+-- of its argument, try to determine the name of the selector that is
+-- meant.
+disambiguateSelector :: RdrName -> Type -> RnM Name
+disambiguateSelector rdr parent_type
+ = do { fam_inst_envs <- tcGetFamInstEnvs
+      ; case tyConOf fam_inst_envs parent_type of
+          Nothing -> ambiguousSelector rdr
+          Just p  ->
+            do { xs <- lookupParents rdr
+               ; let parent = RecSelData p
+               ; case lookup parent xs of
+                   Just gre -> do { addUsedGRE True gre
+                                  ; return (gre_name gre) }
+                   Nothing  -> failWithTc (fieldNotInType parent rdr) } }
+
+-- This field name really is ambiguous, so add a suitable "ambiguous
+-- occurrence" error, then give up.
+ambiguousSelector :: RdrName -> RnM a
+ambiguousSelector rdr
+  = do { env <- getGlobalRdrEnv
+       ; let gres = lookupGRE_RdrName rdr env
+       ; setErrCtxt [] $ addNameClashErrRn rdr gres
+       ; failM }
+
+-- Disambiguate the fields in a record update.
+-- See Note [Disambiguating record fields]
 disambiguateRecordBinds :: LHsExpr Name -> [LHsRecUpdField Name] -> Type
                                  -> TcM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]
 disambiguateRecordBinds record_expr rbnds res_ty
+    -- Are all the fields unambiguous?
   = case mapM isUnambiguous rbnds of
+                     -- If so, just skip to looking up the Ids
                      -- Always the case if DuplicateRecordFields is off
-     Just rbnds' -> lookupSelectors rbnds'
-     Nothing     -> do
-      { fam_inst_envs      <- tcGetFamInstEnvs
-      ; (rbnds_with_parents) <- fmap (zip rbnds) $ mapM getParents rbnds
-      ; (p :: RecSelParent) <- case possibleParents (map snd rbnds_with_parents) of
-               []  -> failWithTc (noPossibleParents rbnds)
-               [p] -> return p
-               _ | Just p <- tyConOf fam_inst_envs res_ty -> return (RecSelData p)
-               _ | Just sig_ty <- obviousSig (unLoc record_expr) ->
-                 do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
-                    ; case tyConOf fam_inst_envs sig_tc_ty of
-                        Just p  -> return (RecSelData p)
-                        Nothing -> failWithTc badOverloadedUpdate }
-               _ -> failWithTc badOverloadedUpdate
-      ; assignParent p rbnds_with_parents }
+      Just rbnds' -> mapM lookupSelector rbnds'
+      Nothing     -> -- If not, try to identify a single parent
+        do { fam_inst_envs <- tcGetFamInstEnvs
+             -- Look up the possible parents for each field
+           ; rbnds_with_parents <- getUpdFieldsParents
+           ; let possible_parents = map (map fst . snd) rbnds_with_parents
+             -- Identify a single parent
+           ; p <- identifyParent fam_inst_envs possible_parents
+             -- Pick the right selector with that parent for each field
+           ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents }
   where
+    -- Extract the selector name of a field update if it is unambiguous
     isUnambiguous :: LHsRecUpdField Name -> Maybe (LHsRecUpdField Name, Name)
     isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of
                         Unambiguous _ sel_name -> Just (x, sel_name)
                         Ambiguous{}            -> Nothing
 
-    lookupSelectors :: [(LHsRecUpdField Name, Name)] -> TcM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]
-    lookupSelectors = mapM look
-      where
-        look :: (LHsRecUpdField Name, Name) -> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name))
-        look (L l x, n) = do i <- tcLookupId n
-                             let L loc af = hsRecFieldLbl x
-                                 lbl      = rdrNameAmbiguousFieldOcc af
-                             return $ L l x { hsRecFieldLbl = L loc (Unambiguous lbl i) }
-
-    -- Extract the outermost TyCon of a type, if there is one; for
-    -- data families this is the representation tycon (because that's
-    -- where the fields live).
-    tyConOf fam_inst_envs ty = case tcSplitTyConApp_maybe ty of
-                                 Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))
-                                 Nothing        -> Nothing
-
-    -- Calculate the list of possible parent tycons, by taking the
-    -- intersection of the possibilities for each field.
-    possibleParents :: [[(RecSelParent, a)]] -> [RecSelParent]
-    possibleParents = foldr1 intersect . map (map fst)
-
-    -- Look up the parent tycon for each candidate record selector.
-    getParents :: LHsRecUpdField Name -> RnM [(RecSelParent, GlobalRdrElt)]
-    getParents (L _ fld) = do
-         { env <- getGlobalRdrEnv
-         ; let gres = lookupGRE_RdrName (unLoc (hsRecUpdFieldRdr fld)) env
-         ; mapM lookupParent gres }
-
+    -- Look up the possible parents and selector GREs for each field
+    getUpdFieldsParents :: TcM [(LHsRecUpdField Name
+                                , [(RecSelParent, GlobalRdrElt)])]
+    getUpdFieldsParents
+      = fmap (zip rbnds) $ mapM
+          (lookupParents . unLoc . hsRecUpdFieldRdr . unLoc)
+          rbnds
+
+    -- Given a the lists of possible parents for each field,
+    -- identify a single parent
+    identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
+    identifyParent fam_inst_envs possible_parents
+      = case foldr1 intersect possible_parents of
+        -- No parents for all fields: record update is ill-typed
+        []  -> failWithTc (noPossibleParents rbnds)
+        -- Exactly one datatype with all the fields: use that
+        [p] -> return p
+        -- Multiple possible parents: try harder to disambiguate
+        -- Can we get a parent TyCon from the pushed-in type?
+        _:_ | Just p <- tyConOf fam_inst_envs res_ty -> return (RecSelData p)
+        -- Does the expression being updated have a type signature?
+        -- If so, try to extract a parent TyCon from it
+            | Just sig_ty <- obviousSig (unLoc record_expr)
+            -> do { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
+                  ; case tyConOf fam_inst_envs sig_tc_ty of
+                      Just p  -> return (RecSelData p)
+                      Nothing -> failWithTc badOverloadedUpdate }
+        -- Nothing else we can try...
+        _ -> failWithTc badOverloadedUpdate
+
+    -- Make a field unambiguous by choosing the given parent.
+    -- Emits an error if the field cannot have that parent,
+    -- e.g. if the user writes
+    --     r { x = e } :: T
+    -- where T does not have field x.
+    pickParent :: RecSelParent
+               -> (LHsRecUpdField Name, [(RecSelParent, GlobalRdrElt)])
+               -> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name))
+    pickParent p (upd, xs)
+      = case lookup p xs of
+                      -- Phew! The parent is valid for this field.
+                      -- Previously ambiguous fields must be marked as
+                      -- used now that we know which one is meant, but
+                      -- unambiguous ones shouldn't be recorded again
+                      -- (giving duplicate deprecation warnings).
+          Just gre -> do { unless (null (tail xs)) $ do
+                             let L loc _ = hsRecFieldLbl (unLoc upd)
+                             setSrcSpan loc $ addUsedGRE True gre
+                         ; lookupSelector (upd, gre_name gre) }
+                      -- The field doesn't belong to this parent, so report
+                      -- an error but keep going through all the fields
+          Nothing  -> do { addErrTc (fieldNotInType p
+                                      (unLoc (hsRecUpdFieldRdr (unLoc upd))))
+                         ; lookupSelector (upd, gre_name (snd (head xs))) }
+
+    -- Given a (field update, selector name) pair, look up the
+    -- selector to give a field update with an unambiguous Id
+    lookupSelector :: (LHsRecUpdField Name, Name)
+                   -> TcM (LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name))
+    lookupSelector (L l upd, n)
+      = do { i <- tcLookupId n
+           ; let L loc af = hsRecFieldLbl upd
+                 lbl      = rdrNameAmbiguousFieldOcc af
+           ; return $ L l upd { hsRecFieldLbl = L loc (Unambiguous lbl i) } }
+
+
+-- Extract the outermost TyCon of a type, if there is one; for
+-- data families this is the representation tycon (because that's
+-- where the fields live).
+tyConOf :: FamInstEnvs -> Type -> Maybe TyCon
+tyConOf fam_inst_envs ty = case tcSplitTyConApp_maybe ty of
+  Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))
+  Nothing        -> Nothing
+
+-- For an ambiguous record field, find all the candidate record
+-- selectors (as GlobalRdrElts) and their parents.
+lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
+lookupParents rdr
+  = do { env <- getGlobalRdrEnv
+       ; let gres = lookupGRE_RdrName rdr env
+       ; mapM lookupParent gres }
+  where
     lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)
     lookupParent gre = do { id <- tcLookupId (gre_name gre)
-                          ; ASSERT(isRecordSelector id)
-                            return (recordSelectorTyCon id, gre) }
+                          ; if isRecordSelector id
+                              then return (recordSelectorTyCon id, gre)
+                              else failWithTc (notSelector (gre_name gre)) }
 
-    -- 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.
-    assignParent :: RecSelParent -> [(LHsRecUpdField Name, [(RecSelParent, GlobalRdrElt)])]
-                 -> RnM [LHsRecField' (AmbiguousFieldOcc Id) (LHsExpr Name)]
-    assignParent p rbnds
-      | null orphans = do rbnds'' <- mapM f rbnds'
-                          lookupSelectors rbnds''
-      | otherwise    = failWithTc (orphanFields p orphans)
-      where
-        (orphans, rbnds') = partitionWith pickParent rbnds
-
-        -- Previously ambiguous fields must be marked as used now that
-        -- we know which one is meant, but unambiguous ones shouldn't
-        -- be recorded again (giving duplicate deprecation warnings).
-        f (fld, gre, was_unambiguous)
-            = do { unless was_unambiguous $ do
-                   setSrcSpan (getLoc fld) $ addUsedGRE True gre
-                 ; return (fld, gre_name gre) }
-
-        -- Returns Right if fld can have parent p, or Left lbl if not.
-        pickParent :: (LHsRecUpdField Name, [(RecSelParent, GlobalRdrElt)])
-                   -> Either (Located RdrName) (LHsRecUpdField Name, GlobalRdrElt, Bool)
-        pickParent (fld, xs)
-            = case lookup p xs of
-                  Just gre -> Right (fld, gre, null (tail xs))
-                  Nothing  -> Left  (hsRecUpdFieldRdr (unLoc 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
+-- A type signature on the argument of an ambiguous record selector or
+-- the record expression in an update 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
 
 
 {-
@@ -1886,8 +1984,6 @@ noPossibleParents rbinds
 badOverloadedUpdate :: SDoc
 badOverloadedUpdate = ptext (sLit "Record update is ambiguous, and requires a type signature")
 
-orphanFields :: RecSelParent -> [Located RdrName] -> SDoc
-orphanFields p flds
-  = hang (ptext (sLit "Type") <+> ppr p <+>
-             ptext (sLit "does not have field") <> plural flds <> colon)
-       2 (pprQuotedList flds)
+fieldNotInType :: RecSelParent -> RdrName -> SDoc
+fieldNotInType p rdr
+  = unknownSubordinateErr (ptext (sLit "field of type") <+> quotes (ppr p)) rdr
diff --git a/testsuite/tests/overloadedrecflds/should_fail/all.T b/testsuite/tests/overloadedrecflds/should_fail/all.T
index fe7a85af70..5ff61e2735 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/all.T
+++ b/testsuite/tests/overloadedrecflds/should_fail/all.T
@@ -20,3 +20,5 @@ test('overloadedrecfldsfail11', normal, compile_fail, [''])
 test('overloadedrecfldsfail12',
      extra_clean(['OverloadedRecFldsFail12_A.hi', 'OverloadedRecFldsFail12_A.o']),
      multimod_compile_fail, ['overloadedrecfldsfail12', ''])
+test('overloadedrecfldsfail13', normal, compile_fail, [''])
+test('overloadedrecfldsfail14', normal, compile_fail, [''])
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.stderr
index fbf8a61176..4f51a6f6a9 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.stderr
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail01.stderr
@@ -1,16 +1,22 @@
 
-overloadedrecfldsfail01.hs:11:10:
+overloadedrecfldsfail01.hs:11:10: error:
     Record update is ambiguous, and requires a type signature
     In the expression: r {x = 3}
     In an equation for ‘upd1’: upd1 r = r {x = 3}
 
-overloadedrecfldsfail01.hs:14:10:
+overloadedrecfldsfail01.hs:14:10: error:
     No type has all these fields: ‘x’, ‘y’, ‘z’
     In the expression: r {x = 3, y = True, z = False}
     In an equation for ‘upd2’: upd2 r = r {x = 3, y = True, z = False}
 
-overloadedrecfldsfail01.hs:17:10:
-    Type U does not have fields: ‘w’, ‘x’
+overloadedrecfldsfail01.hs:17:10: error:
+    ‘w’ is not a (visible) field of type ‘U’
+    In the expression: r {w = True, x = 3, y = True} :: U
+    In an equation for ‘upd3’:
+        upd3 r = r {w = True, x = 3, y = True} :: U
+
+overloadedrecfldsfail01.hs:17:10: error:
+    ‘x’ is not a (visible) field of type ‘U’
     In the expression: r {w = True, x = 3, y = True} :: U
     In an equation for ‘upd3’:
         upd3 r = r {w = True, x = 3, y = True} :: U
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.hs
index 9d35bbe5dd..47f16da56d 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.hs
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail04.hs
@@ -10,3 +10,5 @@ x' = I.x
 
 -- But this is okay
 f e = e { I.x = True, I.y = False }
+
+main = return ()
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.stderr
index 8d892e380a..415099d79b 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.stderr
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.stderr
@@ -1,4 +1,4 @@
 
 overloadedrecfldsfail09.hs:9:11: error:
-    ambiguous record updates not (yet) handled by Template Haskell
+    Ambiguous record updates not (yet) handled by Template Haskell
       x = 3
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.hs
index 0516e43d63..56092b6ce0 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.hs
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.hs
@@ -9,4 +9,7 @@ data S = MkS { foo :: Bool }
 f :: T -> T
 f e = e { foo = 3, bar = 3 }
 
+s :: T -> Int
+s = foo
+
 main = return ()
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.stderr
index 65733ed6e8..f4a2f7bcfc 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.stderr
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail12.stderr
@@ -9,5 +9,9 @@ overloadedrecfldsfail12.hs:10:20: warning:
     In the use of ‘bar’ (imported from OverloadedRecFldsFail12_A):
     "Deprecated bar"
 
+overloadedrecfldsfail12.hs:13:5: warning:
+    In the use of ‘foo’ (imported from OverloadedRecFldsFail12_A):
+    "Deprecated foo"
+
 <no location info>: error: 
 Failing due to -Werror.
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail13.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail13.hs
new file mode 100644
index 0000000000..773bd60c8c
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail13.hs
@@ -0,0 +1,20 @@
+-- Test that giving a stupid type annotation to an ambiguous field
+-- yields a sensible error message
+
+{-# LANGUAGE DuplicateRecordFields #-}
+
+data S = MkS { x :: Int }
+data T = MkT { x :: Bool }
+data U = MkU
+
+a = x (MkU :: U)
+
+b = x (MkU :: a)
+
+c :: U -> Int
+c = x
+
+d :: a -> Int
+d = x
+
+main = return ()
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail13.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail13.stderr
new file mode 100644
index 0000000000..7c61ab769e
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail13.stderr
@@ -0,0 +1,22 @@
+
+overloadedrecfldsfail13.hs:10:5: error:
+    ‘x’ is not a (visible) field of type ‘U’
+    In the expression: x (MkU :: U)
+    In an equation for ‘a’: a = x (MkU :: U)
+
+overloadedrecfldsfail13.hs:12:5: error:
+    Ambiguous occurrence ‘x’
+    It could refer to either the field ‘x’,
+                             defined at overloadedrecfldsfail13.hs:7:16
+                          or the field ‘x’, defined at overloadedrecfldsfail13.hs:6:16
+
+overloadedrecfldsfail13.hs:15:5: error:
+    ‘x’ is not a (visible) field of type ‘U’
+    In the expression: x
+    In an equation for ‘c’: c = x
+
+overloadedrecfldsfail13.hs:18:5: error:
+    Ambiguous occurrence ‘x’
+    It could refer to either the field ‘x’,
+                             defined at overloadedrecfldsfail13.hs:7:16
+                          or the field ‘x’, defined at overloadedrecfldsfail13.hs:6:16
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail14.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail14.hs
new file mode 100644
index 0000000000..7785bb2403
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail14.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+
+-- Test that we deal gracefully with non-fields in updates
+
+data S = MkS { x :: Int }
+data T = MkT { x :: Int }
+
+y :: Bool
+y = True
+
+-- y isn't a field
+f r = r { x = 3, y = False }
+
+main = return ()
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail14.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail14.stderr
new file mode 100644
index 0000000000..908996f39e
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail14.stderr
@@ -0,0 +1,5 @@
+
+overloadedrecfldsfail14.hs:12:7: error:
+    ‘y’ is not a record selector
+    In the expression: r {x = 3, y = False}
+    In an equation for ‘f’: f r = r {x = 3, y = False}
diff --git a/testsuite/tests/overloadedrecflds/should_run/all.T b/testsuite/tests/overloadedrecflds/should_run/all.T
index 012916ab6a..3d7cef2c54 100644
--- a/testsuite/tests/overloadedrecflds/should_run/all.T
+++ b/testsuite/tests/overloadedrecflds/should_run/all.T
@@ -7,3 +7,4 @@ test('overloadedrecfldsrun02',
 test('overloadedrecfldsrun03', normal, compile_and_run, [''])
 test('overloadedrecfldsrun04', normal, compile_and_run, [''])
 test('overloadedrecfldsrun05', normal, compile_and_run, [''])
+test('overloadedrecfldsrun06', normal, compile_and_run, [''])
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun06.hs b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun06.hs
new file mode 100644
index 0000000000..92f870833d
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun06.hs
@@ -0,0 +1,21 @@
+-- Test that ambiguous selectors can be disambiguated by providing
+-- type signatures in various places
+
+{-# LANGUAGE DuplicateRecordFields #-}
+
+data S = MkS { x :: Int }
+data T = MkT { x :: Bool }
+data U a = MkU { x :: a }
+
+x_for_s :: S -> Int
+x_for_s = x
+
+x_for_t = x :: T -> Bool
+
+x_for_u u = x (u :: U Int)
+
+k :: (T -> Bool) -> Bool
+k f = f (MkT True)
+
+main = do print (x_for_s (MkS 42))
+          print (k x)
diff --git a/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun06.stdout b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun06.stdout
new file mode 100644
index 0000000000..abc4e3b957
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_run/overloadedrecfldsrun06.stdout
@@ -0,0 +1,2 @@
+42
+True