Fix infix record field fixity (#11167 and #11173).

This extends D1585 with proper support for infix duplicate record
fields.  In particular, it is now possible to declare record fields as
infix in a module for which `DuplicateRecordFields` is enabled, fixity
is looked up correctly and a readable (although unpleasant) error
message is generated if multiple fields with different fixities are in
scope.

As a bonus, `DEPRECATED` and `WARNING` pragmas now work for
duplicate record fields. The pragma applies to all fields with the
given label.

In addition, a couple of minor `DuplicateRecordFields` bugs, which were
pinpointed by the `T11167_ambig` test case, are fixed by this patch:

  - Ambiguous infix fields can now be disambiguated by putting a type
    signature on the first argument

  - Polymorphic type constructor signatures (such as `ContT () IO a` in
    `T11167_ambig`) now work for disambiguation

Parts of this patch are from D1585 authored by @KaneTW.

Test Plan: New tests added.

Reviewers: KaneTW, bgamari, austin

Reviewed By: bgamari

Subscribers: thomie, hvr

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

GHC Trac Issues: #11167, #11173

22 files changed, 205 insertions, 33 deletions

diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index b15e4304f4..c5afa7410f 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -650,6 +650,7 @@ ppr_expr (HsApp e1 e2)
 ppr_expr (OpApp e1 op _ e2)
   = case unLoc op of
       HsVar (L _ v) -> pp_infixly v
+      HsRecFld f    -> pp_infixly f
       _             -> pp_prefixly
   where
     pp_e1 = pprDebugParendExpr e1   -- In debug mode, add parens
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index 5546a91843..8bcdc6aac1 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -723,6 +723,10 @@ deriving instance ( Data name
 instance Outputable (AmbiguousFieldOcc name) where
   ppr = ppr . rdrNameAmbiguousFieldOcc
 
+instance OutputableBndr (AmbiguousFieldOcc name) where
+  pprInfixOcc  = pprInfixOcc . rdrNameAmbiguousFieldOcc
+  pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc
+
 mkAmbiguousFieldOcc :: RdrName -> AmbiguousFieldOcc RdrName
 mkAmbiguousFieldOcc rdr = Unambiguous rdr PlaceHolder
 
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index b5abdf4374..3ffffa1f3b 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -807,8 +807,10 @@ data ModIface
                 -- Cached environments for easy lookup
                 -- These are computed (lazily) from other fields
                 -- and are not put into the interface file
-        mi_warn_fn   :: Name -> Maybe WarningTxt,        -- ^ Cached lookup for 'mi_warns'
-        mi_fix_fn    :: OccName -> Fixity,               -- ^ Cached lookup for 'mi_fixities'
+        mi_warn_fn   :: OccName -> Maybe WarningTxt,
+                -- ^ Cached lookup for 'mi_warns'
+        mi_fix_fn    :: OccName -> Fixity,
+                -- ^ Cached lookup for 'mi_fixities'
         mi_hash_fn   :: OccName -> Maybe (OccName, Fingerprint),
                 -- ^ Cached lookup for 'mi_decls'.
                 -- The @Nothing@ in 'mi_hash_fn' means that the thing
@@ -2008,12 +2010,12 @@ instance Binary Warnings where
                       return (WarnSome aa)
 
 -- | Constructs the cache for the 'mi_warn_fn' field of a 'ModIface'
-mkIfaceWarnCache :: Warnings -> Name -> Maybe WarningTxt
+mkIfaceWarnCache :: Warnings -> OccName -> Maybe WarningTxt
 mkIfaceWarnCache NoWarnings  = \_ -> Nothing
 mkIfaceWarnCache (WarnAll t) = \_ -> Just t
-mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs) . nameOccName
+mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs)
 
-emptyIfaceWarnCache :: Name -> Maybe WarningTxt
+emptyIfaceWarnCache :: OccName -> Maybe WarningTxt
 emptyIfaceWarnCache _ = Nothing
 
 plusWarns :: Warnings -> Warnings -> Warnings
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index 42a159f3d4..7466381cd5 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -21,7 +21,7 @@ module RnEnv (
         HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
         lookupSigCtxtOccRn,
 
-        lookupFixityRn, lookupTyFixityRn,
+        lookupFixityRn, lookupFieldFixityRn, lookupTyFixityRn,
         lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName,
         lookupConstructorFields,
         lookupSyntaxName, lookupSyntaxNames, lookupIfThenElse,
@@ -1043,10 +1043,10 @@ warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss })
 
 lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt
 lookupImpDeprec iface gre
-  = mi_warn_fn iface (gre_name gre) `mplus`  -- Bleat if the thing,
+  = mi_warn_fn iface (greOccName gre) `mplus`  -- Bleat if the thing,
     case gre_par gre of                      -- or its parent, is warn'd
-       ParentIs  p              -> mi_warn_fn iface p
-       FldParent { par_is = p } -> mi_warn_fn iface p
+       ParentIs  p              -> mi_warn_fn iface (nameOccName p)
+       FldParent { par_is = p } -> mi_warn_fn iface (nameOccName p)
        NoParent                 -> Nothing
        PatternSynonym           -> Nothing
 
@@ -1259,7 +1259,7 @@ lookupBindGroupOcc ctxt what rdr_name
 
 
 ---------------
-lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [Name]
+lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)]
 -- GHC extension: look up both the tycon and data con or variable.
 -- Used for top-level fixity signatures and deprecations.
 -- Complain if neither is in scope.
@@ -1270,7 +1270,8 @@ lookupLocalTcNames ctxt what rdr_name
        ; when (null names) $ addErr (head errs) -- Bleat about one only
        ; return names }
   where
-    lookup = lookupBindGroupOcc ctxt what
+    lookup rdr = do { name <- lookupBindGroupOcc ctxt what rdr
+                    ; return (fmap ((,) rdr) name) }
 
 dataTcOccs :: RdrName -> [RdrName]
 -- Return both the given name and the same name promoted to the TcClsName
@@ -1373,7 +1374,10 @@ lookupFixity is a bit strange.
 -}
 
 lookupFixityRn :: Name -> RnM Fixity
-lookupFixityRn name
+lookupFixityRn name = lookupFixityRn' name (nameOccName name)
+
+lookupFixityRn' :: Name -> OccName -> RnM Fixity
+lookupFixityRn' name occ
   | isUnboundName name
   = return (Fixity minPrecedence InfixL)
     -- Minimise errors from ubound names; eg
@@ -1412,8 +1416,8 @@ lookupFixityRn name
       -- and that's what we want.
       = do { iface <- loadInterfaceForName doc name
            ; traceRn (text "lookupFixityRn: looking up name in iface cache and found:" <+>
-                      vcat [ppr name, ppr $ mi_fix_fn iface (nameOccName name)])
-           ; return (mi_fix_fn iface (nameOccName name)) }
+                      vcat [ppr name, ppr $ mi_fix_fn iface occ])
+           ; return (mi_fix_fn iface occ) }
 
     doc = ptext (sLit "Checking fixity for") <+> ppr name
 
@@ -1421,6 +1425,43 @@ lookupFixityRn name
 lookupTyFixityRn :: Located Name -> RnM Fixity
 lookupTyFixityRn (L _ n) = lookupFixityRn n
 
+-- | Look up the fixity of a (possibly ambiguous) occurrence of a record field
+-- selector.  We use 'lookupFixityRn'' so that we can specifiy the 'OccName' as
+-- the field label, which might be different to the 'OccName' of the selector
+-- 'Name' if @DuplicateRecordFields@ is in use (Trac #1173). If there are
+-- multiple possible selectors with different fixities, generate an error.
+lookupFieldFixityRn :: AmbiguousFieldOcc Name -> RnM Fixity
+lookupFieldFixityRn (Unambiguous rdr n) = lookupFixityRn' n (rdrNameOcc rdr)
+lookupFieldFixityRn (Ambiguous   rdr _) = get_ambiguous_fixity rdr
+  where
+    get_ambiguous_fixity :: RdrName -> RnM Fixity
+    get_ambiguous_fixity rdr_name = do
+      traceRn $ text "get_ambiguous_fixity" <+> ppr rdr_name
+      rdr_env <- getGlobalRdrEnv
+      let elts =  lookupGRE_RdrName rdr_name rdr_env
+
+      fixities <- groupBy ((==) `on` snd) . zip elts
+                  <$> mapM lookup_gre_fixity elts
+
+      case fixities of
+        -- There should always be at least one fixity.
+        -- Something's very wrong if there are no fixity candidates, so panic
+        [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName"
+        [ (_, fix):_ ] -> return fix
+        ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs)
+                  >> return (Fixity minPrecedence InfixL)
+
+    lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre)
+
+    ambiguous_fixity_err rn ambigs
+      = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn)
+             , hang (text "Conflicts: ") 2 . vcat .
+               map format_ambig $ concat ambigs ]
+
+    format_ambig (elt, fix) = hang (ppr fix)
+                                 2 (pprNameProvenance elt)
+
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 5df96cf042..11d03f4d6a 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -150,9 +150,10 @@ rnExpr (OpApp e1 op  _ e2)
         -- more, so I've removed the test.  Adding HsPars in TcGenDeriv
         -- should prevent bad things happening.
         ; fixity <- case op' of
-                     L _ (HsVar (L _ n)) -> lookupFixityRn n
-                     _                   -> return (Fixity minPrecedence InfixL)
-                                       -- c.f. lookupFixity for unbound
+                      L _ (HsVar (L _ n)) -> lookupFixityRn n
+                      L _ (HsRecFld f)    -> lookupFieldFixityRn f
+                      _ -> return (Fixity minPrecedence InfixL)
+                           -- c.f. lookupFixity for unbound
 
         ; final_e <- mkOpAppRn e1' op' fixity e2'
         ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 0024304b3a..cfe5fc5c27 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -477,7 +477,7 @@ extendGlobalRdrEnvRn avails new_fixities
 
         ; rdr_env2 <- foldlM add_gre rdr_env1 new_gres
 
-        ; let fix_env' = foldl extend_fix_env fix_env new_names
+        ; let fix_env' = foldl extend_fix_env fix_env new_gres
               gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' }
 
         ; traceRn (text "extendGlobalRdrEnvRn 2" <+> (pprGlobalRdrEnv True rdr_env2))
@@ -487,13 +487,14 @@ extendGlobalRdrEnvRn avails new_fixities
     new_occs  = map nameOccName new_names
 
     -- If there is a fixity decl for the gre, add it to the fixity env
-    extend_fix_env fix_env name
+    extend_fix_env fix_env gre
       | Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ)
       = extendNameEnv fix_env name (FixItem occ fi)
       | otherwise
       = fix_env
       where
-        occ  = nameOccName name
+        name = gre_name gre
+        occ  = greOccName gre
 
     new_gres :: [GlobalRdrElt]  -- New LocalDef GREs, derived from avails
     new_gres = concatMap localGREsFromAvail avails
@@ -564,8 +565,8 @@ getLocalNonValBinders fixity_env
         ; val_avails <- mapM new_simple val_bndrs
 
         ; let avails    = concat nti_availss ++ val_avails
-              new_bndrs = availsToNameSet avails `unionNameSet`
-                          availsToNameSet tc_avails
+              new_bndrs = availsToNameSetWithSelectors avails `unionNameSet`
+                          availsToNameSetWithSelectors tc_avails
               flds      = concat nti_fldss ++ concat tc_fldss
         ; traceRn (text "getLocalNonValBinders 2" <+> ppr avails)
         ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 1579400fc2..b284ec8d88 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -287,7 +287,7 @@ rnSrcFixityDecls bndr_set fix_decls
       = setSrcSpan name_loc $
                     -- this lookup will fail if the definition isn't local
         do names <- lookupLocalTcNames sig_ctxt what rdr_name
-           return [ L name_loc name | name <- names ]
+           return [ L name_loc name | (_, name) <- names ]
     what = ptext (sLit "fixity signature")
 
 {-
@@ -325,7 +325,7 @@ rnSrcWarnDecls bndr_set decls'
        -- ensures that the names are defined locally
      = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)
                                 rdr_names
-          ; return [(nameOccName name, txt) | name <- names] }
+          ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }
 
    what = ptext (sLit "deprecation")
 
diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs
index 26e920ead9..853ef54c8a 100644
--- a/compiler/typecheck/TcExpr.hs
+++ b/compiler/typecheck/TcExpr.hs
@@ -379,6 +379,15 @@ tcExpr (OpApp arg1 op fix arg2) res_ty
                op' fix
                (mkLHsWrapCo co_a arg2') }
 
+  | (L loc (HsRecFld (Ambiguous lbl _))) <- op
+  , Just sig_ty <- obviousSig (unLoc arg1)
+    -- See Note [Disambiguating record fields]
+  = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
+       ; sel_name <- disambiguateSelector lbl sig_tc_ty
+       ; let op' = L loc (HsRecFld (Unambiguous lbl sel_name))
+       ; tcExpr (OpApp arg1 op' fix arg2) res_ty
+       }
+
   | otherwise
   = do { traceTc "Non Application rule" (ppr op)
        ; (op', op_ty) <- tcInferFun op
@@ -1739,11 +1748,14 @@ disambiguateRecordBinds record_expr record_tau rbnds res_ty
 
 -- 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).
+-- where the fields live).  Look inside sigma-types, so that
+--   tyConOf _ (forall a. Q => T a) = T
 tyConOf :: FamInstEnvs -> Type -> Maybe TyCon
-tyConOf fam_inst_envs ty = case tcSplitTyConApp_maybe ty of
+tyConOf fam_inst_envs ty0 = case tcSplitTyConApp_maybe ty of
   Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))
   Nothing        -> Nothing
+  where
+    (_, _, ty) = tcSplitSigmaTy ty0
 
 -- For an ambiguous record field, find all the candidate record
 -- selectors (as GlobalRdrElts) and their parents.
diff --git a/testsuite/tests/overloadedrecflds/should_compile/T11173.hs b/testsuite/tests/overloadedrecflds/should_compile/T11173.hs
new file mode 100644
index 0000000000..54b363869e
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_compile/T11173.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module T11173 where
+import T11173a (A(..))
+
+-- Check that the fixity declaration applied to the field 'foo' is used
+x b = b `foo` b `foo` 0
diff --git a/testsuite/tests/overloadedrecflds/should_compile/T11173a.hs b/testsuite/tests/overloadedrecflds/should_compile/T11173a.hs
new file mode 100644
index 0000000000..ae8c37f763
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_compile/T11173a.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module T11173a where
+
+data A = A { foo :: Int -> Int, bar :: Int -> Int }
+newtype B = B { foo :: Int -> Int }
+infixr 5 `foo`
+infixr 5 `bar`
+
+-- This is well-typed only if the fixity is correctly applied
+y b = b `bar` b `bar` 0
diff --git a/testsuite/tests/overloadedrecflds/should_compile/all.T b/testsuite/tests/overloadedrecflds/should_compile/all.T
new file mode 100644
index 0000000000..ea5baf899e
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_compile/all.T
@@ -0,0 +1 @@
+test('T11173', extra_clean(['T11173a.hi', 'T11173a.o']), multimod_compile, ['T11173', '-v0'])
diff --git a/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail11_A.hs b/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail11_A.hs
new file mode 100644
index 0000000000..9dbadc648c
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/OverloadedRecFldsFail11_A.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module OverloadedRecFldsFail11_A where
+
+{-# WARNING foo "Warning on a record field" #-}
+data S = MkS { foo :: Bool }
+data T = MkT { foo :: Int }
diff --git a/testsuite/tests/overloadedrecflds/should_fail/T11167_ambiguous_fixity.hs b/testsuite/tests/overloadedrecflds/should_fail/T11167_ambiguous_fixity.hs
new file mode 100644
index 0000000000..d4dd38edbb
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/T11167_ambiguous_fixity.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module T11167_ambiguous_fixity where
+import T11167_ambiguous_fixity_A
+import T11167_ambiguous_fixity_B
+
+x a = (a :: A) `foo` 0
diff --git a/testsuite/tests/overloadedrecflds/should_fail/T11167_ambiguous_fixity.stderr b/testsuite/tests/overloadedrecflds/should_fail/T11167_ambiguous_fixity.stderr
new file mode 100644
index 0000000000..26b8daa53d
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/T11167_ambiguous_fixity.stderr
@@ -0,0 +1,16 @@
+[1 of 3] Compiling T11167_ambiguous_fixity_B ( T11167_ambiguous_fixity_B.hs, T11167_ambiguous_fixity_B.o )
+[2 of 3] Compiling T11167_ambiguous_fixity_A ( T11167_ambiguous_fixity_A.hs, T11167_ambiguous_fixity_A.o )
+[3 of 3] Compiling T11167_ambiguous_fixity ( T11167_ambiguous_fixity.hs, T11167_ambiguous_fixity.o )
+
+T11167_ambiguous_fixity.hs:6:7: error:
+    Ambiguous fixity for record field ‘foo’
+    Conflicts:
+      infixr 3
+        imported from ‘T11167_ambiguous_fixity_A’ at T11167_ambiguous_fixity.hs:3:1-32
+        (and originally defined at T11167_ambiguous_fixity_A.hs:4:16-18)
+      infixr 3
+        imported from ‘T11167_ambiguous_fixity_A’ at T11167_ambiguous_fixity.hs:3:1-32
+        (and originally defined at T11167_ambiguous_fixity_A.hs:3:16-18)
+      infixl 5
+        imported from ‘T11167_ambiguous_fixity_B’ at T11167_ambiguous_fixity.hs:4:1-32
+        (and originally defined at T11167_ambiguous_fixity_B.hs:2:16-18)
diff --git a/testsuite/tests/overloadedrecflds/should_fail/T11167_ambiguous_fixity_A.hs b/testsuite/tests/overloadedrecflds/should_fail/T11167_ambiguous_fixity_A.hs
new file mode 100644
index 0000000000..cc5440de16
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/T11167_ambiguous_fixity_A.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module T11167_ambiguous_fixity_A where
+data A = MkA { foo :: Int -> Int }
+data C = MkC { foo :: Int -> Int }
+infixr 3 `foo`
diff --git a/testsuite/tests/overloadedrecflds/should_fail/T11167_ambiguous_fixity_B.hs b/testsuite/tests/overloadedrecflds/should_fail/T11167_ambiguous_fixity_B.hs
new file mode 100644
index 0000000000..927a336537
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/T11167_ambiguous_fixity_B.hs
@@ -0,0 +1,3 @@
+module T11167_ambiguous_fixity_B where
+data B = MkB { foo :: Int -> Int }
+infixl 5 `foo`
diff --git a/testsuite/tests/overloadedrecflds/should_fail/all.T b/testsuite/tests/overloadedrecflds/should_fail/all.T
index a9c7426c78..a1b8ccb4ad 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/all.T
+++ b/testsuite/tests/overloadedrecflds/should_fail/all.T
@@ -16,10 +16,16 @@ test('overloadedrecfldsfail10',
                  , 'OverloadedRecFldsFail10_B.hi', 'OverloadedRecFldsFail10_B.o'
                  , 'OverloadedRecFldsFail10_C.hi', 'OverloadedRecFldsFail10_C.o']),
      multimod_compile_fail, ['overloadedrecfldsfail10', ''])
-test('overloadedrecfldsfail11', normal, compile_fail, [''])
+test('overloadedrecfldsfail11',
+     extra_clean(['OverloadedRecFldsFail11_A.hi', 'OverloadedRecFldsFail11_A.o']),
+     multimod_compile_fail, ['overloadedrecfldsfail11', ''])
 test('overloadedrecfldsfail12',
      extra_clean(['OverloadedRecFldsFail12_A.hi', 'OverloadedRecFldsFail12_A.o']),
      multimod_compile_fail, ['overloadedrecfldsfail12', ''])
 test('overloadedrecfldsfail13', normal, compile_fail, [''])
 test('overloadedrecfldsfail14', normal, compile_fail, [''])
 test('overloadedlabelsfail01', normal, compile_fail, [''])
+test('T11167_ambiguous_fixity',
+     extra_clean([ 'T11167_ambiguous_fixity_A.hi', 'T11167_ambiguous_fixity_A.o'
+                 , 'T11167_ambiguous_fixity_B.hi', 'T11167_ambiguous_fixity_B.o' ]),
+     multimod_compile_fail, ['T11167_ambiguous_fixity', ''])
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.hs
index 9c5c145c94..c1c309a48a 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.hs
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE DuplicateRecordFields #-}
+{-# OPTIONS_GHC -Werror #-}
+import OverloadedRecFldsFail11_A
 
-{-# WARNING foo "No warnings for DRFs" #-}
-data S = MkS { foo :: Bool }
-data T = MkT { foo :: Int }
+main = print (foo (MkS True :: S))
diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.stderr b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.stderr
index 650456ccd0..771a46f10c 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.stderr
+++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail11.stderr
@@ -1,4 +1,9 @@
+[1 of 2] Compiling OverloadedRecFldsFail11_A ( OverloadedRecFldsFail11_A.hs, OverloadedRecFldsFail11_A.o )
+[2 of 2] Compiling Main             ( overloadedrecfldsfail11.hs, overloadedrecfldsfail11.o )
 
-overloadedrecfldsfail11.hs:3:13: error:
-    The deprecation for ‘foo’ lacks an accompanying binding
-      (The deprecation must be given where ‘foo’ is declared)
+overloadedrecfldsfail11.hs:5:15: warning:
+    In the use of ‘foo’ (imported from OverloadedRecFldsFail11_A):
+    "Warning on a record field"
+
+<no location info>: error:
+Failing due to -Werror.
diff --git a/testsuite/tests/rename/should_compile/T11167.hs b/testsuite/tests/rename/should_compile/T11167.hs
new file mode 100644
index 0000000000..644cc90bed
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/T11167.hs
@@ -0,0 +1,21 @@
+module T11167 where
+
+data SomeException
+
+newtype ContT r m a = ContT {runContT :: (a -> m r) -> m r}
+
+runContT' :: ContT r m a -> (a -> m r) -> m r
+runContT' = runContT
+
+catch_ :: IO a -> (SomeException -> IO a) -> IO a
+catch_ = undefined
+
+foo :: IO ()
+foo = (undefined :: ContT () IO a)
+        `runContT` (undefined :: a -> IO ())
+        `catch_` (undefined :: SomeException -> IO ())
+
+foo' :: IO ()
+foo' = (undefined :: ContT () IO a)
+         `runContT'` (undefined :: a -> IO ())
+         `catch_` (undefined :: SomeException -> IO ())
diff --git a/testsuite/tests/rename/should_compile/T11167_ambig.hs b/testsuite/tests/rename/should_compile/T11167_ambig.hs
new file mode 100644
index 0000000000..74df05e5ee
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/T11167_ambig.hs
@@ -0,0 +1,23 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module T11167_ambig where
+
+data SomeException
+
+newtype ContT r m a = ContT {runContT :: (a -> m r) -> m r}
+newtype ContT' r m a = ContT' {runContT :: (a -> m r) -> m r}
+
+runContT' :: ContT r m a -> (a -> m r) -> m r
+runContT' = runContT
+
+catch_ :: IO a -> (SomeException -> IO a) -> IO a
+catch_ = undefined
+
+foo :: IO ()
+foo = (undefined :: ContT () IO a)
+        `runContT` (undefined :: a -> IO ())
+        `catch_` (undefined :: SomeException -> IO ())
+
+foo' :: IO ()
+foo' = (undefined :: ContT () IO a)
+         `runContT'` (undefined :: a -> IO ())
+         `catch_` (undefined :: SomeException -> IO ())
diff --git a/testsuite/tests/rename/should_compile/all.T b/testsuite/tests/rename/should_compile/all.T
index 05bc2507d0..8c120cd4c2 100644
--- a/testsuite/tests/rename/should_compile/all.T
+++ b/testsuite/tests/rename/should_compile/all.T
@@ -230,3 +230,5 @@ test('T11164',
      extra_clean(['T11164a.hi', 'T11164a.o',
                   'T11164b.hi', 'T11164b.o']),
      multimod_compile, ['T11164', '-v0'])
+test('T11167', normal, compile, [''])
+test('T11167_ambig', normal, compile, [''])