Add real error messages for associativity errors

examples/failing/MixedAssociativityError.purs

@@ -0,0 +1,6 @@
+-- @shouldFailWith MixedAssociativityError
+module Main where
+
+import Prelude
+
+feq f x y = f <$> x == f <$> y

examples/failing/NonAssociativeError.purs

@@ -0,0 +1,8 @@
+-- @shouldFailWith NonAssociativeError
+-- @shouldFailWith NonAssociativeError
+module Main where
+
+import Prelude
+
+a = true == true == true
+b = true == false /= true

src/Language/PureScript/AST/Declarations.hs

@@ -174,6 +174,8 @@ data SimpleErrorMessage
   -- | a declaration couldn't be used because it contained free variables
   | UnusableDeclaration Ident [[Text]]
   | CannotDefinePrimModules ModuleName
+  | MixedAssociativityError (NEL.NonEmpty (Qualified (OpName 'AnyOpName), Associativity))
+  | NonAssociativeError (NEL.NonEmpty (Qualified (OpName 'AnyOpName)))
   deriving (Show)
 
 -- | Error message hints, providing more detailed information about failure.

src/Language/PureScript/Errors.hs

@@ -180,6 +180,8 @@ errorCode em = case unwrapErrorMessage em of
   UserDefinedWarning{} -> "UserDefinedWarning"
   UnusableDeclaration{} -> "UnusableDeclaration"
   CannotDefinePrimModules{} -> "CannotDefinePrimModules"
+  MixedAssociativityError{} -> "MixedAssociativityError"
+  NonAssociativeError{} -> "NonAssociativeError"
 
 -- | A stack trace for an error
 newtype MultipleErrors = MultipleErrors
@@ -997,6 +999,27 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
         , line $ "The Prim namespace is reserved for compiler-defined terms."
         ]
 
+    renderSimpleErrorMessage (MixedAssociativityError opsWithAssoc) =
+      paras
+        [ line "Cannot parse an expression that uses operators of the same precedence but mixed associativity:"
+        , indent $ paras $ map (\(name, assoc) -> line $ markCode (showQualified showOp name) <> " is " <> markCode (T.pack (showAssoc assoc))) (NEL.toList opsWithAssoc)
+        , line "Use parentheses to resolve this ambiguity."
+        ]
+
+    renderSimpleErrorMessage (NonAssociativeError ops) =
+      if NEL.length ops == 1
+        then
+          paras
+            [ line $ "Cannot parse an expression that uses multiple instances of the non-associative operator " <> markCode (showQualified showOp (NEL.head ops)) <> "."
+            , line "Use parentheses to resolve this ambiguity."
+            ]
+        else
+          paras
+            [ line "Cannot parse an expression that uses multiple non-associative operators of the same precedence:"
+            , indent $ paras $ map (line . markCode . showQualified showOp) (NEL.toList ops)
+            , line "Use parentheses to resolve this ambiguity."
+            ]
+
     renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
     renderHint (ErrorUnifyingTypes t1 t2) detail =
       paras [ detail

src/Language/PureScript/Names.hs

@@ -121,7 +121,10 @@ showOp op = "(" <> runOpName op <> ")"
 -- |
 -- The closed set of operator alias types.
 --
-data OpNameType = ValueOpName | TypeOpName
+data OpNameType = ValueOpName | TypeOpName | AnyOpName
+
+eraseOpName :: OpName a -> OpName 'AnyOpName
+eraseOpName = OpName . runOpName
 
 -- |
 -- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.

src/Language/PureScript/Sugar/Operators.hs

@@ -197,19 +197,13 @@ rebracketModule pred_ valueOpTable typeOpTable (Module ss coms mn ds exts) =
   (f, _, _) =
       everywhereOnValuesTopDownM
         goDecl
-        (goExpr <=< decontextify goExpr')
-        (goBinder <=< decontextify goBinder')
+        (matchExprOperators valueOpTable <=< decontextify goExpr')
+        (matchBinderOperators valueOpTable <=< decontextify goBinder')
 
   (goDecl, goExpr', goBinder') = updateTypes (const goType)
 
-  goExpr :: Expr -> m Expr
-  goExpr = return . matchExprOperators valueOpTable
-
-  goBinder :: Binder -> m Binder
-  goBinder = return . matchBinderOperators valueOpTable
-
   goType :: Type -> m Type
-  goType = return . matchTypeOperators typeOpTable
+  goType = matchTypeOperators typeOpTable
 
   decontextify :: (Maybe SourceSpan -> a -> m (Maybe SourceSpan, a)) -> a -> m a
   decontextify ctxf = fmap snd . ctxf Nothing

src/Language/PureScript/Sugar/Operators/Binders.hs

@@ -2,11 +2,18 @@ module Language.PureScript.Sugar.Operators.Binders where
 
 import Prelude.Compat
 
+import Control.Monad.Except
+
 import Language.PureScript.AST
+import Language.PureScript.Errors
 import Language.PureScript.Names
 import Language.PureScript.Sugar.Operators.Common
 
-matchBinderOperators :: [[(Qualified (OpName 'ValueOpName), Associativity)]] -> Binder -> Binder
+matchBinderOperators
+  :: MonadError MultipleErrors m
+  => [[(Qualified (OpName 'ValueOpName), Associativity)]] 
+  -> Binder
+  -> m Binder
 matchBinderOperators = matchOperators isBinOp extractOp fromOp reapply id
   where
 

src/Language/PureScript/Sugar/Operators/Common.hs

@@ -3,15 +3,22 @@ module Language.PureScript.Sugar.Operators.Common where
 import Prelude.Compat
 
 import Control.Monad.State
+import Control.Monad.Except
 
+import Data.Either (rights)
 import Data.Functor.Identity
+import Data.List (sortOn)
+import Data.Maybe (mapMaybe, fromJust)
+import qualified Data.List.NonEmpty as NEL
+import qualified Data.Map as M
 
 import qualified Text.Parsec as P
 import qualified Text.Parsec.Pos as P
 import qualified Text.Parsec.Expr as P
 
 import Language.PureScript.AST
 import Language.PureScript.Crash
+import Language.PureScript.Errors
 import Language.PureScript.Names
 
 type Chain a = [Either a a]
@@ -53,30 +60,85 @@ opTable ops fromOp reapply =
   map (map (\(name, a) -> P.Infix (P.try (matchOp fromOp name) >>= \ss -> return (reapply ss name)) (toAssoc a))) ops
 
 matchOperators
-  :: forall a nameType
+  :: forall m a nameType
    . Show a
+  => MonadError MultipleErrors m
   => (a -> Bool)
   -> (a -> Maybe (a, a, a))
   -> FromOp nameType a
   -> Reapply nameType a
   -> ([[P.Operator (Chain a) () Identity a]] -> P.OperatorTable (Chain a) () Identity a)
   -> [[(Qualified (OpName nameType), Associativity)]]
   -> a
-  -> a
+  -> m a
 matchOperators isBinOp extractOp fromOp reapply modOpTable ops = parseChains
   where
-  parseChains :: a -> a
+  parseChains :: a -> m a
   parseChains ty
     | True <- isBinOp ty = bracketChain (extendChain ty)
-    | otherwise = ty
+    | otherwise = pure ty
   extendChain :: a -> Chain a
   extendChain ty
     | Just (op, l, r) <- extractOp ty = Left l : Right op : extendChain r
     | otherwise = [Left ty]
-  bracketChain :: Chain a -> a
-  bracketChain =
-    either
-      (\_ -> internalError "matchTypeOperators: cannot reorder operators")
-      id
-    . P.parse opParser "operator expression"
+  bracketChain :: Chain a -> m a
+  bracketChain chain =
+    case P.parse opParser "operator expression" chain of
+      Right a -> pure a
+      Left _ -> throwError . MultipleErrors $ mkErrors chain
+  opParser :: P.Parsec (Chain a) () a
   opParser = P.buildExpressionParser (modOpTable (opTable ops fromOp reapply)) parseValue <* P.eof
+
+  -- Generating a good error message involves a bit of work here, as the parser
+  -- can't provide one for us.
+  --
+  -- We examine the expression chain, plucking out the operators and then
+  -- grouping them by shared precedence, then if any of the following conditions
+  -- are met, we have something to report:
+  --   1. any of the groups have mixed associativity
+  --   2. there is more than one occurance of a non-associative operator in a
+  --      precedence group
+  mkErrors :: Chain a -> [ErrorMessage]
+  mkErrors chain =
+    let
+      opInfo :: M.Map (Qualified (OpName nameType)) (Integer, Associativity)
+      opInfo = M.fromList $ concatMap (\(n, o) -> map (\(name, assoc) -> (name, (n, assoc))) o) (zip [0..] ops)
+      opPrec :: Qualified (OpName nameType) -> Integer
+      opPrec = fromJust . fmap fst . flip M.lookup opInfo
+      opAssoc :: Qualified (OpName nameType) -> Associativity
+      opAssoc = fromJust . fmap snd . flip M.lookup opInfo
+      chainOpSpans :: M.Map (Qualified (OpName nameType)) (NEL.NonEmpty SourceSpan)
+      chainOpSpans = foldr (\(ss, name) -> M.alter (Just . maybe (pure ss) (NEL.cons ss)) name) M.empty . mapMaybe fromOp $ rights chain
+      opUsages :: Qualified (OpName nameType) -> Int
+      opUsages = maybe 0 NEL.length . flip M.lookup chainOpSpans
+      precGrouped :: [NEL.NonEmpty (Qualified (OpName nameType))]
+      precGrouped = NEL.groupWith opPrec . sortOn opPrec $ M.keys chainOpSpans
+      assocGrouped :: [NEL.NonEmpty (NEL.NonEmpty (Qualified (OpName nameType)))]
+      assocGrouped = fmap (NEL.groupWith1 opAssoc . NEL.sortWith opAssoc) precGrouped
+      mixedAssoc :: [NEL.NonEmpty (Qualified (OpName nameType))]
+      mixedAssoc = fmap join . filter (\precGroup -> NEL.length precGroup > 1) $ assocGrouped
+      nonAssoc :: [NEL.NonEmpty (Qualified (OpName nameType))]
+      nonAssoc = join $ fmap (NEL.filter (\assocGroup -> opAssoc (NEL.head assocGroup) == Infix && sum (fmap opUsages assocGroup) > 1)) assocGrouped
+    in
+      if null (nonAssoc ++ mixedAssoc)
+        then internalError "matchOperators: cannot reorder operators"
+        else
+          map
+            (\grp ->
+              mkPositionedError chainOpSpans grp
+                (MixedAssociativityError (fmap (\name -> (eraseOpName <$> name, opAssoc name)) grp)))
+            mixedAssoc
+          ++ map
+            (\grp ->
+              mkPositionedError chainOpSpans grp
+                (NonAssociativeError (fmap (fmap eraseOpName) grp)))
+            nonAssoc
+
+  mkPositionedError
+    :: M.Map (Qualified (OpName nameType)) (NEL.NonEmpty SourceSpan)
+    -> NEL.NonEmpty (Qualified (OpName nameType))
+    -> SimpleErrorMessage
+    -> ErrorMessage
+  mkPositionedError chainOpSpans grp =
+    ErrorMessage
+      [PositionedError (join . fmap (fromJust . flip M.lookup chainOpSpans) $ grp)]

src/Language/PureScript/Sugar/Operators/Expr.hs

@@ -2,6 +2,7 @@ module Language.PureScript.Sugar.Operators.Expr where
 
 import Prelude.Compat
 
+import Control.Monad.Except
 import Data.Functor.Identity
 
 import qualified Text.Parsec as P
@@ -10,8 +11,13 @@ import qualified Text.Parsec.Expr as P
 import Language.PureScript.AST
 import Language.PureScript.Names
 import Language.PureScript.Sugar.Operators.Common
+import Language.PureScript.Errors
 
-matchExprOperators :: [[(Qualified (OpName 'ValueOpName), Associativity)]] -> Expr -> Expr
+matchExprOperators
+  :: MonadError MultipleErrors m
+  => [[(Qualified (OpName 'ValueOpName), Associativity)]]
+  -> Expr
+  -> m Expr
 matchExprOperators = matchOperators isBinOp extractOp fromOp reapply modOpTable
   where
 

src/Language/PureScript/Sugar/Operators/Types.hs

@@ -2,13 +2,19 @@ module Language.PureScript.Sugar.Operators.Types where
 
 import Prelude.Compat
 
+import Control.Monad.Except
 import Language.PureScript.AST
 import Language.PureScript.Crash
+import Language.PureScript.Errors
 import Language.PureScript.Names
 import Language.PureScript.Sugar.Operators.Common
 import Language.PureScript.Types
 
-matchTypeOperators :: [[(Qualified (OpName 'TypeOpName), Associativity)]] -> Type -> Type
+matchTypeOperators
+  :: MonadError MultipleErrors m
+  => [[(Qualified (OpName 'TypeOpName), Associativity)]]
+  -> Type
+  -> m Type
 matchTypeOperators = matchOperators isBinOp extractOp fromOp reapply id
   where