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' = forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (forall a. a -> Maybe a
Just String
"whitespace") (Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> Bool
isSpace forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. Eq a => a -> a -> Bool
/=Char
'\n'))

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

lexeme :: Parser a -> Parser a
lexeme :: forall a. Parser a -> Parser a
lexeme = 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 = 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 = forall a. Parser a -> Parser a
lexeme forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some 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 <- forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m () -> m a -> m a
L.signed (forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ if Int
n 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 = forall a. Parser a -> Parser a
lexeme (forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (forall a. a -> Maybe a
Just String
"letter") forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> Bool
isSpace) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. Eq a => a -> a -> Bool
/=Char
')'))

process :: Parser Process
process :: Parser Process
process = Parser (String -> Process)
slot forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'.' 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 = 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
")") (forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many Parser p
p) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. Applicative f => a -> f a
pure Parser p
p

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

grammeme :: Parser Grammeme
grammeme :: Parser Grammeme
grammeme =
    Affix -> Grammeme
Concrete forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Affix
affix
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> AbstractGrammeme -> Grammeme
Abstract forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AbstractGrammeme
AbstractGrammeme 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"
    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
")") forall a b. (a -> b) -> a -> b
$
        forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (FeatureName -> Grammeme -> Condition
Is forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FeatureName
FeatureName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
name forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> Parser String
symbol String
"is" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Grammeme
grammeme)
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> FeatureName -> Grammeme -> Condition
Not forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> FeatureName
FeatureName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
name forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> Parser String
symbol String
"not" 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 <- forall a. a -> Maybe a -> a
fromMaybe Condition
Always forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser Condition
condition
    Maybe (String -> Process)
globalSlot <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ Parser (String -> Process)
slot 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 <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ Parser String
name forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> Parser String
symbol String
"="
            [Grammeme]
gs <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some Parser Grammeme
grammeme
            Maybe (Tokens String)
_ <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Condition -> Maybe FeatureName -> [Grammeme] -> Feature
Feature Condition
c (String -> FeatureName
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 <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ Parser String
name forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* String -> Parser String
symbol String
"="
            [Affix]
gs <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall a b. (a -> b) -> a -> b
$ forall p. Parser p -> Parser [p]
oneOrMany forall a b. (a -> b) -> a -> b
$ Parser Process
process forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (String -> Process
globalSlot' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser String
morphValue)
            Maybe (Tokens String)
_ <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Tokens s)
eol
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Condition -> Maybe FeatureName -> [Grammeme] -> Feature
Feature Condition
c (String -> FeatureName
FeatureName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
n) (Affix -> Grammeme
Concrete forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Affix]
gs)

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

statement :: Parser Statement
statement :: Parser Statement
statement = Parser ()
sc forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*>
    (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [AbstractGrammeme] -> Affix -> Statement
NewMapping forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser ([AbstractGrammeme], Affix)
mapping
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Feature -> Statement
NewFeature 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/v0.0.3/Documentation.md#paradigm-builder>.

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