{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

module Algebra.Ring.Polynomial.Parser
  ( unlabeldVarP,
    labeledVarP,
    polynomialP,
    rationalP,
    integerP,
    parsePolynomialWith,
    Parser,
    VariableParser,
  )
where

import Algebra.Internal
import Algebra.Ring.Polynomial.Class
import Algebra.Ring.Polynomial.Monomial
import AlgebraicPrelude hiding (char)
import Control.Arrow (left)
import Control.Monad.Combinators.Expr
import qualified Data.List.NonEmpty as NE
import qualified Data.Ratio as P
#if MIN_VERSION_singletons(3,0,0)
import Data.List.Singletons
#else
import Data.Singletons.Prelude.List
#endif

import qualified Data.Text as T
import Data.Void
import GHC.TypeLits (Symbol)
import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L
import qualified Prelude as P

lexeme :: (MonadParsec e T.Text m) => m a -> m a
lexeme :: m a -> m a
lexeme = m () -> m a -> m a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space

symbol :: (MonadParsec e T.Text m) => T.Text -> m T.Text
symbol :: Text -> m Text
symbol = m () -> Tokens Text -> m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol m ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space

type Parser = Parsec Void T.Text

type VariableParser n = Parser (Ordinal n)

unlabeldVarP ::
  (KnownNat n) =>
  proxy n ->
  T.Text ->
  VariableParser n
unlabeldVarP :: proxy n -> Text -> VariableParser n
unlabeldVarP proxy n
pxy Text
pfx = VariableParser n -> VariableParser n
forall e (m :: * -> *) a. MonadParsec e Text m => m a -> m a
lexeme (VariableParser n -> VariableParser n)
-> VariableParser n -> VariableParser n
forall a b. (a -> b) -> a -> b
$ do
  Natural
i <- Text -> ParsecT Void Text Identity Text
forall e (m :: * -> *). MonadParsec e Text m => Text -> m Text
symbol Text
pfx ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a b. Applicative f => f a -> f b -> 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
-> ParsecT Void Text Identity Natural
-> ParsecT Void Text Identity Natural
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Natural
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal
  case Natural -> Maybe (Ordinal n)
forall (n :: Nat). KnownNat n => Natural -> Maybe (Ordinal n)
naturalToOrd Natural
i of
    Just Ordinal n
o -> Ordinal n -> VariableParser n
forall (m :: * -> *) a. Monad m => a -> m a
return Ordinal n
o
    Maybe (Ordinal n)
Nothing -> String -> VariableParser n
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> VariableParser n) -> String -> VariableParser n
forall a b. (a -> b) -> a -> b
$ String
"Number " String -> String -> String
forall w. Monoid w => w -> w -> w
++ Natural -> String
forall a. Show a => a -> String
show Natural
i String -> String -> String
forall w. Monoid w => w -> w -> w
++ String
" is out of bound: " String -> String -> String
forall w. Monoid w => w -> w -> w
++ Natural -> String
forall a. Show a => a -> String
show (proxy n -> Natural
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Natural
natVal proxy n
pxy)

fromSingList :: Sing (list :: [Symbol]) -> [T.Text]
#if MIN_VERSION_singletons(2,3,0)
fromSingList :: Sing list -> [Text]
fromSingList = Sing list -> [Text]
forall k (a :: k). SingKind k => Sing a -> Demote k
fromSing
#else
fromSingList = map T.pack . fromSing
#endif

labeledVarP ::
  forall list.
  Sing (list :: [Symbol]) ->
  VariableParser (Length list)
labeledVarP :: Sing list -> VariableParser (Length list)
labeledVarP Sing list
slist =
  [ParsecT Void Text Identity (Ordinal (Length list))]
-> ParsecT Void Text Identity (Ordinal (Length list))
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([ParsecT Void Text Identity (Ordinal (Length list))]
 -> ParsecT Void Text Identity (Ordinal (Length list)))
-> [ParsecT Void Text Identity (Ordinal (Length list))]
-> ParsecT Void Text Identity (Ordinal (Length list))
forall a b. (a -> b) -> a -> b
$ (Ordinal (Length list)
 -> Text -> ParsecT Void Text Identity (Ordinal (Length list)))
-> [Ordinal (Length list)]
-> [Text]
-> [ParsecT Void Text Identity (Ordinal (Length list))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Ordinal (Length list)
-> Text -> ParsecT Void Text Identity (Ordinal (Length list))
forall (f :: * -> *) e a. MonadParsec e Text f => a -> Text -> f a
go (SNat (Length list) -> [Ordinal (Length list)]
forall (n :: Nat). SNat n -> [Ordinal n]
enumOrdinal (SNat (Length list) -> [Ordinal (Length list)])
-> SNat (Length list) -> [Ordinal (Length list)]
forall a b. (a -> b) -> a -> b
$ Sing (Length list) -> SNat (Length list)
forall (n :: Nat). Sing n -> SNat n
singToSNat (Sing (Length list) -> SNat (Length list))
-> Sing (Length list) -> SNat (Length list)
forall a b. (a -> b) -> a -> b
$ Sing list -> Sing (Apply LengthSym0 list)
forall (t :: * -> *) a (t1 :: t a).
SFoldable t =>
Sing t1 -> Sing (Apply LengthSym0 t1)
sLength Sing list
slist) ([Text] -> [ParsecT Void Text Identity (Ordinal (Length list))])
-> [Text] -> [ParsecT Void Text Identity (Ordinal (Length list))]
forall a b. (a -> b) -> a -> b
$ Sing list -> [Text]
forall (list :: [Symbol]). Sing list -> [Text]
fromSingList Sing list
slist
  where
    go :: a -> Text -> f a
go a
i Text
v = a
i a -> f Text -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> f Text
forall e (m :: * -> *). MonadParsec e Text m => Text -> m Text
symbol Text
v

varPowP :: KnownNat n => VariableParser n -> Parser (OrderedMonomial ord n)
varPowP :: VariableParser n -> Parser (OrderedMonomial ord n)
varPowP VariableParser n
vp =
  Parser (OrderedMonomial ord n) -> Parser (OrderedMonomial ord n)
forall e (m :: * -> *) a. MonadParsec e Text m => m a -> m a
lexeme (Parser (OrderedMonomial ord n) -> Parser (OrderedMonomial ord n))
-> Parser (OrderedMonomial ord n) -> Parser (OrderedMonomial ord n)
forall a b. (a -> b) -> a -> b
$
    OrderedMonomial ord n -> Natural -> OrderedMonomial ord n
forall r. Unital r => r -> Natural -> r
pow (OrderedMonomial ord n -> Natural -> OrderedMonomial ord n)
-> Parser (OrderedMonomial ord n)
-> ParsecT Void Text Identity (Natural -> OrderedMonomial ord n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Proxy ord -> Monomial n -> OrderedMonomial ord n
forall k (proxy :: k -> *) (ord :: k) (n :: Nat).
proxy ord -> Monomial n -> OrderedMonomial ord n
orderMonomial Proxy ord
forall k (t :: k). Proxy t
Proxy (Monomial n -> OrderedMonomial ord n)
-> (Ordinal n -> Monomial n) -> Ordinal n -> OrderedMonomial ord n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SNat n -> Ordinal n -> Monomial n
forall (n :: Nat). SNat n -> Ordinal n -> Monomial n
varMonom SNat n
forall (n :: Nat). KnownNat n => SNat n
sNat (Ordinal n -> OrderedMonomial ord n)
-> VariableParser n -> Parser (OrderedMonomial ord n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VariableParser n
vp)
      ParsecT Void Text Identity (Natural -> OrderedMonomial ord n)
-> ParsecT Void Text Identity Natural
-> Parser (OrderedMonomial ord n)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Natural
-> ParsecT Void Text Identity Natural
-> ParsecT Void Text Identity Natural
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option (Natural
1 :: Natural) (Text -> ParsecT Void Text Identity Text
forall e (m :: * -> *). MonadParsec e Text m => Text -> m Text
symbol Text
"^" ParsecT Void Text Identity Text
-> ParsecT Void Text Identity Natural
-> ParsecT Void Text Identity Natural
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void Text Identity Natural
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal)

monomialP :: KnownNat n => VariableParser n -> Parser (OrderedMonomial ord n)
monomialP :: VariableParser n -> Parser (OrderedMonomial ord n)
monomialP VariableParser n
v =
  [OrderedMonomial ord n] -> OrderedMonomial ord n
forall (f :: * -> *) r. (Foldable f, Unital r) => f r -> r
product ([OrderedMonomial ord n] -> OrderedMonomial ord n)
-> ParsecT Void Text Identity [OrderedMonomial ord n]
-> Parser (OrderedMonomial ord n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VariableParser n -> Parser (OrderedMonomial ord n)
forall (n :: Nat) ord.
KnownNat n =>
VariableParser n -> Parser (OrderedMonomial ord n)
varPowP VariableParser n
v Parser (OrderedMonomial ord n)
-> ParsecT Void Text Identity (Maybe Text)
-> ParsecT Void Text Identity [OrderedMonomial ord n]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy1` ParsecT Void Text Identity Text
-> ParsecT Void Text Identity (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Text -> ParsecT Void Text Identity Text
forall e (m :: * -> *). MonadParsec e Text m => Text -> m Text
symbol Text
"*")

factorP ::
  (IsOrderedPolynomial poly) =>
  proxy poly ->
  Parser (Coefficient poly) ->
  VariableParser (Arity poly) ->
  Parser poly
factorP :: proxy poly
-> Parser (Coefficient poly)
-> VariableParser (Arity poly)
-> Parser poly
factorP proxy poly
_ Parser (Coefficient poly)
coeffP VariableParser (Arity poly)
varP =
  Coefficient poly -> poly
forall poly. IsPolynomial poly => Coefficient poly -> poly
injectCoeff (Coefficient poly -> poly)
-> Parser (Coefficient poly) -> Parser poly
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Coefficient poly) -> Parser (Coefficient poly)
forall e (m :: * -> *) a. MonadParsec e Text m => m a -> m a
lexeme Parser (Coefficient poly)
coeffP
    Parser poly -> Parser poly -> Parser poly
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> OrderedMonomial (MOrder poly) (Arity poly) -> poly
forall poly.
IsOrderedPolynomial poly =>
OrderedMonomial (MOrder poly) (Arity poly) -> poly
fromOrderedMonomial (OrderedMonomial (MOrder poly) (Arity poly) -> poly)
-> ParsecT
     Void Text Identity (OrderedMonomial (MOrder poly) (Arity poly))
-> Parser poly
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VariableParser (Arity poly)
-> ParsecT
     Void Text Identity (OrderedMonomial (MOrder poly) (Arity poly))
forall (n :: Nat) ord.
KnownNat n =>
VariableParser n -> Parser (OrderedMonomial ord n)
monomialP VariableParser (Arity poly)
varP

binary :: MonadParsec e Text m => Text -> (a -> a -> a) -> Operator m a
binary :: Text -> (a -> a -> a) -> Operator m a
binary Text
name a -> a -> a
f = m (a -> a -> a) -> Operator m a
forall (m :: * -> *) a. m (a -> a -> a) -> Operator m a
InfixL (a -> a -> a
f (a -> a -> a) -> m Text -> m (a -> a -> a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> m Text
forall e (m :: * -> *). MonadParsec e Text m => Text -> m Text
symbol Text
name)

prefix :: MonadParsec e Text m => Text -> (a -> a) -> Operator m a
prefix :: Text -> (a -> a) -> Operator m a
prefix Text
name a -> a
f = m (a -> a) -> Operator m a
forall (m :: * -> *) a. m (a -> a) -> Operator m a
Prefix (a -> a
f (a -> a) -> m Text -> m (a -> a)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Text -> m Text
forall e (m :: * -> *). MonadParsec e Text m => Text -> m Text
symbol Text
name)

table :: (CoeffRing a, MonadParsec e Text m) => [[Operator m a]]
table :: [[Operator m a]]
table =
  [
    [ Text -> (a -> a) -> Operator m a
forall e (m :: * -> *) a.
MonadParsec e Text m =>
Text -> (a -> a) -> Operator m a
prefix Text
"-" a -> a
forall r. Group r => r -> r
negate
    , Text -> (a -> a) -> Operator m a
forall e (m :: * -> *) a.
MonadParsec e Text m =>
Text -> (a -> a) -> Operator m a
prefix Text
"+" a -> a
forall a. a -> a
id
    ]
  , [Text -> (a -> a -> a) -> Operator m a
forall e (m :: * -> *) a.
MonadParsec e Text m =>
Text -> (a -> a -> a) -> Operator m a
binary Text
"*" a -> a -> a
forall r. Multiplicative r => r -> r -> r
(*)]
  , [Text -> (a -> a -> a) -> Operator m a
forall e (m :: * -> *) a.
MonadParsec e Text m =>
Text -> (a -> a -> a) -> Operator m a
binary Text
"+" a -> a -> a
forall r. Additive r => r -> r -> r
(+), Text -> (a -> a -> a) -> Operator m a
forall e (m :: * -> *) a.
MonadParsec e Text m =>
Text -> (a -> a -> a) -> Operator m a
binary Text
"-" (-)]
  ]

polynomialP ::
  (IsOrderedPolynomial poly) =>
  Parser (Coefficient poly) ->
  VariableParser (Arity poly) ->
  Parser poly
polynomialP :: Parser (Coefficient poly)
-> VariableParser (Arity poly) -> Parser poly
polynomialP Parser (Coefficient poly)
coeffP VariableParser (Arity poly)
varP = Parser poly
body
  where
    body :: Parser poly
body = Parser poly
-> [[Operator (ParsecT Void Text Identity) poly]] -> Parser poly
forall (m :: * -> *) a.
MonadPlus m =>
m a -> [[Operator m a]] -> m a
makeExprParser (Proxy poly
-> Parser (Coefficient poly)
-> VariableParser (Arity poly)
-> Parser poly
forall poly (proxy :: * -> *).
IsOrderedPolynomial poly =>
proxy poly
-> Parser (Coefficient poly)
-> VariableParser (Arity poly)
-> Parser poly
factorP Proxy poly
forall k (t :: k). Proxy t
Proxy Parser (Coefficient poly)
coeffP VariableParser (Arity poly)
varP) [[Operator (ParsecT Void Text Identity) poly]]
forall a e (m :: * -> *).
(CoeffRing a, MonadParsec e Text m) =>
[[Operator m a]]
table

rationalP :: Field k => Parser k
rationalP :: Parser k
rationalP = Rational -> k
forall k. Field k => Rational -> k
fromRat (Rational -> k) -> (Scientific -> Rational) -> Scientific -> k
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Rational
forall a. Real a => a -> Rational
P.toRational (Scientific -> k)
-> ParsecT Void Text Identity Scientific -> Parser k
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void Text Identity Scientific
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m Scientific
L.scientific

integerP :: Parser Integer
integerP :: Parser Integer
integerP = Integer -> Integer
forall r. Ring r => Integer -> r
fromInteger' (Integer -> Integer) -> Parser Integer -> Parser Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal

fromRat :: Field k => P.Rational -> k
fromRat :: Rational -> k
fromRat Rational
r = Integer -> k
forall r. Ring r => Integer -> r
fromInteger' (Rational -> Integer
forall a. Ratio a -> a
P.numerator Rational
r) k -> k -> k
forall r. Division r => r -> r -> r
/ Integer -> k
forall r. Ring r => Integer -> r
fromInteger' (Rational -> Integer
forall a. Ratio a -> a
P.denominator Rational
r)

parsePolynomialWith ::
  (IsOrderedPolynomial poly) =>
  Parser (Coefficient poly) ->
  VariableParser (Arity poly) ->
  T.Text ->
  Either String poly
parsePolynomialWith :: Parser (Coefficient poly)
-> VariableParser (Arity poly) -> Text -> Either String poly
parsePolynomialWith Parser (Coefficient poly)
coeffP VariableParser (Arity poly)
varP =
  (ParseErrorBundle Text Void -> String)
-> Either (ParseErrorBundle Text Void) poly -> Either String poly
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (ParseError Text Void -> String
forall s e.
(VisualStream s, ShowErrorComponent e) =>
ParseError s e -> String
parseErrorPretty (ParseError Text Void -> String)
-> (ParseErrorBundle Text Void -> ParseError Text Void)
-> ParseErrorBundle Text Void
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (ParseError Text Void) -> ParseError Text Void
forall a. NonEmpty a -> a
NE.head (NonEmpty (ParseError Text Void) -> ParseError Text Void)
-> (ParseErrorBundle Text Void -> NonEmpty (ParseError Text Void))
-> ParseErrorBundle Text Void
-> ParseError Text Void
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text Void -> NonEmpty (ParseError Text Void)
forall s e. ParseErrorBundle s e -> NonEmpty (ParseError s e)
bundleErrors) (Either (ParseErrorBundle Text Void) poly -> Either String poly)
-> (Text -> Either (ParseErrorBundle Text Void) poly)
-> Text
-> Either String poly
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Void Text poly
-> String -> Text -> Either (ParseErrorBundle Text Void) poly
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space ParsecT Void Text Identity ()
-> Parsec Void Text poly -> Parsec Void Text poly
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser (Coefficient poly)
-> VariableParser (Arity poly) -> Parsec Void Text poly
forall poly.
IsOrderedPolynomial poly =>
Parser (Coefficient poly)
-> VariableParser (Arity poly) -> Parser poly
polynomialP Parser (Coefficient poly)
coeffP VariableParser (Arity poly)
varP Parsec Void Text poly
-> ParsecT Void Text Identity () -> Parsec Void Text poly
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) String
"input"