Parse.hs

{-# LANGUAGE LambdaCase #-}
module Brassica.Paradigm.Parse (parseParadigm, parseStems) where

import Control.Category ((>>>))
import Data.Maybe (fromMaybe)
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

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' = void $ takeWhile1P (Just "whitespace") ((&&) <$> isSpace <*> (/='\n'))

sc :: Parser ()
sc = L.space space1' (L.skipLineComment "*") empty

eolf :: Parser ()
eolf = void (some eol) <|> eof

lexeme :: Parser a -> Parser a
lexeme = L.lexeme sc

symbol :: String -> Parser String
symbol = L.symbol sc

name :: Parser String
name = lexeme $ some alphaNumChar

slot :: Parser (String -> Process)
slot = do
    n <- L.signed (pure ()) L.decimal
    pure $ if n > 0 then Suffix n else Prefix (-n)

morphValue :: Parser String
morphValue = lexeme (takeWhile1P (Just "letter") $ (&&) <$> (not.isSpace) <*> (/=')'))

process :: Parser Process
process =
    Stem <$> lexeme (char '~' *> L.decimal)
    <|> (try (slot <* char '.') <*> morphValue)

oneOrMany :: Parser p -> Parser [p]
oneOrMany p = between (symbol "(") (symbol ")") (many p) <|> fmap pure p

affix :: Parser Affix
affix = oneOrMany process

grammeme :: Parser Grammeme
grammeme =
    Concrete <$> affix
    <|> Abstract . AbstractGrammeme <$> name

parseExpr :: Parser a -> Parser (Expr a)
parseExpr p = Any <$> ((All <$> some atom) `sepBy1` symbol "/")
  where
    atom = (Pred <$> p)
        <|> between (symbol "(") (symbol ")") (parseExpr p)

condition :: Parser (Expr Condition)
condition = do
    _ <- symbol "when"
    parseExpr $ between (symbol "(") (symbol ")") $
        try (Is <$> featureName <* symbol "is" <*> grammeme)
        <|> Not <$> featureName <* symbol "not" <*> grammeme
  where
    featureName = (Class <$ lexeme (char '#')) <|> (FeatureName <$> name)

feature :: Parser Feature
feature = do
    c <- fromMaybe (All []) <$> optional condition
    globalSlot <- optional $ try $ slot <* space1'
    case globalSlot of
        Nothing -> do
            n <- optional $ try $ name <* symbol "="
            gs <- some grammeme
            eolf
            return $ Feature c n gs
        Just globalSlot' -> do
            n <- optional $ try $ name <* symbol "="
            gs <- some $ oneOrMany $ process <|> (globalSlot' <$> morphValue)
            eolf
            return $ Feature c n (Concrete <$> gs)

mapping :: Parser (Expr AbstractGrammeme, Affix)
mapping = (,) <$> parseExpr (AbstractGrammeme <$> name) <* symbol ">" <*> some process <* eolf

statement :: Parser Statement
statement = sc *>
    (uncurry NewMapping <$> try mapping
    <|> NewFeature <$> 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.1.0/docs/Paradigm-Builder.md>.
parseParadigm :: String -> Either (ParseErrorBundle String Void) Paradigm
parseParadigm = runParser (many statement) ""

parseStems :: String -> (Maybe String, [String])
parseStems = words >>> \case
    ('#':p):ws -> (Just p, ws)
    ws -> (Nothing, ws)