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

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)
-> 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)
{- *****************************************************
* *
......
{-# 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, [''])
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, [''])
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