Refactor renaming of operators/sections to fix DuplicateRecordFields bugs

A variety of panics were possible because the get_op function in
RnTypes didn't handle the possibility that its argument might be an
ambiguous record field. I've made its return type more informative to
correctly handle occurrences of record fields.  Fixes Trac #13132.

Test Plan: new test
overloadedrecflds/should_fail/T13132_duplicaterecflds

Reviewers: bgamari, simonpj, austin

Reviewed By: bgamari

Subscribers: thomie

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

4 files changed, 68 insertions, 22 deletions

diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index 9cf78c2338..b74064751d 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -1160,7 +1160,7 @@ mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
             -> RnM (HsType Name)
 mk_hs_op_ty mk1 op1 fix1 ty1
             mk2 op2 fix2 ty21 ty22 loc2
-  | nofix_error     = do { precParseErr (op1,fix1) (op2,fix2)
+  | nofix_error     = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2)
                          ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
   | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22)))
   | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
@@ -1194,7 +1194,7 @@ mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
 --      (- neg_arg) `op` e2
 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
   | nofix_error
-  = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
+  = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2)
        return (OpApp e1 op2 fix2 e2)
 
   | associate_right
@@ -1208,7 +1208,7 @@ mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
 --      e1 `op` - neg_arg
 mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _))     -- NegApp can occur on the right
   | not associate_right                 -- We *want* right association
-  = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
+  = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity)
        return (OpApp e1 op1 fix1 e2)
   where
     (_, associate_right) = compareFixity fix1 negateFixity
@@ -1222,12 +1222,26 @@ mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
     return (OpApp e1 op fix e2)
 
 ----------------------------
-get_op :: LHsExpr Name -> Name
+
+-- | Name of an operator in an operator application or section
+data OpName = NormalOp Name         -- ^ A normal identifier
+            | NegateOp              -- ^ Prefix negation
+            | UnboundOp UnboundVar  -- ^ An unbound indentifier
+            | RecFldOp (AmbiguousFieldOcc Name)
+              -- ^ A (possibly ambiguous) record field occurrence
+
+instance Outputable OpName where
+  ppr (NormalOp n)   = ppr n
+  ppr NegateOp       = ppr negateName
+  ppr (UnboundOp uv) = ppr uv
+  ppr (RecFldOp fld) = ppr fld
+
+get_op :: LHsExpr Name -> OpName
 -- An unbound name could be either HsVar or HsUnboundVar
 -- See RnExpr.rnUnboundVar
-get_op (L _ (HsVar (L _ n)))   = n
-get_op (L _ (HsUnboundVar uv)) = mkUnboundName (unboundVarOcc uv)
-get_op (L _ (HsRecFld (Unambiguous _ n))) = n
+get_op (L _ (HsVar (L _ n)))   = NormalOp n
+get_op (L _ (HsUnboundVar uv)) = UnboundOp uv
+get_op (L _ (HsRecFld fld))    = RecFldOp fld
 get_op other                   = pprPanic "get_op" (ppr other)
 
 -- Parser left-associates everything, but
@@ -1289,7 +1303,8 @@ mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
         ; let (nofix_error, associate_right) = compareFixity fix1 fix2
 
         ; if nofix_error then do
-                { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
+                { precParseErr (NormalOp (unLoc op1),fix1)
+                               (NormalOp (unLoc op2),fix2)
                 ; return (ConPatIn op2 (InfixCon p1 p2)) }
 
           else if associate_right then do
@@ -1338,8 +1353,8 @@ checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
                   (op1_dir == InfixR && op_dir == InfixR && right ||
                    op1_dir == InfixL && op_dir == InfixL && not right))
 
-        info  = (op,        op_fix)
-        info1 = (unLoc op1, op1_fix)
+        info  = (NormalOp op,          op_fix)
+        info1 = (NormalOp (unLoc op1), op1_fix)
         (infol, infor) = if right then (info, info1) else (info1, info)
     unless inf_ok (precParseErr infol infor)
 
@@ -1354,23 +1369,33 @@ checkSectionPrec :: FixityDirection -> HsExpr RdrName
         -> LHsExpr Name -> LHsExpr Name -> RnM ()
 checkSectionPrec direction section op arg
   = case unLoc arg of
-        OpApp _ op fix _ -> go_for_it (get_op op) fix
-        NegApp _ _       -> go_for_it negateName  negateFixity
-        _                -> return ()
+        OpApp _ op' fix _ -> go_for_it (get_op op') fix
+        NegApp _ _        -> go_for_it NegateOp     negateFixity
+        _                 -> return ()
   where
     op_name = get_op op
     go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do
-          op_fix@(Fixity _ op_prec _) <- lookupFixityRn op_name
+          op_fix@(Fixity _ op_prec _) <- lookupFixityOp op_name
           unless (op_prec < arg_prec
                   || (op_prec == arg_prec && direction == assoc))
-                 (sectionPrecErr (op_name, op_fix)
+                 (sectionPrecErr (get_op op, op_fix)
                                  (arg_op, arg_fix) section)
 
+-- | Look up the fixity for an operator name.  Be careful to use
+-- 'lookupFieldFixityRn' for (possibly ambiguous) record fields
+-- (see Trac #13132).
+lookupFixityOp :: OpName -> RnM Fixity
+lookupFixityOp (NormalOp n)  = lookupFixityRn n
+lookupFixityOp NegateOp      = lookupFixityRn negateName
+lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName (unboundVarOcc u))
+lookupFixityOp (RecFldOp f)  = lookupFieldFixityRn f
+
+
 -- Precedence-related error messages
 
-precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
+precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM ()
 precParseErr op1@(n1,_) op2@(n2,_)
-  | isUnboundName n1 || isUnboundName n2
+  | is_unbound n1 || is_unbound n2
   = return ()     -- Avoid error cascade
   | otherwise
   = addErr $ hang (text "Precedence parsing error")
@@ -1378,9 +1403,9 @@ precParseErr op1@(n1,_) op2@(n2,_)
                ppr_opfix op2,
                text "in the same infix expression"])
 
-sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
+sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr RdrName -> RnM ()
 sectionPrecErr op@(n1,_) arg_op@(n2,_) section
-  | isUnboundName n1 || isUnboundName n2
+  | is_unbound n1 || is_unbound n2
   = return ()     -- Avoid error cascade
   | otherwise
   = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"),
@@ -1388,11 +1413,16 @@ sectionPrecErr op@(n1,_) arg_op@(n2,_) section
                       nest 2 (text "namely" <+> ppr_opfix arg_op)]),
          nest 4 (text "in the section:" <+> quotes (ppr section))]
 
-ppr_opfix :: (Name, Fixity) -> SDoc
+is_unbound :: OpName -> Bool
+is_unbound UnboundOp{} = True
+is_unbound _           = False
+
+ppr_opfix :: (OpName, Fixity) -> SDoc
 ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
    where
-     pp_op | op == negateName = text "prefix `-'"
-           | otherwise        = quotes (ppr op)
+     pp_op | NegateOp <- op = text "prefix `-'"
+           | otherwise      = quotes (ppr op)
+
 
 {- *****************************************************
 *                                                      *
diff --git a/testsuite/tests/overloadedrecflds/should_fail/T13132_duplicaterecflds.hs b/testsuite/tests/overloadedrecflds/should_fail/T13132_duplicaterecflds.hs
new file mode 100644
index 0000000000..a094bff05b
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/T13132_duplicaterecflds.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+module Bug where
+
+newtype ContT r m a = ContT { runContT :: (a -> m r) -> m r }
+newtype ContT2 r m a = ContT2 { runContT :: (a -> m r) -> m r }
+
+foo bar baz = (`runContT` bar.baz)
+
+woo x y = (`runContT` x `y` x)
diff --git a/testsuite/tests/overloadedrecflds/should_fail/T13132_duplicaterecflds.stderr b/testsuite/tests/overloadedrecflds/should_fail/T13132_duplicaterecflds.stderr
new file mode 100644
index 0000000000..391ccde4c1
--- /dev/null
+++ b/testsuite/tests/overloadedrecflds/should_fail/T13132_duplicaterecflds.stderr
@@ -0,0 +1,6 @@
+
+T13132_duplicaterecflds.hs:9:11: error:
+    The operator ‘runContT’ [infixl 9] of a section
+        must have lower precedence than that of the operand,
+          namely ‘y’ [infixl 9]
+        in the section: ‘`runContT` x `y` x’
diff --git a/testsuite/tests/overloadedrecflds/should_fail/all.T b/testsuite/tests/overloadedrecflds/should_fail/all.T
index 95a2d9b81e..f036ad0b63 100644
--- a/testsuite/tests/overloadedrecflds/should_fail/all.T
+++ b/testsuite/tests/overloadedrecflds/should_fail/all.T
@@ -21,4 +21,5 @@ test('overloadedlabelsfail01', normal, compile_fail, [''])
 test('T11103', normal, compile_fail, [''])
 test('T11167_ambiguous_fixity', [], multimod_compile_fail,
      ['T11167_ambiguous_fixity', ''])
+test('T13132_duplicaterecflds', normal, compile_fail, [''])
 test('NoParent', normal, compile_fail, [''])