From f0e527a9dcad9a9b8947d525d4a3dfe80b5b0f38 Mon Sep 17 00:00:00 2001
From: Brian Huffman <huffman@galois.com>
Date: Fri, 21 Jun 2019 16:01:17 -0700
Subject: [PATCH] More informative, nicer error message for fixity errors.

Fixes #590.
---
 src/Cryptol/ModuleSystem/Renamer.hs | 15 ++++++++-------
 src/Cryptol/Parser/Fixity.hs        |  6 +++++-
 src/Cryptol/Utils/PP.hs             |  6 +++++-
 3 files changed, 18 insertions(+), 9 deletions(-)

diff --git a/src/Cryptol/ModuleSystem/Renamer.hs b/src/Cryptol/ModuleSystem/Renamer.hs
index c69d2fb16..3625ba2d6 100644
--- a/src/Cryptol/ModuleSystem/Renamer.hs
+++ b/src/Cryptol/ModuleSystem/Renamer.hs
@@ -78,7 +78,7 @@ data RenamerError
     -- ^ When a type is missing from the naming environment, but one or more
     -- values exist with the same name.
 
-  | FixityError (Located Name) (Located Name) NameDisp
+  | FixityError (Located Name) Fixity (Located Name) Fixity NameDisp
     -- ^ When the fixity of two operators conflict
 
   | InvalidConstraint (Type PName) NameDisp
@@ -126,11 +126,12 @@ instance PP RenamerError where
          4 (fsep [ text "Expected a type named", quotes (pp (thing lqn))
                  , text "but found a value instead" ])
 
-    FixityError o1 o2 disp -> fixNameDisp disp $
-      hang (text "[error]")
-         4 (fsep [ text "The fixities of", pp o1, text "and", pp o2
-                 , text "are not compatible.  "
-                 , text "You may use explicit parenthesis to disambiguate" ])
+    FixityError o1 f1 o2 f2 disp -> fixNameDisp disp $
+      hang (text "[error] at" <+> pp (srcRange o1) <+> text "and" <+> pp (srcRange o2))
+         4 (fsep [ text "The fixities of", pp (thing o1), parens (pp f1)
+                 , text "and", pp (thing o2), parens (pp f2)
+                 , text "are not compatible."
+                 , text "You may use explicit parentheses to disambiguate." ])
 
     InvalidConstraint ty disp -> fixNameDisp disp $
       hang (text "[error]" <+> maybe empty (\r -> text "at" <+> pp r) (getLoc ty))
@@ -867,7 +868,7 @@ mkEInfix e@(EInfix x o1 f1 y) op@(o2,f2) z =
      FCRight -> do r <- mkEInfix y op z
                    return (EInfix x o1 f1 r)
 
-     FCError -> do record (FixityError o1 o2)
+     FCError -> do record (FixityError o1 f1 o2 f2)
                    return (EInfix e o2 f2 z)
 
 mkEInfix (ELocated e' _) op z =
diff --git a/src/Cryptol/Parser/Fixity.hs b/src/Cryptol/Parser/Fixity.hs
index 1d325ba70..9809f5a84 100644
--- a/src/Cryptol/Parser/Fixity.hs
+++ b/src/Cryptol/Parser/Fixity.hs
@@ -17,7 +17,7 @@ module Cryptol.Parser.Fixity
   , compareFixity
   ) where
 
-import Cryptol.Utils.PP (Assoc(..))
+import Cryptol.Utils.PP
 
 import GHC.Generics (Generic)
 import Control.DeepSeq
@@ -44,3 +44,7 @@ compareFixity (Fixity a1 p1) (Fixity a2 p2) =
 -- | The fixity used when none is provided.
 defaultFixity :: Fixity
 defaultFixity = Fixity LeftAssoc 100
+
+instance PP Fixity where
+  ppPrec _ (Fixity assoc level) =
+    text "precedence" <+> int level <.> comma <+> pp assoc
diff --git a/src/Cryptol/Utils/PP.hs b/src/Cryptol/Utils/PP.hs
index 07294e54e..f50b54bb8 100644
--- a/src/Cryptol/Utils/PP.hs
+++ b/src/Cryptol/Utils/PP.hs
@@ -177,7 +177,7 @@ ppInfix lp isInfix expr =
 
 
 
--- | Display a numeric values as an ordinar (e.g., 2nd)
+-- | Display a numeric value as an ordinal (e.g., 2nd)
 ordinal :: (Integral a, Show a, Eq a) => a -> Doc
 ordinal x = text (show x) <.> text (ordSuffix x)
 
@@ -293,3 +293,7 @@ instance PP Ident where
 instance PP ModName where
   ppPrec _   = text . T.unpack . modNameToText
 
+instance PP Assoc where
+  ppPrec _ LeftAssoc  = text "left-associative"
+  ppPrec _ RightAssoc = text "right-associative"
+  ppPrec _ NonAssoc   = text "non-associative"