Improve error reporting for precedence errors

Adopt the suggestion of Trac #2993, and tidy up the reporting of
precedence parsing errors somewhat.

diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs
index 0e047fe..d5fc150 100644 (file)
--- a/compiler/rename/RnTypes.lhs
+++ b/compiler/rename/RnTypes.lhs
@@ -23,7 +23,7 @@ import RnEnv
 import TcRnMonad
 import RdrName
 import PrelNames
-import TypeRep         ( funTyCon )
+import TypeRep         ( funTyConName )
 import Name
 import SrcLoc
 import NameSet
@@ -32,6 +32,7 @@ import BasicTypes     ( compareFixity, funTyFixity, negateFixity,
                          Fixity(..), FixityDirection(..) )
 import Outputable
 import FastString
+import Control.Monad   ( unless )
 
 #include "HsVersions.h"
 \end{code}
@@ -116,7 +117,7 @@ rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2)
        ; fix <- lookupTyFixityRn l_op'
        ; ty1' <- rnLHsType doc ty1
        ; 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
     ty' <- rnLHsType doc ty
@@ -141,7 +142,7 @@ rnHsType doc (HsFunTy ty1 ty2) = do
        -- when we find return :: forall m. Monad m -> forall a. a -> m a
 
        -- Check for fixity rearrangements
-    mkHsOpTyRn HsFunTy (ppr funTyCon) funTyFixity ty1' ty2'
+    mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2'
 
 rnHsType doc (HsListTy ty) = do
     ty' <- rnLHsType doc ty
@@ -270,36 +271,35 @@ by the presence of ->, which is a separate syntactic construct.
 ---------------
 -- Building (ty1 `op1` (ty21 `op2` ty22))
 mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name)
-          -> SDoc -> Fixity -> LHsType Name -> LHsType Name 
+          -> Name -> Fixity -> LHsType Name -> LHsType Name 
           -> RnM (HsType Name)
 
 mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22))
   = do  { fix2 <- lookupTyFixityRn op2
        ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 
                      (\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))
   = 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
   = return (mk1 ty1 ty2)
 
 ---------------
 mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name)
-           -> SDoc -> Fixity -> LHsType Name
+           -> Name -> Fixity -> LHsType Name
            -> (LHsType Name -> LHsType Name -> HsType Name)
-           -> SDoc -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
+           -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan
            -> RnM (HsType Name)
-mk_hs_op_ty mk1 pp_op1 fix1 ty1 
-           mk2 pp_op2 fix2 ty21 ty22 loc2
-  | nofix_error     = do { addErr (precParseErr (quotes pp_op1,fix1) 
-                                               (quotes pp_op2,fix2))
+mk_hs_op_ty mk1 op1 fix1 ty1 
+           mk2 op2 fix2 ty21 ty22 loc2
+  | nofix_error     = do { precParseErr (op1,fix1) (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)
-                          new_ty <- mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty21
+                          new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21
                         ; return (mk2 (noLoc new_ty) ty22) }
   where
     (nofix_error, associate_right) = compareFixity fix1 fix2
@@ -314,9 +314,9 @@ mkOpAppRn :: LHsExpr Name                   -- Left operand; already rearranged
 
 -- (e11 `op1` e12) `op2` e2
 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2
-  | nofix_error = do
-    addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))
-    return (OpApp e1 op2 fix2 e2)
+  | nofix_error
+  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
+       return (OpApp e1 op2 fix2 e2)
 
   | associate_right = do
     new_e <- mkOpAppRn e12 op2 fix2 e2
@@ -328,13 +328,13 @@ 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
-    addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2))
-    return (OpApp e1 op2 fix2 e2)
+  | nofix_error
+  = do precParseErr (negateName,negateFixity) (get_op op2,fix2)
+       return (OpApp e1 op2 fix2 e2)
 
-  | associate_right = do
-    new_e <- mkOpAppRn neg_arg op2 fix2 e2
-    return (NegApp (L loc' new_e) neg_name)
+  | associate_right 
+  = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
+       return (NegApp (L loc' new_e) neg_name)
   where
     loc' = combineLocs neg_arg e2
     (nofix_error, associate_right) = compareFixity negateFixity fix2
@@ -342,9 +342,9 @@ 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= do                    -- We *want* right association
-    addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity))
-    return (OpApp e1 op1 fix1 e2)
+  | not associate_right                        -- We *want* right association
+  = do precParseErr (get_op op1, fix1) (negateName, negateFixity)
+       return (OpApp e1 op1 fix1 e2)
   where
     (_, associate_right) = compareFixity fix1 negateFixity
 
@@ -356,6 +356,11 @@ mkOpAppRn e1 op fix e2                     -- Default case, no rearrangment
     )
     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 
 -- derived instances may have correctly-associated things to
 -- 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
 -- (e11 `op1` e12) `op2` e2
 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _))
        op2 fix2 a2
-  | nofix_error = do
-    addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))
-    return (HsArrForm op2 (Just fix2) [a1, a2])
-
-  | associate_right = do
-    new_c <- mkOpFormRn a12 op2 fix2 a2
-    return (HsArrForm op1 (Just fix1)
-       [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
+  | nofix_error
+  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
+       return (HsArrForm op2 (Just fix2) [a1, a2])
+
+  | associate_right
+  = do new_c <- mkOpFormRn a12 op2 fix2 a2
+       return (HsArrForm op1 (Just fix1)
+                 [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])])
        -- TODO: locs are wrong
   where
     (nofix_error, associate_right) = compareFixity fix1 fix2
@@ -413,7 +418,7 @@ 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
-               { addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))
+               { precParseErr (unLoc op1,fix1) (unLoc op2,fix2)
                ; return (ConPatIn op2 (InfixCon p1 p2)) }
 
          else if associate_right then do
@@ -462,11 +467,10 @@ checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do
                  (op1_dir == InfixR && op_dir == InfixR && right ||
                   op1_dir == InfixL && op_dir == InfixL && not right))
 
-       info  = (ppr_op op,  op_fix)
-       info1 = (ppr_op op1, op1_fix)
+       info  = (op,        op_fix)
+       info1 = (unLoc op1, op1_fix)
        (infol, infor) = if right then (info, info1) else (info1, info)
-
-    checkErr inf_ok (precParseErr infol infor)
+    unless inf_ok (precParseErr infol infor)
 
 checkPrec _ _ _
   = return ()
@@ -479,41 +483,47 @@ checkSectionPrec :: FixityDirection -> HsExpr RdrName
        -> LHsExpr Name -> LHsExpr Name -> RnM ()
 checkSectionPrec direction section op arg
   = case unLoc arg of
-       OpApp _ op fix _ -> go_for_it (ppr_op op)     fix
-       NegApp _ _       -> go_for_it pp_prefix_minus negateFixity
+       OpApp _ op fix _ -> go_for_it (get_op op) fix
+       NegApp _ _       -> go_for_it negateName  negateFixity
        _                -> return ()
   where
-    L _ (HsVar op_name) = op
-    go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc) = do
+    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
-         checkErr (op_prec < arg_prec
-                    || op_prec == arg_prec && direction == assoc)
-                 (sectionPrecErr (ppr_op op_name, op_fix)      
-                                 (pp_arg_op, arg_fix) section)
+         unless (op_prec < arg_prec
+                 || (op_prec == arg_prec && direction == assoc))
+                (sectionPrecErr (op_name, op_fix)      
+                                (arg_op, arg_fix) section)
 \end{code}
 
 Precedence-related error messages
 
 \begin{code}
-precParseErr :: (SDoc, Fixity) -> (SDoc, Fixity) -> SDoc
-precParseErr op1 op2 
-  = hang (ptext (sLit "precedence parsing error"))
+precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM ()
+precParseErr op1@(n1,_) op2@(n2,_) 
+  | 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"), 
               ppr_opfix op2,
               ptext (sLit "in the same infix expression")])
 
-sectionPrecErr :: (SDoc, Fixity) -> (SDoc, Fixity) -> HsExpr RdrName -> SDoc
-sectionPrecErr op arg_op section
- = vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"),
-        nest 4 (ptext (sLit "must have lower precedence than the operand") <+> ppr_opfix arg_op),
+sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM ()
+sectionPrecErr op@(n1,_) arg_op@(n2,_) section
+  | isUnboundName n1 || isUnboundName n2
+  = 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))]
 
-pp_prefix_minus :: SDoc
-pp_prefix_minus = ptext (sLit "prefix `-'")
-ppr_op :: Outputable a => a -> SDoc
-ppr_op op = quotes (ppr op)    -- Here, op can be a Name or a (Var n), where n is a Name
-ppr_opfix :: (SDoc, Fixity) -> SDoc
-ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
+ppr_opfix :: (Name, Fixity) -> SDoc
+ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)
+   where
+     pp_op | op == negateName = ptext (sLit "prefix `-'")
+          | otherwise        = quotes (ppr op)
 \end{code}
 
 %*********************************************************

diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs
index f71606e..600b731 100644 (file)
--- a/compiler/types/TypeRep.lhs
+++ b/compiler/types/TypeRep.lhs
@@ -15,7 +15,7 @@ module TypeRep (
        
        Kind, ThetaType,                -- Synonyms
 
-       funTyCon,
+       funTyCon, funTyConName,
 
        -- Pretty-printing
        pprType, pprParendType, pprTypeApp,