module Hermod.ReCon.Integer.Polynomial.Parser (Parser, intTerm) where

import           Hermod.ReCon.Common.Parser
import           Hermod.ReCon.Common.Types
import           Hermod.ReCon.Integer.Polynomial.Term (IntTerm (..), mul)

import           Data.Functor                         (void)
import           Text.Megaparsec
import           Text.Megaparsec.Char                 (char, space)

-- ---------------------------------------------------------------------------
-- IntTerm parser
-- ---------------------------------------------------------------------------

intTermCoeffOp :: Parser ()
intTermCoeffOp :: Parser ()
intTermCoeffOp = ParsecT Void Text Identity Char -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Char -> Parser ())
-> ParsecT Void Text Identity Char -> Parser ()
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'·' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'*'

-- | Atom-level IntTerm.
--
-- @
--   ( intTerm )
--   k · x          (signed coefficient times identifier)
--   k              (signed integer constant)
--   x              (identifier, implicit coefficient 1)
-- @
intTermAtom :: Parser IntTerm
intTermAtom :: Parser IntTerm
intTermAtom =
      Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'(' ParsecT Void Text Identity Char -> Parser () -> Parser ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space Parser () -> Parser IntTerm -> Parser IntTerm
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser IntTerm
intTerm Parser IntTerm -> Parser () -> Parser IntTerm
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space Parser IntTerm -> ParsecT Void Text Identity Char -> Parser IntTerm
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
')'
  Parser IntTerm -> Parser IntTerm -> Parser IntTerm
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser IntTerm -> Parser IntTerm
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (IntValue -> Text -> IntTerm
IntVar (IntValue -> Text -> IntTerm)
-> ParsecT Void Text Identity IntValue
-> ParsecT Void Text Identity (Text -> IntTerm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity IntValue
parseIntValue ParsecT Void Text Identity (Text -> IntTerm)
-> Parser () -> ParsecT Void Text Identity (Text -> IntTerm)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
intTermCoeffOp ParsecT Void Text Identity (Text -> IntTerm)
-> ParsecT Void Text Identity Text -> Parser IntTerm
forall a b.
ParsecT Void Text Identity (a -> b)
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT Void Text Identity Text
parseIdentifier)
  Parser IntTerm -> Parser IntTerm -> Parser IntTerm
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> IntValue -> IntTerm
IntConst (IntValue -> IntTerm)
-> ParsecT Void Text Identity IntValue -> Parser IntTerm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity IntValue
parseIntValue
  Parser IntTerm -> Parser IntTerm -> Parser IntTerm
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> IntValue -> Text -> IntTerm
IntVar IntValue
1 (Text -> IntTerm)
-> ParsecT Void Text Identity Text -> Parser IntTerm
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Text
parseIdentifier

-- | Full IntTerm: atoms joined by @+@ and @-@.
intTerm :: Parser IntTerm
intTerm :: Parser IntTerm
intTerm = do
  IntTerm
hd   <- Parser IntTerm
intTermAtom
  [Either IntTerm IntTerm]
rest <- ParsecT Void Text Identity (Either IntTerm IntTerm)
-> ParsecT Void Text Identity [Either IntTerm IntTerm]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void Text Identity (Either IntTerm IntTerm)
addOp
  IntTerm -> Parser IntTerm
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((IntTerm -> Either IntTerm IntTerm -> IntTerm)
-> IntTerm -> [Either IntTerm IntTerm] -> IntTerm
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl IntTerm -> Either IntTerm IntTerm -> IntTerm
applyOp IntTerm
hd [Either IntTerm IntTerm]
rest)
  where
    -- Each alternative wraps the leading space in `try` so that whitespace
    -- consumed before a non-additive token (e.g. '<') is backtracked.
    addOp :: ParsecT Void Text Identity (Either IntTerm IntTerm)
addOp =
          ParsecT Void Text Identity (Either IntTerm IntTerm)
-> ParsecT Void Text Identity (Either IntTerm IntTerm)
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space Parser ()
-> ParsecT Void Text Identity (Either IntTerm IntTerm)
-> ParsecT Void Text Identity (Either IntTerm IntTerm)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (IntTerm -> Either IntTerm IntTerm
forall a b. a -> Either a b
Left  (IntTerm -> Either IntTerm IntTerm)
-> Parser IntTerm
-> ParsecT Void Text Identity (Either IntTerm IntTerm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'+' ParsecT Void Text Identity Char -> Parser () -> Parser ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space Parser () -> Parser IntTerm -> Parser IntTerm
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser IntTerm
intTermAtom)))
      ParsecT Void Text Identity (Either IntTerm IntTerm)
-> ParsecT Void Text Identity (Either IntTerm IntTerm)
-> ParsecT Void Text Identity (Either IntTerm IntTerm)
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity (Either IntTerm IntTerm)
-> ParsecT Void Text Identity (Either IntTerm IntTerm)
forall a.
ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space Parser ()
-> ParsecT Void Text Identity (Either IntTerm IntTerm)
-> ParsecT Void Text Identity (Either IntTerm IntTerm)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (IntTerm -> Either IntTerm IntTerm
forall a b. b -> Either a b
Right (IntTerm -> Either IntTerm IntTerm)
-> Parser IntTerm
-> ParsecT Void Text Identity (Either IntTerm IntTerm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-' ParsecT Void Text Identity Char -> Parser () -> Parser ()
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space Parser () -> Parser IntTerm -> Parser IntTerm
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser IntTerm
intTermAtom)))
    applyOp :: IntTerm -> Either IntTerm IntTerm -> IntTerm
applyOp IntTerm
acc (Left  IntTerm
t) = IntTerm -> IntTerm -> IntTerm
IntSum IntTerm
acc IntTerm
t
    applyOp IntTerm
acc (Right IntTerm
t) = IntTerm -> IntTerm -> IntTerm
IntSum IntTerm
acc (IntValue -> IntTerm -> IntTerm
mul (-IntValue
1) IntTerm
t)