module Language.PureScript.Sugar.Operators.Expr where

import Prelude

import Control.Monad.Except
import Data.Functor.Identity

import qualified Text.Parsec as P
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
  :: MonadError MultipleErrors m
  => [[(Qualified (OpName 'ValueOpName), Associativity)]]
  -> Expr
  -> m Expr
matchExprOperators :: forall (m :: * -> *).
MonadError MultipleErrors m =>
[[(Qualified (OpName 'ValueOpName), Associativity)]]
-> Expr -> m Expr
matchExprOperators = 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 Expr -> Bool
isBinOp Expr -> Maybe (Expr, Expr, Expr)
extractOp Expr -> Maybe (SourceSpan, Qualified (OpName 'ValueOpName))
fromOp SourceSpan
-> Qualified (OpName 'ValueOpName) -> Expr -> Expr -> Expr
reapply [[Operator (Chain Expr) () Identity Expr]]
-> [[Operator (Chain Expr) () Identity Expr]]
modOpTable
  where

  isBinOp :: Expr -> Bool
  isBinOp :: Expr -> Bool
isBinOp BinaryNoParens{} = Bool
True
  isBinOp Expr
_ = Bool
False

  extractOp :: Expr -> Maybe (Expr, Expr, Expr)
  extractOp :: Expr -> Maybe (Expr, Expr, Expr)
extractOp (BinaryNoParens Expr
op Expr
l Expr
r)
    | PositionedValue SourceSpan
_ [Comment]
_ Expr
op' <- Expr
op = forall a. a -> Maybe a
Just (Expr
op', Expr
l, Expr
r)
    | Bool
otherwise = forall a. a -> Maybe a
Just (Expr
op, Expr
l, Expr
r)
  extractOp Expr
_ = forall a. Maybe a
Nothing

  fromOp :: Expr -> Maybe (SourceSpan, Qualified (OpName 'ValueOpName))
  fromOp :: Expr -> Maybe (SourceSpan, Qualified (OpName 'ValueOpName))
fromOp (Op SourceSpan
ss q :: Qualified (OpName 'ValueOpName)
q@(Qualified QualifiedBy
_ (OpName Text
_))) = forall a. a -> Maybe a
Just (SourceSpan
ss, Qualified (OpName 'ValueOpName)
q)
  fromOp Expr
_ = forall a. Maybe a
Nothing

  reapply :: SourceSpan -> Qualified (OpName 'ValueOpName) -> Expr -> Expr -> Expr
  reapply :: SourceSpan
-> Qualified (OpName 'ValueOpName) -> Expr -> Expr -> Expr
reapply SourceSpan
ss = Expr -> Expr -> Expr -> Expr
BinaryNoParens forall b c a. (b -> c) -> (a -> b) -> a -> c
. SourceSpan -> Qualified (OpName 'ValueOpName) -> Expr
Op SourceSpan
ss

  modOpTable
    :: [[P.Operator (Chain Expr) () Identity Expr]]
    -> [[P.Operator (Chain Expr) () Identity Expr]]
  modOpTable :: [[Operator (Chain Expr) () Identity Expr]]
-> [[Operator (Chain Expr) () Identity Expr]]
modOpTable [[Operator (Chain Expr) () Identity Expr]]
table =
    [ 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 (Expr -> Expr -> Expr -> Expr
BinaryNoParens forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parsec (Chain Expr) () Expr
parseTicks)) Assoc
P.AssocLeft ]
    forall a. a -> [a] -> [a]
: [[Operator (Chain Expr) () Identity Expr]]
table

  parseTicks :: P.Parsec (Chain Expr) () Expr
  parseTicks :: Parsec (Chain Expr) () Expr
parseTicks = 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) Expr -> Maybe Expr
fromOther) forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
P.<?> String
"infix function"
    where
    fromOther :: Expr -> Maybe Expr
fromOther (Op SourceSpan
_ Qualified (OpName 'ValueOpName)
_) = forall a. Maybe a
Nothing
    fromOther Expr
v = forall a. a -> Maybe a
Just Expr
v