- rearrange = rnOpApp e11 op1 (OpApp e12 (HsVar op) e2)
- dont_rearrange = completeOpApp (rnOpApp e11 op1 e12) op (rnExpr e2)
-
-rnOpApp e1 op e2 = completeOpApp (rnExpr e1) op (rnExpr e2)
-
-completeOpApp rn_e1 op rn_e2
- = rn_e1 `thenRn` \ (e1', fvs1) ->
- rn_e2 `thenRn` \ (e2', fvs2) ->
- rnExpr (HsVar op) `thenRn` \ (op', fvs3) ->
- returnRn (OpApp e1' op' e2', fvs1 `unionNameSets` fvs2 `unionNameSets` fvs3)
-
-completeNegApp rn_expr
- = rn_expr `thenRn` \ (e', fvs_e) ->
- lookupImplicitOccRn negate_RDR `thenRn` \ neg ->
- returnRn (NegApp e' (HsVar neg), fvs_e)
+ (nofix_error, associate_right) = compareFixity fix1 fix2
+
+---------------------------
+-- (- neg_arg) `op` e2
+mkOpAppRn e1@(NegApp neg_arg neg_op) op2 fix2 e2
+ | nofix_error
+ = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenRn_`
+ returnRn (OpApp e1 op2 fix2 e2)
+
+ | associate_right
+ = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e ->
+ returnRn (NegApp new_e neg_op)
+ where
+ (nofix_error, associate_right) = compareFixity negateFixity fix2
+
+---------------------------
+-- e1 `op` - neg_arg
+mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg neg_op) -- NegApp can occur on the right
+ | not associate_right -- We *want* right association
+ = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_`
+ returnRn (OpApp e1 op1 fix1 e2)
+ where
+ (_, associate_right) = compareFixity fix1 negateFixity
+
+---------------------------
+-- Default case
+mkOpAppRn e1 op fix e2 -- Default case, no rearrangment
+ = ASSERT2( right_op_ok fix e2,
+ ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
+ )
+ returnRn (OpApp e1 op fix e2)
+
+-- Parser left-associates everything, but
+-- derived instances may have correctly-associated things to
+-- in the right operarand. So we just check that the right operand is OK
+right_op_ok fix1 (OpApp _ _ fix2 _)
+ = not error_please && associate_right
+ where
+ (error_please, associate_right) = compareFixity fix1 fix2
+right_op_ok fix1 other
+ = True
+
+-- Parser initially makes negation bind more tightly than any other operator
+mkNegAppRn neg_arg neg_op
+ =
+#ifdef DEBUG
+ getModeRn `thenRn` \ mode ->
+ ASSERT( not_op_app mode neg_arg )
+#endif
+ returnRn (NegApp neg_arg neg_op)
+
+not_op_app SourceMode (OpApp _ _ _ _) = False
+not_op_app mode other = True