Commit 2484d4da authored by Adam Gundry's avatar Adam Gundry Committed by Ben Gamari
Browse files

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
parent 6626242b
...@@ -1160,7 +1160,7 @@ mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name) ...@@ -1160,7 +1160,7 @@ mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
-> RnM (HsType Name) -> RnM (HsType Name)
mk_hs_op_ty mk1 op1 fix1 ty1 mk_hs_op_ty mk1 op1 fix1 ty1
mk2 op2 fix2 ty21 ty22 loc2 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))) } ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) }
| associate_right = 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) | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)
...@@ -1194,7 +1194,7 @@ mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2 ...@@ -1194,7 +1194,7 @@ mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
-- (- neg_arg) `op` e2 -- (- neg_arg) `op` e2
mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
| nofix_error | nofix_error
= do precParseErr (negateName,negateFixity) (get_op op2,fix2) = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2)
return (OpApp e1 op2 fix2 e2) return (OpApp e1 op2 fix2 e2)
| associate_right | associate_right
...@@ -1208,7 +1208,7 @@ mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2 ...@@ -1208,7 +1208,7 @@ mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2
-- e1 `op` - neg_arg -- e1 `op` - neg_arg
mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right
| not associate_right -- We *want* right association | 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) return (OpApp e1 op1 fix1 e2)
where where
(_, associate_right) = compareFixity fix1 negateFixity (_, associate_right) = compareFixity fix1 negateFixity
...@@ -1222,12 +1222,26 @@ mkOpAppRn e1 op fix e2 -- Default case, no rearrangment ...@@ -1222,12 +1222,26 @@ mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
return (OpApp e1 op fix e2) 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 -- An unbound name could be either HsVar or HsUnboundVar
-- See RnExpr.rnUnboundVar -- See RnExpr.rnUnboundVar
get_op (L _ (HsVar (L _ n))) = n get_op (L _ (HsVar (L _ n))) = NormalOp n
get_op (L _ (HsUnboundVar uv)) = mkUnboundName (unboundVarOcc uv) get_op (L _ (HsUnboundVar uv)) = UnboundOp uv
get_op (L _ (HsRecFld (Unambiguous _ n))) = n get_op (L _ (HsRecFld fld)) = RecFldOp fld
get_op other = pprPanic "get_op" (ppr other) get_op other = pprPanic "get_op" (ppr other)
-- Parser left-associates everything, but -- Parser left-associates everything, but
...@@ -1289,7 +1303,8 @@ mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 ...@@ -1289,7 +1303,8 @@ mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2
; let (nofix_error, associate_right) = compareFixity fix1 fix2 ; let (nofix_error, associate_right) = compareFixity fix1 fix2
; if nofix_error then do ; 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)) } ; return (ConPatIn op2 (InfixCon p1 p2)) }
else if associate_right then do else if associate_right then do
...@@ -1338,8 +1353,8 @@ checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do ...@@ -1338,8 +1353,8 @@ checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
(op1_dir == InfixR && op_dir == InfixR && right || (op1_dir == InfixR && op_dir == InfixR && right ||
op1_dir == InfixL && op_dir == InfixL && not right)) op1_dir == InfixL && op_dir == InfixL && not right))
info = (op, op_fix) info = (NormalOp op, op_fix)
info1 = (unLoc op1, op1_fix) info1 = (NormalOp (unLoc op1), op1_fix)
(infol, infor) = if right then (info, info1) else (info1, info) (infol, infor) = if right then (info, info1) else (info1, info)
unless inf_ok (precParseErr infol infor) unless inf_ok (precParseErr infol infor)
...@@ -1354,23 +1369,33 @@ checkSectionPrec :: FixityDirection -> HsExpr RdrName ...@@ -1354,23 +1369,33 @@ checkSectionPrec :: FixityDirection -> HsExpr RdrName
-> LHsExpr Name -> LHsExpr Name -> RnM () -> LHsExpr Name -> LHsExpr Name -> RnM ()
checkSectionPrec direction section op arg checkSectionPrec direction section op arg
= case unLoc arg of = case unLoc arg of
OpApp _ op fix _ -> go_for_it (get_op op) fix OpApp _ op' fix _ -> go_for_it (get_op op') fix
NegApp _ _ -> go_for_it negateName negateFixity NegApp _ _ -> go_for_it NegateOp negateFixity
_ -> return () _ -> return ()
where where
op_name = get_op op op_name = get_op op
go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do 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 unless (op_prec < arg_prec
|| (op_prec == arg_prec && direction == assoc)) || (op_prec == arg_prec && direction == assoc))
(sectionPrecErr (op_name, op_fix) (sectionPrecErr (get_op op, op_fix)
(arg_op, arg_fix) section) (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 -- Precedence-related error messages
precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM () precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM ()
precParseErr op1@(n1,_) op2@(n2,_) precParseErr op1@(n1,_) op2@(n2,_)
| isUnboundName n1 || isUnboundName n2 | is_unbound n1 || is_unbound n2
= return () -- Avoid error cascade = return () -- Avoid error cascade
| otherwise | otherwise
= addErr $ hang (text "Precedence parsing error") = addErr $ hang (text "Precedence parsing error")
...@@ -1378,9 +1403,9 @@ precParseErr op1@(n1,_) op2@(n2,_) ...@@ -1378,9 +1403,9 @@ precParseErr op1@(n1,_) op2@(n2,_)
ppr_opfix op2, ppr_opfix op2,
text "in the same infix expression"]) 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 sectionPrecErr op@(n1,_) arg_op@(n2,_) section
| isUnboundName n1 || isUnboundName n2 | is_unbound n1 || is_unbound n2
= return () -- Avoid error cascade = return () -- Avoid error cascade
| otherwise | otherwise
= addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"), = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"),
...@@ -1388,11 +1413,16 @@ sectionPrecErr op@(n1,_) arg_op@(n2,_) section ...@@ -1388,11 +1413,16 @@ sectionPrecErr op@(n1,_) arg_op@(n2,_) section
nest 2 (text "namely" <+> ppr_opfix arg_op)]), nest 2 (text "namely" <+> ppr_opfix arg_op)]),
nest 4 (text "in the section:" <+> quotes (ppr section))] 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) ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
where where
pp_op | op == negateName = text "prefix `-'" pp_op | NegateOp <- op = text "prefix `-'"
| otherwise = quotes (ppr op) | otherwise = quotes (ppr op)
{- ***************************************************** {- *****************************************************
* * * *
......
{-# 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)
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’
...@@ -21,4 +21,5 @@ test('overloadedlabelsfail01', normal, compile_fail, ['']) ...@@ -21,4 +21,5 @@ test('overloadedlabelsfail01', normal, compile_fail, [''])
test('T11103', normal, compile_fail, ['']) test('T11103', normal, compile_fail, [''])
test('T11167_ambiguous_fixity', [], multimod_compile_fail, test('T11167_ambiguous_fixity', [], multimod_compile_fail,
['T11167_ambiguous_fixity', '']) ['T11167_ambiguous_fixity', ''])
test('T13132_duplicaterecflds', normal, compile_fail, [''])
test('NoParent', normal, compile_fail, ['']) test('NoParent', normal, compile_fail, [''])
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment