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"