module Language.PureScript.Sugar.Operators.Common where

import Prelude

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]

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)]