module Brassica.Paradigm.Parse (parseParadigm) where

import Control.Monad (void)
import Data.Char (isSpace)
import Data.Void (Void)

import Text.Megaparsec
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L

import Brassica.Paradigm.Types
import Data.Maybe (fromMaybe)

type Parser = Parsec Void String

-- adapted from megaparsec source: like 'space1', but does not

-- consume newlines (which are important for rule separation)

space1' :: Parser ()
space1' :: Parser ()
space1' = ParsecT Void String Identity (Tokens String) -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void String Identity (Tokens String) -> Parser ())
-> ParsecT Void String Identity (Tokens String) -> Parser ()
forall a b. (a -> b) -> a -> b
$ Maybe String
-> (Token String -> Bool)
-> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"whitespace") (Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> (Token String -> Bool) -> Token String -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Bool
Token String -> Bool
isSpace (Token String -> Bool -> Bool)
-> (Token String -> Bool) -> Token String -> Bool
forall a b.
(Token String -> a -> b)
-> (Token String -> a) -> Token String -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\n'))

sc :: Parser ()
sc :: Parser ()
sc = Parser () -> Parser () -> Parser () -> Parser ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space Parser ()
space1' (Tokens String -> Parser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment String
Tokens String
"*") Parser ()
forall a. ParsecT Void String Identity a
forall (f :: * -> *) a. Alternative f => f a
empty

lexeme :: Parser a -> Parser a
lexeme :: forall a. Parser a -> Parser a
lexeme = Parser ()
-> ParsecT Void String Identity a -> ParsecT Void String Identity a
forall e s (m :: * -> *) a. MonadParsec e s m => m () -> m a -> m a
L.lexeme Parser ()
sc

symbol :: String -> Parser String
symbol :: String -> Parser String
symbol = Parser ()
-> Tokens String -> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol Parser ()
sc

name :: Parser String
name :: Parser String
name = Parser String -> Parser String
forall a. Parser a -> Parser a
lexeme (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$ ParsecT Void String Identity Char -> Parser String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void String Identity Char
ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar

slot :: Parser (String -> Process)
slot :: Parser (String -> Process)
slot = do
    Int
n <- Parser ()
-> ParsecT Void String Identity Int
-> ParsecT Void String Identity Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m () -> m a -> m a
L.signed (() -> Parser ()
forall a. a -> ParsecT Void String Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) ParsecT Void String Identity Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal
    (String -> Process) -> Parser (String -> Process)
forall a. a -> ParsecT Void String Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String -> Process) -> Parser (String -> Process))
-> (String -> Process) -> Parser (String -> Process)
forall a b. (a -> b) -> a -> b
$ if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then Int -> String -> Process
Suffix Int
n else Int -> String -> Process
Prefix (-Int
n)

morphValue :: Parser String
morphValue :: Parser String
morphValue = Parser String -> Parser String
forall a. Parser a -> Parser a
lexeme (Maybe String
-> (Token String -> Bool)
-> ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (String -> Maybe String
forall a. a -> Maybe a
Just String
"letter") ((Token String -> Bool)
 -> ParsecT Void String Identity (Tokens String))
-> (Token String -> Bool)
-> ParsecT Void String Identity (Tokens String)
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool)
-> (Token String -> Bool) -> Token String -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Bool
not(Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> Bool
isSpace) (Token String -> Bool -> Bool)
-> (Token String -> Bool) -> Token String -> Bool
forall a b.
(Token String -> a -> b)
-> (Token String -> a) -> Token String -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
')'))

process :: Parser Process
process :: Parser Process
process = Parser (String -> Process)
slot Parser (String -> Process)
-> ParsecT Void String Identity Char -> Parser (String -> Process)
forall a b.
ParsecT Void String Identity a
-> ParsecT Void String Identity b -> ParsecT Void String Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Token String -> ParsecT Void String Identity (Token String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token String
'.' Parser (String -> Process) -> Parser String -> Parser Process
forall a b.
ParsecT Void String Identity (a -> b)
-> ParsecT Void String Identity a -> ParsecT Void String Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser String
morphValue

oneOrMany :: Parser p -> Parser [p]
oneOrMany :: forall p. Parser p -> Parser [p]
oneOrMany Parser p
p = Parser String
-> Parser String
-> ParsecT Void String Identity [p]
-> ParsecT Void String Identity [p]
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (String -> Parser String
symbol String
"(") (String -> Parser String
symbol String
")") (Parser p -> ParsecT Void String Identity [p]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser p
p) ParsecT Void String Identity [p]
-> ParsecT Void String Identity [p]
-> ParsecT Void String Identity [p]
forall a.
ParsecT Void String Identity a
-> ParsecT Void String Identity a -> ParsecT Void String Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (p -> [p]) -> Parser p -> ParsecT Void String Identity [p]
forall a b.
(a -> b)
-> ParsecT Void String Identity a -> ParsecT Void String Identity b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap p -> [p]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Parser p
p

affix :: Parser Affix
affix :: Parser Affix
affix = Parser Process -> Parser Affix
forall p. Parser p -> Parser [p]
oneOrMany Parser Process
process

grammeme :: Parser Grammeme
grammeme :: Parser Grammeme
grammeme =
    Affix -> Grammeme
Concrete (Affix -> Grammeme) -> Parser Affix -> Parser Grammeme
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Affix
affix
    Parser Grammeme -> Parser Grammeme -> Parser Grammeme
forall a.
ParsecT Void String Identity a
-> ParsecT Void String Identity a -> ParsecT Void String Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> AbstractGrammeme -> Grammeme
Abstract (AbstractGrammeme -> Grammeme)
-> (String -> AbstractGrammeme) -> String -> Grammeme
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AbstractGrammeme
AbstractGrammeme (String -> Grammeme) -> Parser String -> Parser Grammeme
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
name

condition :: Parser Condition
condition :: Parser Condition
condition = do
    String
_ <- String -> Parser String
symbol String
"when"
    Parser String
-> Parser String -> Parser Condition -> Parser Condition
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (String -> Parser String
symbol String
"(") (String -> Parser String
symbol String
")") (Parser Condition -> Parser Condition)
-> Parser Condition -> Parser Condition
forall a b. (a -> b) -> a -> b
$
        Parser Condition -> Parser Condition
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (FeatureName -> Grammeme -> Condition
Is (FeatureName -> Grammeme -> Condition)
-> (String -> FeatureName) -> String -> Grammeme -> Condition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FeatureName
FeatureName (String -> Grammeme -> Condition)
-> Parser String
-> ParsecT Void String Identity (Grammeme -> Condition)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
name ParsecT Void String Identity (Grammeme -> Condition)
-> Parser String
-> ParsecT Void String Identity (Grammeme -> Condition)
forall a b.
ParsecT Void String Identity a
-> ParsecT Void String Identity b -> ParsecT Void String Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> Parser String
symbol String
"is" ParsecT Void String Identity (Grammeme -> Condition)
-> Parser Grammeme -> Parser Condition
forall a b.
ParsecT Void String Identity (a -> b)
-> ParsecT Void String Identity a -> ParsecT Void String Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Grammeme
grammeme)
        Parser Condition -> Parser Condition -> Parser Condition
forall a.
ParsecT Void String Identity a
-> ParsecT Void String Identity a -> ParsecT Void String Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FeatureName -> Grammeme -> Condition
Not (FeatureName -> Grammeme -> Condition)
-> (String -> FeatureName) -> String -> Grammeme -> Condition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FeatureName
FeatureName (String -> Grammeme -> Condition)
-> Parser String
-> ParsecT Void String Identity (Grammeme -> Condition)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
name ParsecT Void String Identity (Grammeme -> Condition)
-> Parser String
-> ParsecT Void String Identity (Grammeme -> Condition)
forall a b.
ParsecT Void String Identity a
-> ParsecT Void String Identity b -> ParsecT Void String Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> Parser String
symbol String
"not" ParsecT Void String Identity (Grammeme -> Condition)
-> Parser Grammeme -> Parser Condition
forall a b.
ParsecT Void String Identity (a -> b)
-> ParsecT Void String Identity a -> ParsecT Void String Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Grammeme
grammeme

feature :: Parser Feature
feature :: Parser Feature
feature = do
    Condition
c <- Condition -> Maybe Condition -> Condition
forall a. a -> Maybe a -> a
fromMaybe Condition
Always (Maybe Condition -> Condition)
-> ParsecT Void String Identity (Maybe Condition)
-> Parser Condition
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Condition -> ParsecT Void String Identity (Maybe Condition)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Condition
condition
    Maybe (String -> Process)
globalSlot <- Parser (String -> Process)
-> ParsecT Void String Identity (Maybe (String -> Process))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser (String -> Process)
 -> ParsecT Void String Identity (Maybe (String -> Process)))
-> Parser (String -> Process)
-> ParsecT Void String Identity (Maybe (String -> Process))
forall a b. (a -> b) -> a -> b
$ Parser (String -> Process) -> Parser (String -> Process)
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser (String -> Process) -> Parser (String -> Process))
-> Parser (String -> Process) -> Parser (String -> Process)
forall a b. (a -> b) -> a -> b
$ Parser (String -> Process)
slot Parser (String -> Process)
-> Parser () -> Parser (String -> Process)
forall a b.
ParsecT Void String Identity a
-> ParsecT Void String Identity b -> ParsecT Void String Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
space1'
    case Maybe (String -> Process)
globalSlot of
        Maybe (String -> Process)
Nothing -> do
            Maybe String
n <- Parser String -> ParsecT Void String Identity (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser String -> ParsecT Void String Identity (Maybe String))
-> Parser String -> ParsecT Void String Identity (Maybe String)
forall a b. (a -> b) -> a -> b
$ Parser String -> Parser String
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$ Parser String
name Parser String -> Parser String -> Parser String
forall a b.
ParsecT Void String Identity a
-> ParsecT Void String Identity b -> ParsecT Void String Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> Parser String
symbol String
"="
            [Grammeme]
gs <- Parser Grammeme -> ParsecT Void String Identity [Grammeme]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some Parser Grammeme
grammeme
            Maybe (Tokens String)
_ <- ParsecT Void String Identity (Tokens String)
-> ParsecT Void String Identity (Maybe (Tokens String))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
            Feature -> Parser Feature
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Feature -> Parser Feature) -> Feature -> Parser Feature
forall a b. (a -> b) -> a -> b
$ Condition -> Maybe FeatureName -> [Grammeme] -> Feature
Feature Condition
c (String -> FeatureName
FeatureName (String -> FeatureName) -> Maybe String -> Maybe FeatureName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
n) [Grammeme]
gs
        Just String -> Process
globalSlot' -> do
            Maybe String
n <- Parser String -> ParsecT Void String Identity (Maybe String)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Parser String -> ParsecT Void String Identity (Maybe String))
-> Parser String -> ParsecT Void String Identity (Maybe String)
forall a b. (a -> b) -> a -> b
$ Parser String -> Parser String
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (Parser String -> Parser String) -> Parser String -> Parser String
forall a b. (a -> b) -> a -> b
$ Parser String
name Parser String -> Parser String -> Parser String
forall a b.
ParsecT Void String Identity a
-> ParsecT Void String Identity b -> ParsecT Void String Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> Parser String
symbol String
"="
            [Affix]
gs <- Parser Affix -> ParsecT Void String Identity [Affix]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (Parser Affix -> ParsecT Void String Identity [Affix])
-> Parser Affix -> ParsecT Void String Identity [Affix]
forall a b. (a -> b) -> a -> b
$ Parser Process -> Parser Affix
forall p. Parser p -> Parser [p]
oneOrMany (Parser Process -> Parser Affix) -> Parser Process -> Parser Affix
forall a b. (a -> b) -> a -> b
$ Parser Process
process Parser Process -> Parser Process -> Parser Process
forall a.
ParsecT Void String Identity a
-> ParsecT Void String Identity a -> ParsecT Void String Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> Process
globalSlot' (String -> Process) -> Parser String -> Parser Process
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
morphValue)
            Maybe (Tokens String)
_ <- ParsecT Void String Identity (Tokens String)
-> ParsecT Void String Identity (Maybe (Tokens String))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
            Feature -> Parser Feature
forall a. a -> ParsecT Void String Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Feature -> Parser Feature) -> Feature -> Parser Feature
forall a b. (a -> b) -> a -> b
$ Condition -> Maybe FeatureName -> [Grammeme] -> Feature
Feature Condition
c (String -> FeatureName
FeatureName (String -> FeatureName) -> Maybe String -> Maybe FeatureName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
n) (Affix -> Grammeme
Concrete (Affix -> Grammeme) -> [Affix] -> [Grammeme]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Affix]
gs)

mapping :: Parser ([AbstractGrammeme], Affix)
mapping :: Parser ([AbstractGrammeme], Affix)
mapping = (,) ([AbstractGrammeme] -> Affix -> ([AbstractGrammeme], Affix))
-> ParsecT Void String Identity [AbstractGrammeme]
-> ParsecT
     Void String Identity (Affix -> ([AbstractGrammeme], Affix))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Void String Identity AbstractGrammeme
-> Parser String -> ParsecT Void String Identity [AbstractGrammeme]
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
manyTill (String -> AbstractGrammeme
AbstractGrammeme (String -> AbstractGrammeme)
-> Parser String -> ParsecT Void String Identity AbstractGrammeme
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
name) (String -> Parser String
symbol String
">") ParsecT Void String Identity (Affix -> ([AbstractGrammeme], Affix))
-> Parser Affix -> Parser ([AbstractGrammeme], Affix)
forall a b.
ParsecT Void String Identity (a -> b)
-> ParsecT Void String Identity a -> ParsecT Void String Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Affix
affix Parser ([AbstractGrammeme], Affix)
-> ParsecT Void String Identity (Maybe (Tokens String))
-> Parser ([AbstractGrammeme], Affix)
forall a b.
ParsecT Void String Identity a
-> ParsecT Void String Identity b -> ParsecT Void String Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void String Identity (Tokens String)
-> ParsecT Void String Identity (Maybe (Tokens String))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Void String Identity (Tokens String)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol

statement :: Parser Statement
statement :: Parser Statement
statement = Parser ()
sc Parser () -> Parser Statement -> Parser Statement
forall a b.
ParsecT Void String Identity a
-> ParsecT Void String Identity b -> ParsecT Void String Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
    (([AbstractGrammeme] -> Affix -> Statement)
-> ([AbstractGrammeme], Affix) -> Statement
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [AbstractGrammeme] -> Affix -> Statement
NewMapping (([AbstractGrammeme], Affix) -> Statement)
-> Parser ([AbstractGrammeme], Affix) -> Parser Statement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ([AbstractGrammeme], Affix)
-> Parser ([AbstractGrammeme], Affix)
forall a. Parser a -> Parser a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser ([AbstractGrammeme], Affix)
mapping
    Parser Statement -> Parser Statement -> Parser Statement
forall a.
ParsecT Void String Identity a
-> ParsecT Void String Identity a -> ParsecT Void String Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Feature -> Statement
NewFeature (Feature -> Statement) -> Parser Feature -> Parser Statement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Feature
feature)

-- | Parse a 'String' in Brassica paradigm syntax into a 'Paradigm'.

-- Returns 'Left' if the input string is malformed.

--

-- For details on the syntax, refer to <https://github.com/bradrn/brassica/blob/v1.0.0/docs/Paradigm-Builder.md>.

parseParadigm :: String -> Either (ParseErrorBundle String Void) Paradigm
parseParadigm :: String -> Either (ParseErrorBundle String Void) Paradigm
parseParadigm = Parsec Void String Paradigm
-> String
-> String
-> Either (ParseErrorBundle String Void) Paradigm
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser (Parser Statement -> Parsec Void String Paradigm
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser Statement
statement) String
""