module Language.PureScript.Sugar.Operators.Common where

import Prelude

import Control.Monad.State (guard, join)
import Control.Monad.Except (MonadError(..))

import Data.Either (rights)
import Data.Functor.Identity (Identity)
import Data.List (sortOn)
import Data.Maybe (mapMaybe, fromJust)
import Data.List.NonEmpty qualified as NEL
import Data.Map qualified as M

import Text.Parsec qualified as P
import Text.Parsec.Pos qualified as P
import Text.Parsec.Expr qualified as P

import Language.PureScript.AST (Associativity(..), ErrorMessageHint(..), SourceSpan)
import Language.PureScript.Crash (internalError)
import Language.PureScript.Errors (ErrorMessage(..), MultipleErrors(..), SimpleErrorMessage(..))
import Language.PureScript.Names (OpName, Qualified, eraseOpName)

type Chain a = [Either a a]

type FromOp nameType a = a -> Maybe (SourceSpan, Qualified (OpName nameType))
type Reapply nameType a = SourceSpan -> Qualified (OpName nameType) -> a -> a -> a

toAssoc :: Associativity -> P.Assoc
toAssoc :: Associativity -> Assoc
toAssoc Associativity
Infixl = Assoc
P.AssocLeft
toAssoc Associativity
Infixr = Assoc
P.AssocRight
toAssoc Associativity
Infix  = Assoc
P.AssocNone

token :: (P.Stream s Identity t) => (t -> Maybe a) -> P.Parsec s u a
token :: forall s t a u.
Stream s Identity t =>
(t -> Maybe a) -> Parsec s u a
token = forall s t a u.
Stream s Identity t =>
(t -> String) -> (t -> SourcePos) -> (t -> Maybe a) -> Parsec s u a
P.token (forall a b. a -> b -> a
const String
"") (forall a b. a -> b -> a
const (String -> SourcePos
P.initialPos String
""))

parseValue :: P.Parsec (Chain a) () a
parseValue :: forall a. Parsec (Chain a) () a
parseValue = forall s t a u.
Stream s Identity t =>
(t -> Maybe a) -> Parsec s u a
token (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. a -> Maybe a
Just (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)) forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
P.<?> String
"expression"

parseOp
  :: FromOp nameType a
  -> P.Parsec (Chain a) () (SourceSpan, Qualified (OpName nameType))
parseOp :: forall (nameType :: OpNameType) a.
FromOp nameType a
-> Parsec (Chain a) () (SourceSpan, Qualified (OpName nameType))
parseOp FromOp nameType a
fromOp = forall s t a u.
Stream s Identity t =>
(t -> Maybe a) -> Parsec s u a
token (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) FromOp nameType a
fromOp) forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
P.<?> String
"operator"

matchOp
  :: FromOp nameType a
  -> Qualified (OpName nameType)
  -> P.Parsec (Chain a) () SourceSpan
matchOp :: forall (nameType :: OpNameType) a.
FromOp nameType a
-> Qualified (OpName nameType) -> Parsec (Chain a) () SourceSpan
matchOp FromOp nameType a
fromOp Qualified (OpName nameType)
op = do
  (SourceSpan
ss, Qualified (OpName nameType)
ident) <- forall (nameType :: OpNameType) a.
FromOp nameType a
-> Parsec (Chain a) () (SourceSpan, Qualified (OpName nameType))
parseOp FromOp nameType a
fromOp
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Qualified (OpName nameType)
ident forall a. Eq a => a -> a -> Bool
== Qualified (OpName nameType)
op
  forall (f :: * -> *) a. Applicative f => a -> f a
pure SourceSpan
ss

opTable
  :: [[(Qualified (OpName nameType), Associativity)]]
  -> FromOp nameType a
  -> Reapply nameType a
  -> [[P.Operator (Chain a) () Identity a]]
opTable :: forall (nameType :: OpNameType) a.
[[(Qualified (OpName nameType), Associativity)]]
-> FromOp nameType a
-> Reapply nameType a
-> [[Operator (Chain a) () Identity a]]
opTable [[(Qualified (OpName nameType), Associativity)]]
ops FromOp nameType a
fromOp Reapply nameType a
reapply =
  forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map (\(Qualified (OpName nameType)
name, Associativity
a) -> forall s u (m :: * -> *) a.
ParsecT s u m (a -> a -> a) -> Assoc -> Operator s u m a
P.Infix (forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m a
P.try (forall (nameType :: OpNameType) a.
FromOp nameType a
-> Qualified (OpName nameType) -> Parsec (Chain a) () SourceSpan
matchOp FromOp nameType a
fromOp Qualified (OpName nameType)
name) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \SourceSpan
ss -> forall (m :: * -> *) a. Monad m => a -> m a
return (Reapply nameType a
reapply SourceSpan
ss Qualified (OpName nameType)
name)) (Associativity -> Assoc
toAssoc Associativity
a))) [[(Qualified (OpName nameType), Associativity)]]
ops

matchOperators
  :: 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
  -> m a
matchOperators :: forall (m :: * -> *) a (nameType :: OpNameType).
(Show a, MonadError MultipleErrors m) =>
(a -> Bool)
-> (a -> Maybe (a, a, a))
-> FromOp nameType a
-> Reapply nameType a
-> ([[Operator (Chain a) () Identity a]]
    -> [[Operator (Chain a) () Identity a]])
-> [[(Qualified (OpName nameType), Associativity)]]
-> a
-> m a
matchOperators a -> Bool
isBinOp a -> Maybe (a, a, a)
extractOp FromOp nameType a
fromOp Reapply nameType a
reapply [[Operator (Chain a) () Identity a]]
-> [[Operator (Chain a) () Identity a]]
modOpTable [[(Qualified (OpName nameType), Associativity)]]
ops = a -> m a
parseChains
  where
  parseChains :: a -> m a
  parseChains :: a -> m a
parseChains a
ty
    | Bool
True <- a -> Bool
isBinOp a
ty = Chain a -> m a
bracketChain (a -> Chain a
extendChain a
ty)
    | Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
ty
  extendChain :: a -> Chain a
  extendChain :: a -> Chain a
extendChain a
ty
    | Just (a
op, a
l, a
r) <- a -> Maybe (a, a, a)
extractOp a
ty = forall a b. a -> Either a b
Left a
l forall a. a -> [a] -> [a]
: forall a b. b -> Either a b
Right a
op forall a. a -> [a] -> [a]
: a -> Chain a
extendChain a
r
    | Bool
otherwise = [forall a b. a -> Either a b
Left a
ty]
  bracketChain :: Chain a -> m a
  bracketChain :: Chain a -> m a
bracketChain Chain a
chain =
    case forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
P.parse Parsec (Chain a) () a
opParser String
"operator expression" Chain a
chain of
      Right a
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
      Left ParseError
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ErrorMessage] -> MultipleErrors
MultipleErrors forall a b. (a -> b) -> a -> b
$ Chain a -> [ErrorMessage]
mkErrors Chain a
chain
  opParser :: P.Parsec (Chain a) () a
  opParser :: Parsec (Chain a) () a
opParser = forall s (m :: * -> *) t u a.
Stream s m t =>
OperatorTable s u m a -> ParsecT s u m a -> ParsecT s u m a
P.buildExpressionParser ([[Operator (Chain a) () Identity a]]
-> [[Operator (Chain a) () Identity a]]
modOpTable (forall (nameType :: OpNameType) a.
[[(Qualified (OpName nameType), Associativity)]]
-> FromOp nameType a
-> Reapply nameType a
-> [[Operator (Chain a) () Identity a]]
opTable [[(Qualified (OpName nameType), Associativity)]]
ops FromOp nameType a
fromOp Reapply nameType a
reapply)) forall a. Parsec (Chain a) () a
parseValue forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
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 occurrence of a non-associative operator in a
  --      precedence group
  mkErrors :: Chain a -> [ErrorMessage]
  mkErrors :: Chain a -> [ErrorMessage]
mkErrors Chain a
chain =
    let
      opInfo :: M.Map (Qualified (OpName nameType)) (Integer, Associativity)
      opInfo :: Map (Qualified (OpName nameType)) (Integer, Associativity)
opInfo = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Integer
n, [(Qualified (OpName nameType), Associativity)]
o) -> forall a b. (a -> b) -> [a] -> [b]
map (\(Qualified (OpName nameType)
name, Associativity
assoc) -> (Qualified (OpName nameType)
name, (Integer
n, Associativity
assoc))) [(Qualified (OpName nameType), Associativity)]
o) (forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
0..] [[(Qualified (OpName nameType), Associativity)]]
ops)
      opPrec :: Qualified (OpName nameType) -> Integer
      opPrec :: Qualified (OpName nameType) -> Integer
opPrec = forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map (Qualified (OpName nameType)) (Integer, Associativity)
opInfo
      opAssoc :: Qualified (OpName nameType) -> Associativity
      opAssoc :: Qualified (OpName nameType) -> Associativity
opAssoc = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map (Qualified (OpName nameType)) (Integer, Associativity)
opInfo
      chainOpSpans :: M.Map (Qualified (OpName nameType)) (NEL.NonEmpty SourceSpan)
      chainOpSpans :: Map (Qualified (OpName nameType)) (NonEmpty SourceSpan)
chainOpSpans = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(SourceSpan
ss, Qualified (OpName nameType)
name) -> forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure SourceSpan
ss) (forall a. a -> NonEmpty a -> NonEmpty a
NEL.cons SourceSpan
ss)) Qualified (OpName nameType)
name) forall k a. Map k a
M.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FromOp nameType a
fromOp forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> [b]
rights Chain a
chain
      opUsages :: Qualified (OpName nameType) -> Int
      opUsages :: Qualified (OpName nameType) -> Int
opUsages = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 forall a. NonEmpty a -> Int
NEL.length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map (Qualified (OpName nameType)) (NonEmpty SourceSpan)
chainOpSpans
      precGrouped :: [NEL.NonEmpty (Qualified (OpName nameType))]
      precGrouped :: [NonEmpty (Qualified (OpName nameType))]
precGrouped = forall (f :: * -> *) b a.
(Foldable f, Eq b) =>
(a -> b) -> f a -> [NonEmpty a]
NEL.groupWith Qualified (OpName nameType) -> Integer
opPrec forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Qualified (OpName nameType) -> Integer
opPrec forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
M.keys Map (Qualified (OpName nameType)) (NonEmpty SourceSpan)
chainOpSpans
      assocGrouped :: [NEL.NonEmpty (NEL.NonEmpty (Qualified (OpName nameType)))]
      assocGrouped :: [NonEmpty (NonEmpty (Qualified (OpName nameType)))]
assocGrouped = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall b a. Eq b => (a -> b) -> NonEmpty a -> NonEmpty (NonEmpty a)
NEL.groupWith1 Qualified (OpName nameType) -> Associativity
opAssoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall o a. Ord o => (a -> o) -> NonEmpty a -> NonEmpty a
NEL.sortWith Qualified (OpName nameType) -> Associativity
opAssoc) [NonEmpty (Qualified (OpName nameType))]
precGrouped
      mixedAssoc :: [NEL.NonEmpty (Qualified (OpName nameType))]
      mixedAssoc :: [NonEmpty (Qualified (OpName nameType))]
mixedAssoc = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (\NonEmpty (NonEmpty (Qualified (OpName nameType)))
precGroup -> forall a. NonEmpty a -> Int
NEL.length NonEmpty (NonEmpty (Qualified (OpName nameType)))
precGroup forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$ [NonEmpty (NonEmpty (Qualified (OpName nameType)))]
assocGrouped
      nonAssoc :: [NEL.NonEmpty (Qualified (OpName nameType))]
      nonAssoc :: [NonEmpty (Qualified (OpName nameType))]
nonAssoc = forall a. (a -> Bool) -> NonEmpty a -> [a]
NEL.filter (\NonEmpty (Qualified (OpName nameType))
assocGroup -> Qualified (OpName nameType) -> Associativity
opAssoc (forall a. NonEmpty a -> a
NEL.head NonEmpty (Qualified (OpName nameType))
assocGroup) forall a. Eq a => a -> a -> Bool
== Associativity
Infix Bool -> Bool -> Bool
&& forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Qualified (OpName nameType) -> Int
opUsages NonEmpty (Qualified (OpName nameType))
assocGroup) forall a. Ord a => a -> a -> Bool
> Int
1) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [NonEmpty (NonEmpty (Qualified (OpName nameType)))]
assocGrouped
    in
      if forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([NonEmpty (Qualified (OpName nameType))]
nonAssoc forall a. [a] -> [a] -> [a]
++ [NonEmpty (Qualified (OpName nameType))]
mixedAssoc)
        then forall a. HasCallStack => String -> a
internalError String
"matchOperators: cannot reorder operators"
        else
          forall a b. (a -> b) -> [a] -> [b]
map
            (\NonEmpty (Qualified (OpName nameType))
grp ->
              Map (Qualified (OpName nameType)) (NonEmpty SourceSpan)
-> NonEmpty (Qualified (OpName nameType))
-> SimpleErrorMessage
-> ErrorMessage
mkPositionedError Map (Qualified (OpName nameType)) (NonEmpty SourceSpan)
chainOpSpans NonEmpty (Qualified (OpName nameType))
grp
                (NonEmpty (Qualified (OpName 'AnyOpName), Associativity)
-> SimpleErrorMessage
MixedAssociativityError (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Qualified (OpName nameType)
name -> (forall (a :: OpNameType). OpName a -> OpName 'AnyOpName
eraseOpName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Qualified (OpName nameType)
name, Qualified (OpName nameType) -> Associativity
opAssoc Qualified (OpName nameType)
name)) NonEmpty (Qualified (OpName nameType))
grp)))
            [NonEmpty (Qualified (OpName nameType))]
mixedAssoc
          forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map
            (\NonEmpty (Qualified (OpName nameType))
grp ->
              Map (Qualified (OpName nameType)) (NonEmpty SourceSpan)
-> NonEmpty (Qualified (OpName nameType))
-> SimpleErrorMessage
-> ErrorMessage
mkPositionedError Map (Qualified (OpName nameType)) (NonEmpty SourceSpan)
chainOpSpans NonEmpty (Qualified (OpName nameType))
grp
                (NonEmpty (Qualified (OpName 'AnyOpName)) -> SimpleErrorMessage
NonAssociativeError (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: OpNameType). OpName a -> OpName 'AnyOpName
eraseOpName) NonEmpty (Qualified (OpName nameType))
grp)))
            [NonEmpty (Qualified (OpName nameType))]
nonAssoc

  mkPositionedError
    :: M.Map (Qualified (OpName nameType)) (NEL.NonEmpty SourceSpan)
    -> NEL.NonEmpty (Qualified (OpName nameType))
    -> SimpleErrorMessage
    -> ErrorMessage
  mkPositionedError :: Map (Qualified (OpName nameType)) (NonEmpty SourceSpan)
-> NonEmpty (Qualified (OpName nameType))
-> SimpleErrorMessage
-> ErrorMessage
mkPositionedError Map (Qualified (OpName nameType)) (NonEmpty SourceSpan)
chainOpSpans NonEmpty (Qualified (OpName nameType))
grp =
    [ErrorMessageHint] -> SimpleErrorMessage -> ErrorMessage
ErrorMessage
      [NonEmpty SourceSpan -> ErrorMessageHint
PositionedError (forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Map (Qualified (OpName nameType)) (NonEmpty SourceSpan)
chainOpSpans forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NonEmpty (Qualified (OpName nameType))
grp)]