Commit 57217f68 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Improve error reporting for precedence errors

Adopt the suggestion of Trac #2993, and tidy up the reporting of
precedence parsing errors somewhat.
parent 1c15bee5
...@@ -23,7 +23,7 @@ import RnEnv ...@@ -23,7 +23,7 @@ import RnEnv
import TcRnMonad import TcRnMonad
import RdrName import RdrName
import PrelNames import PrelNames
import TypeRep ( funTyCon ) import TypeRep ( funTyConName )
import Name import Name
import SrcLoc import SrcLoc
import NameSet import NameSet
...@@ -32,6 +32,7 @@ import BasicTypes ( compareFixity, funTyFixity, negateFixity, ...@@ -32,6 +32,7 @@ import BasicTypes ( compareFixity, funTyFixity, negateFixity,
Fixity(..), FixityDirection(..) ) Fixity(..), FixityDirection(..) )
import Outputable import Outputable
import FastString import FastString
import Control.Monad ( unless )
#include "HsVersions.h" #include "HsVersions.h"
\end{code} \end{code}
...@@ -116,7 +117,7 @@ rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2) ...@@ -116,7 +117,7 @@ rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2)
; fix <- lookupTyFixityRn l_op' ; fix <- lookupTyFixityRn l_op'
; ty1' <- rnLHsType doc ty1 ; ty1' <- rnLHsType doc ty1
; ty2' <- rnLHsType doc ty2 ; ty2' <- rnLHsType doc ty2
; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) (ppr op') fix ty1' ty2' } ; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) op' fix ty1' ty2' }
rnHsType doc (HsParTy ty) = do rnHsType doc (HsParTy ty) = do
ty' <- rnLHsType doc ty ty' <- rnLHsType doc ty
...@@ -141,7 +142,7 @@ rnHsType doc (HsFunTy ty1 ty2) = do ...@@ -141,7 +142,7 @@ rnHsType doc (HsFunTy ty1 ty2) = do
-- when we find return :: forall m. Monad m -> forall a. a -> m a -- when we find return :: forall m. Monad m -> forall a. a -> m a
-- Check for fixity rearrangements -- Check for fixity rearrangements
mkHsOpTyRn HsFunTy (ppr funTyCon) funTyFixity ty1' ty2' mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
rnHsType doc (HsListTy ty) = do rnHsType doc (HsListTy ty) = do
ty' <- rnLHsType doc ty ty' <- rnLHsType doc ty
...@@ -270,36 +271,35 @@ by the presence of ->, which is a separate syntactic construct. ...@@ -270,36 +271,35 @@ by the presence of ->, which is a separate syntactic construct.
--------------- ---------------
-- Building (ty1 `op1` (ty21 `op2` ty22)) -- Building (ty1 `op1` (ty21 `op2` ty22))
mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name) mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
-> SDoc -> Fixity -> LHsType Name -> LHsType Name -> Name -> Fixity -> LHsType Name -> LHsType Name
-> RnM (HsType Name) -> RnM (HsType Name)
mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22)) mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
= do { fix2 <- lookupTyFixityRn op2 = do { fix2 <- lookupTyFixityRn op2
; mk_hs_op_ty mk1 pp_op1 fix1 ty1 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1
(\t1 t2 -> HsOpTy t1 op2 t2) (\t1 t2 -> HsOpTy t1 op2 t2)
(ppr op2) fix2 ty21 ty22 loc2 } (unLoc op2) fix2 ty21 ty22 loc2 }
mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22)) mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22))
= mk_hs_op_ty mk1 pp_op1 fix1 ty1 = mk_hs_op_ty mk1 pp_op1 fix1 ty1
HsFunTy (ppr funTyCon) funTyFixity ty21 ty22 loc2 HsFunTy funTyConName funTyFixity ty21 ty22 loc2
mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment
= return (mk1 ty1 ty2) = return (mk1 ty1 ty2)
--------------- ---------------
mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name) mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
-> SDoc -> Fixity -> LHsType Name -> Name -> Fixity -> LHsType Name
-> (LHsType Name -> LHsType Name -> HsType Name) -> (LHsType Name -> LHsType Name -> HsType Name)
-> SDoc -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
-> RnM (HsType Name) -> RnM (HsType Name)
mk_hs_op_ty mk1 pp_op1 fix1 ty1 mk_hs_op_ty mk1 op1 fix1 ty1
mk2 pp_op2 fix2 ty21 ty22 loc2 mk2 op2 fix2 ty21 ty22 loc2
| nofix_error = do { addErr (precParseErr (quotes pp_op1,fix1) | nofix_error = do { precParseErr (op1,fix1) (op2,fix2)
(quotes pp_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)
new_ty <- mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty21 new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
; return (mk2 (noLoc new_ty) ty22) } ; return (mk2 (noLoc new_ty) ty22) }
where where
(nofix_error, associate_right) = compareFixity fix1 fix2 (nofix_error, associate_right) = compareFixity fix1 fix2
...@@ -314,9 +314,9 @@ mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged ...@@ -314,9 +314,9 @@ mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged
-- (e11 `op1` e12) `op2` e2 -- (e11 `op1` e12) `op2` e2
mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
| nofix_error = do | nofix_error
addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
return (OpApp e1 op2 fix2 e2) return (OpApp e1 op2 fix2 e2)
| associate_right = do | associate_right = do
new_e <- mkOpAppRn e12 op2 fix2 e2 new_e <- mkOpAppRn e12 op2 fix2 e2
...@@ -328,13 +328,13 @@ mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2 ...@@ -328,13 +328,13 @@ 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 = do | nofix_error
addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
return (OpApp e1 op2 fix2 e2) return (OpApp e1 op2 fix2 e2)
| associate_right = do | associate_right
new_e <- mkOpAppRn neg_arg op2 fix2 e2 = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
return (NegApp (L loc' new_e) neg_name) return (NegApp (L loc' new_e) neg_name)
where where
loc' = combineLocs neg_arg e2 loc' = combineLocs neg_arg e2
(nofix_error, associate_right) = compareFixity negateFixity fix2 (nofix_error, associate_right) = compareFixity negateFixity fix2
...@@ -342,9 +342,9 @@ mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2 ...@@ -342,9 +342,9 @@ 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= do -- We *want* right association | not associate_right -- We *want* right association
addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) = do precParseErr (get_op op1, fix1) (negateName, 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
...@@ -356,6 +356,11 @@ mkOpAppRn e1 op fix e2 -- Default case, no rearrangment ...@@ -356,6 +356,11 @@ 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
get_op (L _ (HsVar n)) = n
get_op other = pprPanic "get_op" (ppr other)
-- Parser left-associates everything, but -- Parser left-associates everything, but
-- derived instances may have correctly-associated things to -- derived instances may have correctly-associated things to
-- in the right operarand. So we just check that the right operand is OK -- in the right operarand. So we just check that the right operand is OK
...@@ -387,14 +392,14 @@ mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged ...@@ -387,14 +392,14 @@ mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged
-- (e11 `op1` e12) `op2` e2 -- (e11 `op1` e12) `op2` e2
mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _)) mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _))
op2 fix2 a2 op2 fix2 a2
| nofix_error = do | nofix_error
addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
return (HsArrForm op2 (Just fix2) [a1, a2]) return (HsArrForm op2 (Just fix2) [a1, a2])
| associate_right = do | associate_right
new_c <- mkOpFormRn a12 op2 fix2 a2 = do new_c <- mkOpFormRn a12 op2 fix2 a2
return (HsArrForm op1 (Just fix1) return (HsArrForm op1 (Just fix1)
[a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])]) [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
-- TODO: locs are wrong -- TODO: locs are wrong
where where
(nofix_error, associate_right) = compareFixity fix1 fix2 (nofix_error, associate_right) = compareFixity fix1 fix2
...@@ -413,7 +418,7 @@ mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 ...@@ -413,7 +418,7 @@ 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
{ addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) { precParseErr (unLoc op1,fix1) (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
...@@ -462,11 +467,10 @@ checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do ...@@ -462,11 +467,10 @@ 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 = (ppr_op op, op_fix) info = (op, op_fix)
info1 = (ppr_op op1, op1_fix) info1 = (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)
checkErr inf_ok (precParseErr infol infor)
checkPrec _ _ _ checkPrec _ _ _
= return () = return ()
...@@ -479,41 +483,47 @@ checkSectionPrec :: FixityDirection -> HsExpr RdrName ...@@ -479,41 +483,47 @@ 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 (ppr_op op) fix OpApp _ op fix _ -> go_for_it (get_op op) fix
NegApp _ _ -> go_for_it pp_prefix_minus negateFixity NegApp _ _ -> go_for_it negateName negateFixity
_ -> return () _ -> return ()
where where
L _ (HsVar op_name) = op op_name = get_op op
go_for_it pp_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 _) <- lookupFixityRn op_name
checkErr (op_prec < arg_prec unless (op_prec < arg_prec
|| op_prec == arg_prec && direction == assoc) || (op_prec == arg_prec && direction == assoc))
(sectionPrecErr (ppr_op op_name, op_fix) (sectionPrecErr (op_name, op_fix)
(pp_arg_op, arg_fix) section) (arg_op, arg_fix) section)
\end{code} \end{code}
Precedence-related error messages Precedence-related error messages
\begin{code} \begin{code}
precParseErr :: (SDoc, Fixity) -> (SDoc, Fixity) -> SDoc precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
precParseErr op1 op2 precParseErr op1@(n1,_) op2@(n2,_)
= hang (ptext (sLit "precedence parsing error")) | isUnboundName n1 || isUnboundName n2
= return () -- Avoid error cascade
| otherwise
= addErr $ hang (ptext (sLit "Precedence parsing error"))
4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"), 4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"),
ppr_opfix op2, ppr_opfix op2,
ptext (sLit "in the same infix expression")]) ptext (sLit "in the same infix expression")])
sectionPrecErr :: (SDoc, Fixity) -> (SDoc, Fixity) -> HsExpr RdrName -> SDoc sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
sectionPrecErr op arg_op section sectionPrecErr op@(n1,_) arg_op@(n2,_) section
= vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"), | isUnboundName n1 || isUnboundName n2
nest 4 (ptext (sLit "must have lower precedence than the operand") <+> ppr_opfix arg_op), = return () -- Avoid error cascade
| otherwise
= addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"),
nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]),
nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))] nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))]
pp_prefix_minus :: SDoc ppr_opfix :: (Name, Fixity) -> SDoc
pp_prefix_minus = ptext (sLit "prefix `-'") ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
ppr_op :: Outputable a => a -> SDoc where
ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name pp_op | op == negateName = ptext (sLit "prefix `-'")
ppr_opfix :: (SDoc, Fixity) -> SDoc | otherwise = quotes (ppr op)
ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
\end{code} \end{code}
%********************************************************* %*********************************************************
......
...@@ -15,7 +15,7 @@ module TypeRep ( ...@@ -15,7 +15,7 @@ module TypeRep (
Kind, ThetaType, -- Synonyms Kind, ThetaType, -- Synonyms
funTyCon, funTyCon, funTyConName,
-- Pretty-printing -- Pretty-printing
pprType, pprParendType, pprTypeApp, pprType, pprParendType, pprTypeApp,
......
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