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