{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures   #-}
{-# LANGUAGE LambdaCase       #-}
{-# LANGUAGE RecordWildCards  #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Brassica.SoundChange.Parse
    ( parseRule
    , parseRuleWithCategories
    , parseSoundChanges
      -- ** Re-export
    , errorBundlePretty
    ) where

import Data.Char (isSpace)
import Data.Foldable (asum)
import Data.List (transpose)
import Data.Maybe (isNothing, isJust, fromJust)
import Data.Void (Void)

import Control.Applicative.Permutations
import Control.Monad.State
import qualified Data.Map.Strict as M

import Text.Megaparsec hiding (State)
import Text.Megaparsec.Char
import qualified Text.Megaparsec.Char.Lexer as L

import Brassica.SoundChange.Types
import qualified Brassica.SoundChange.Category as C

newtype Config = Config
    { Config -> Categories Grapheme
categories :: C.Categories Grapheme
    }
type Parser = ParsecT Void String (State Config)

class ParseLexeme (a :: LexemeType) where
    parseLexeme :: Parser (Lexeme a)

-- space consumer which does not match newlines
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 [Char]
";") forall (f :: * -> *) a. Alternative f => f a
empty
  where
    -- adapted from megaparsec source: like 'space1', but does not
    -- consume newlines (which are important for rule separation)
    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 [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (forall a. a -> Maybe a
Just [Char]
"white space") (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'))

-- space consumer which matches newlines
scn :: Parser ()
scn :: Parser ()
scn = forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1 (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Tokens s -> m ()
L.skipLineComment [Char]
";") 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 :: [Char] -> Parser [Char]
symbol = forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> Tokens s -> m (Tokens s)
L.symbol Parser ()
sc

keyChars :: [Char]
keyChars :: [Char]
keyChars = [Char]
"#[](){}>\\→/_^%~*@"

nonzero :: Parser Int
nonzero :: Parser Int
nonzero = forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"nonzero postive number" 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
$ do
    Int
n <- forall a. Parser a -> Parser a
lexeme forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ Char, Num a) =>
m a
L.decimal
    forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Int
nforall a. Ord a => a -> a -> Bool
>Int
0
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
n

parseGrapheme :: Parser (Grapheme, Bool)
parseGrapheme :: Parser (Grapheme, Bool)
parseGrapheme = forall a. Parser a -> Parser a
lexeme forall a b. (a -> b) -> a -> b
$ Parser (Grapheme, Bool)
parseBoundary forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Grapheme, Bool)
parseMulti
  where
    parseBoundary :: Parser (Grapheme, Bool)
parseBoundary = (Grapheme
GBoundary,Bool
False) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'#'

    parseMulti :: Parser (Grapheme, Bool)
parseMulti = (,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Grapheme
GMulti (forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P forall a. Maybe a
Nothing (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char]
keyChars))))
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'~'))

parseGrapheme' :: Parser Grapheme
parseGrapheme' :: Parser Grapheme
parseGrapheme' = forall a. Parser a -> Parser a
lexeme forall a b. (a -> b) -> a -> b
$ [Char] -> Grapheme
GMulti forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe [Char] -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P forall a. Maybe a
Nothing (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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
'=')))

data CategoryModification
    = Union     Grapheme
    | Intersect Grapheme
    | Subtract  Grapheme

parseGraphemeOrCategory :: ParseLexeme a => Parser (Lexeme a)
parseGraphemeOrCategory :: forall (a :: LexemeType). ParseLexeme a => Parser (Lexeme a)
parseGraphemeOrCategory = do
    (Grapheme
g, Bool
isntCat) <- Parser (Grapheme, Bool)
parseGrapheme
    if Bool
isntCat
        then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (a :: LexemeType). Grapheme -> Lexeme a
Grapheme Grapheme
g
        else do
            Categories Grapheme
cats <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Config -> Categories Grapheme
categories
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case forall a.
Ord a =>
a -> Categories a -> Maybe (Category 'Expanded a)
C.lookup Grapheme
g Categories Grapheme
cats of
                Maybe (Category 'Expanded Grapheme)
Nothing -> forall (a :: LexemeType). Grapheme -> Lexeme a
Grapheme Grapheme
g
                Just Category 'Expanded Grapheme
c  -> forall (a :: LexemeType). [Grapheme] -> Lexeme a
Category forall a b. (a -> b) -> a -> b
$ forall a. Eq a => Category 'Expanded a -> [a]
C.bake Category 'Expanded Grapheme
c

parseCategory :: ParseLexeme a => Parser (Lexeme a)
parseCategory :: forall (a :: LexemeType). ParseLexeme a => Parser (Lexeme a)
parseCategory = forall (a :: LexemeType). [Grapheme] -> Lexeme a
Category forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [Grapheme]
parseCategory'

parseCategory' :: Parser [Grapheme]
parseCategory' :: Parser [Grapheme]
parseCategory' = do
    [CategoryModification]
mods <- [Char] -> Parser [Char]
symbol [Char]
"[" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
someTill Parser CategoryModification
parseCategoryModification ([Char] -> Parser [Char]
symbol [Char]
"]")
    Categories Grapheme
cats <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Config -> Categories Grapheme
categories
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Eq a => Category 'Expanded a -> [a]
C.bake forall a b. (a -> b) -> a -> b
$
        forall a.
Ord a =>
Categories a -> Category 'Unexpanded a -> Category 'Expanded a
C.expand Categories Grapheme
cats ([CategoryModification] -> Category 'Unexpanded Grapheme
toCategory [CategoryModification]
mods)

parseCategoryStandalone :: Parser (Grapheme, C.Category 'C.Expanded Grapheme)
parseCategoryStandalone :: Parser (Grapheme, Category 'Expanded Grapheme)
parseCategoryStandalone = do
    Grapheme
g <- Parser Grapheme
parseGrapheme'
    [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
"="
    -- Use Target here because it only allows graphemes, not boundaries
    [CategoryModification]
mods <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some Parser CategoryModification
parseCategoryModification
    Categories Grapheme
cats <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Config -> Categories Grapheme
categories
    forall (m :: * -> *) a. Monad m => a -> m a
return (Grapheme
g, forall a.
Ord a =>
Categories a -> Category 'Unexpanded a -> Category 'Expanded a
C.expand Categories Grapheme
cats forall a b. (a -> b) -> a -> b
$ [CategoryModification] -> Category 'Unexpanded Grapheme
toCategory [CategoryModification]
mods)

categoriesDeclParse :: Parser CategoriesDecl
categoriesDeclParse :: Parser CategoriesDecl
categoriesDeclParse = do
    Bool
overwrite <- forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ([Char] -> Parser [Char]
symbol [Char]
"new")
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
overwrite forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ Categories Grapheme -> Config
Config forall k a. Map k a
M.empty
    [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
"categories" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
scn
    -- parse category declarations, adding to the set of known
    -- categories as each is parsed
    [()]
_ <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall a b. (a -> b) -> a -> b
$ Parser ()
parseFeature forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ()
parseCategoryDecl
    [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
"end" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
scn
    Config Categories Grapheme
catsNew <- forall s (m :: * -> *). MonadState s m => m s
get
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Grapheme] -> CategoriesDecl
CategoriesDecl (forall a. Ord a => Categories a -> [a]
C.values Categories Grapheme
catsNew)
  where
    parseFeature :: Parser ()
parseFeature = do
        [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
"feature"
        Maybe Grapheme
namePlain <- 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 Grapheme
parseGrapheme' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* [Char] -> Parser [Char]
symbol [Char]
"="
        [CategoryModification]
modsPlain <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some Parser CategoryModification
parseCategoryModification
        Categories Grapheme
cats <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Config -> Categories Grapheme
categories
        let plainCat :: Category 'Expanded Grapheme
plainCat = forall a.
Ord a =>
Categories a -> Category 'Unexpanded a -> Category 'Expanded a
C.expand Categories Grapheme
cats forall a b. (a -> b) -> a -> b
$ [CategoryModification] -> Category 'Unexpanded Grapheme
toCategory [CategoryModification]
modsPlain
            plain :: [Grapheme]
plain = forall a. Eq a => Category 'Expanded a -> [a]
C.bake Category 'Expanded Grapheme
plainCat
        [(Grapheme, Category 'Expanded Grapheme)]
modifiedCats <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ([Char] -> Parser [Char]
symbol [Char]
"/" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser (Grapheme, Category 'Expanded Grapheme)
parseCategoryStandalone) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
scn
        let modified :: [[Grapheme]]
modified = forall a. Eq a => Category 'Expanded a -> [a]
C.bake forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Grapheme, Category 'Expanded Grapheme)]
modifiedCats
            syns :: [(Grapheme, Category 'Expanded Grapheme)]
syns = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Grapheme
a [Grapheme]
b -> (Grapheme
a, forall (s :: CategoryState) a. [Category s a] -> Category s a
C.UnionOf [forall (s :: CategoryState) a. a -> Category s a
C.Node Grapheme
a, forall a. Ord a => [a] -> Category 'Expanded a
C.categorise [Grapheme]
b])) [Grapheme]
plain forall a b. (a -> b) -> a -> b
$ forall a. [[a]] -> [[a]]
transpose [[Grapheme]]
modified
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \(Config Categories Grapheme
cs) -> Categories Grapheme -> Config
Config forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
M.unions
                [ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Grapheme, Category 'Expanded Grapheme)]
syns
                , forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Grapheme, Category 'Expanded Grapheme)]
modifiedCats
                , case Maybe Grapheme
namePlain of
                      Maybe Grapheme
Nothing -> forall k a. Map k a
M.empty
                      Just Grapheme
n -> forall k a. k -> a -> Map k a
M.singleton Grapheme
n Category 'Expanded Grapheme
plainCat
                , Categories Grapheme
cs
                ]
    parseCategoryDecl :: Parser ()
parseCategoryDecl = do
        (Grapheme
k, Category 'Expanded Grapheme
c) <- forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser (Grapheme, Category 'Expanded Grapheme)
parseCategoryStandalone forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
scn
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \(Config Categories Grapheme
cs) -> Categories Grapheme -> Config
Config (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Grapheme
k Category 'Expanded Grapheme
c Categories Grapheme
cs)

parseCategoryModification :: Parser CategoryModification
parseCategoryModification :: Parser CategoryModification
parseCategoryModification = ParsecT
  Void [Char] (State Config) (Grapheme -> CategoryModification)
parsePrefix forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Grapheme, Bool)
parseGrapheme)
  where
    parsePrefix :: ParsecT
  Void [Char] (State Config) (Grapheme -> CategoryModification)
parsePrefix =
        (Grapheme -> CategoryModification
Intersect forall (f :: * -> *) a b. Functor 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. Alternative f => f a -> f a -> f a
<|> (Grapheme -> CategoryModification
Subtract forall (f :: * -> *) a b. Functor 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. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure Grapheme -> CategoryModification
Union

toCategory :: [CategoryModification] -> C.Category 'C.Unexpanded Grapheme
toCategory :: [CategoryModification] -> Category 'Unexpanded Grapheme
toCategory = forall {s :: CategoryState}.
Category s Grapheme
-> [CategoryModification] -> Category s Grapheme
go forall (s :: CategoryState) a. Category s a
C.Empty
  where
    go :: Category s Grapheme
-> [CategoryModification] -> Category s Grapheme
go Category s Grapheme
c [] = Category s Grapheme
c
    go Category s Grapheme
c (Union Grapheme
e    :[CategoryModification]
es) = Category s Grapheme
-> [CategoryModification] -> Category s Grapheme
go (forall (s :: CategoryState) a. [Category s a] -> Category s a
C.UnionOf  [Category s Grapheme
c, forall (s :: CategoryState) a. a -> Category s a
C.Node Grapheme
e]) [CategoryModification]
es
    go Category s Grapheme
c (Intersect Grapheme
e:[CategoryModification]
es) = Category s Grapheme
-> [CategoryModification] -> Category s Grapheme
go (forall (s :: CategoryState) a.
Category s a -> Category s a -> Category s a
C.Intersect Category s Grapheme
c (forall (s :: CategoryState) a. a -> Category s a
C.Node Grapheme
e)) [CategoryModification]
es
    go Category s Grapheme
c (Subtract Grapheme
e :[CategoryModification]
es) = Category s Grapheme
-> [CategoryModification] -> Category s Grapheme
go (forall (s :: CategoryState) a.
Category s a -> Category s a -> Category s a
C.Subtract  Category s Grapheme
c (forall (s :: CategoryState) a. a -> Category s a
C.Node Grapheme
e)) [CategoryModification]
es

parseOptional :: ParseLexeme a => Parser (Lexeme a)
parseOptional :: forall (a :: LexemeType). ParseLexeme a => Parser (Lexeme a)
parseOptional = forall (a :: LexemeType). [Lexeme a] -> Lexeme a
Optional forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between ([Char] -> Parser [Char]
symbol [Char]
"(") ([Char] -> Parser [Char]
symbol [Char]
")") (forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some forall (a :: LexemeType). ParseLexeme a => Parser (Lexeme a)
parseLexeme)

parseGeminate :: Parser (Lexeme a)
parseGeminate :: forall (a :: LexemeType). Parser (Lexeme a)
parseGeminate = forall (a :: LexemeType). Lexeme a
Geminate forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Char] -> Parser [Char]
symbol [Char]
">"

parseMetathesis :: Parser (Lexeme 'Replacement)
parseMetathesis :: Parser (Lexeme 'Replacement)
parseMetathesis = Lexeme 'Replacement
Metathesis forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Char] -> Parser [Char]
symbol [Char]
"\\"

parseWildcard :: (ParseLexeme a, OneOf a 'Target 'Env) => Parser (Lexeme a)
parseWildcard :: forall (a :: LexemeType).
(ParseLexeme a, OneOf a 'Target 'Env) =>
Parser (Lexeme a)
parseWildcard = forall (a :: LexemeType).
OneOf a 'Target 'Env =>
Lexeme a -> Lexeme a
Wildcard forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> Parser [Char]
symbol [Char]
"^" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (a :: LexemeType). ParseLexeme a => Parser (Lexeme a)
parseLexeme)

parseDiscard :: Parser (Lexeme 'Replacement)
parseDiscard :: Parser (Lexeme 'Replacement)
parseDiscard = Lexeme 'Replacement
Discard forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Char] -> Parser [Char]
symbol [Char]
"~"

parseKleene :: OneOf a 'Target 'Env => Lexeme a -> Parser (Lexeme a)
parseKleene :: forall (a :: LexemeType).
OneOf a 'Target 'Env =>
Lexeme a -> Parser (Lexeme a)
parseKleene Lexeme a
l = (forall (a :: LexemeType).
OneOf a 'Target 'Env =>
Lexeme a -> Lexeme a
Kleene Lexeme a
l forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Char] -> Parser [Char]
symbol [Char]
"*") forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure Lexeme a
l

parseMultiple :: Parser (Lexeme 'Replacement)
parseMultiple :: Parser (Lexeme 'Replacement)
parseMultiple = [Grapheme] -> Lexeme 'Replacement
Multiple forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> Parser [Char]
symbol [Char]
"@?" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser [Grapheme]
parseCategory')

parseBackreference
    :: forall a.
       (OneOf a 'Target 'Replacement, ParseLexeme a)
    => Parser (Lexeme a)
parseBackreference :: forall (a :: LexemeType).
(OneOf a 'Target 'Replacement, ParseLexeme a) =>
Parser (Lexeme a)
parseBackreference =
    forall (a :: LexemeType).
OneOf a 'Target 'Replacement =>
Int -> [Grapheme] -> Lexeme a
Backreference
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> Parser [Char]
symbol [Char]
"@" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Int
nonzero)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser [Grapheme]
parseCategory' forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser [Grapheme]
parseGraphemeCategory)
  where
    parseGraphemeCategory :: Parser [Grapheme]
    parseGraphemeCategory :: Parser [Grapheme]
parseGraphemeCategory = forall e s (m :: * -> *) a.
MonadParsec e s m =>
[Char] -> m a -> m a
label [Char]
"category" 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
$
        (forall (a :: LexemeType). ParseLexeme a => Parser (Lexeme a)
parseGraphemeOrCategory @a) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Category [Grapheme]
gs -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Grapheme]
gs
            Lexeme a
_ -> forall (f :: * -> *) a. Alternative f => f a
empty

instance ParseLexeme 'Target where
    parseLexeme :: Parser (Lexeme 'Target)
parseLexeme = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ forall (a :: LexemeType). ParseLexeme a => Parser (Lexeme a)
parseCategory
        , forall (a :: LexemeType). ParseLexeme a => Parser (Lexeme a)
parseOptional
        , forall (a :: LexemeType). Parser (Lexeme a)
parseGeminate
        , forall (a :: LexemeType).
(ParseLexeme a, OneOf a 'Target 'Env) =>
Parser (Lexeme a)
parseWildcard
        , forall (a :: LexemeType).
(OneOf a 'Target 'Replacement, ParseLexeme a) =>
Parser (Lexeme a)
parseBackreference
        , forall (a :: LexemeType). ParseLexeme a => Parser (Lexeme a)
parseGraphemeOrCategory
        ] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (a :: LexemeType).
OneOf a 'Target 'Env =>
Lexeme a -> Parser (Lexeme a)
parseKleene

instance ParseLexeme 'Replacement where
    parseLexeme :: Parser (Lexeme 'Replacement)
parseLexeme = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ forall (a :: LexemeType). ParseLexeme a => Parser (Lexeme a)
parseCategory
        , forall (a :: LexemeType). ParseLexeme a => Parser (Lexeme a)
parseOptional
        , Parser (Lexeme 'Replacement)
parseMetathesis
        , Parser (Lexeme 'Replacement)
parseDiscard
        , forall (a :: LexemeType). Parser (Lexeme a)
parseGeminate
        , Parser (Lexeme 'Replacement)
parseMultiple
        , forall (a :: LexemeType).
(OneOf a 'Target 'Replacement, ParseLexeme a) =>
Parser (Lexeme a)
parseBackreference
        , forall (a :: LexemeType). ParseLexeme a => Parser (Lexeme a)
parseGraphemeOrCategory
        ]

instance ParseLexeme 'Env where
    parseLexeme :: Parser (Lexeme 'Env)
parseLexeme = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ forall (a :: LexemeType). ParseLexeme a => Parser (Lexeme a)
parseCategory
        , forall (a :: LexemeType). ParseLexeme a => Parser (Lexeme a)
parseOptional
        , forall (a :: LexemeType). Parser (Lexeme a)
parseGeminate
        , forall (a :: LexemeType).
(ParseLexeme a, OneOf a 'Target 'Env) =>
Parser (Lexeme a)
parseWildcard
        , forall (a :: LexemeType). ParseLexeme a => Parser (Lexeme a)
parseGraphemeOrCategory
        ] forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (a :: LexemeType).
OneOf a 'Target 'Env =>
Lexeme a -> Parser (Lexeme a)
parseKleene

parseLexemes :: ParseLexeme a => Parser [Lexeme a]
parseLexemes :: forall (a :: LexemeType). ParseLexeme a => Parser [Lexeme a]
parseLexemes = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall (a :: LexemeType). ParseLexeme a => Parser (Lexeme a)
parseLexeme

parseFlags :: Parser Flags
parseFlags :: Parser Flags
parseFlags = forall (m :: * -> *) a.
(Alternative m, Monad m) =>
Permutation m a -> m a
runPermutation forall a b. (a -> b) -> a -> b
$ Bool -> Direction -> Bool -> Bool -> Flags
Flags
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Alternative m => m a -> Permutation m a
toPermutation (forall a. Maybe a -> Bool
isNothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ([Char] -> Parser [Char]
symbol [Char]
"-x"))
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a.
Alternative m =>
a -> m a -> Permutation m a
toPermutationWithDefault Direction
LTR ((Direction
LTR forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Char] -> Parser [Char]
symbol [Char]
"-ltr") forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Direction
RTL forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Char] -> Parser [Char]
symbol [Char]
"-rtl"))
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Alternative m => m a -> Permutation m a
toPermutation (forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ([Char] -> Parser [Char]
symbol [Char]
"-1"))
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a. Alternative m => m a -> Permutation m a
toPermutation (forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ([Char] -> Parser [Char]
symbol [Char]
"-?"))

ruleParser :: Parser Rule
ruleParser :: Parser Rule
ruleParser = do
    -- This is an inlined version of 'match' from @megaparsec@;
    -- 'match' itself would be tricky to use here, since it would need
    -- to wrap multiple parsers rather than just one
    Int
o <- forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
    [Char]
s <- forall e s (m :: * -> *). MonadParsec e s m => m s
getInput

    Flags
flags <- Parser Flags
parseFlags
    [Lexeme 'Target]
target <- forall (a :: LexemeType). ParseLexeme a => Parser [Lexeme a]
parseLexemes
    Token [Char]
_ <- forall a. Parser a -> Parser a
lexeme forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf [Char]
"/→"
    [Lexeme 'Replacement]
replacement <- forall (a :: LexemeType). ParseLexeme a => Parser [Lexeme a]
parseLexemes

    [([Lexeme 'Env], [Lexeme 'Env])]
envs' <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall a b. (a -> b) -> a -> b
$ do
        forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy forall a b. (a -> b) -> a -> b
$ [Char] -> Parser [Char]
symbol [Char]
"//"  -- for exceptions
        [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
"/"
        [Lexeme 'Env]
env1 <- forall (a :: LexemeType). ParseLexeme a => Parser [Lexeme a]
parseLexemes
        [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
"_"
        [Lexeme 'Env]
env2 <- forall (a :: LexemeType). ParseLexeme a => Parser [Lexeme a]
parseLexemes
        forall (m :: * -> *) a. Monad m => a -> m a
return ([Lexeme 'Env]
env1, [Lexeme 'Env]
env2)
    let envs :: [([Lexeme 'Env], [Lexeme 'Env])]
envs = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [([Lexeme 'Env], [Lexeme 'Env])]
envs' then [([], [])] else [([Lexeme 'Env], [Lexeme 'Env])]
envs'

    Maybe ([Lexeme 'Env], [Lexeme 'Env])
exception <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Char] -> Parser [Char]
symbol [Char]
"//" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> forall (a :: LexemeType). ParseLexeme a => Parser [Lexeme a]
parseLexemes) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* [Char] -> Parser [Char]
symbol [Char]
"_" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (a :: LexemeType). ParseLexeme a => Parser [Lexeme a]
parseLexemes

    Maybe ()
_ <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ()
scn   -- consume newline after rule if present

    Int
o' <- forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
    let plaintext :: [Char]
plaintext = forall a. (a -> Bool) -> [a] -> [a]
takeWhile Char -> Bool
notNewline forall a b. (a -> b) -> a -> b
$ (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust) (forall s. Stream s => Int -> s -> Maybe (Tokens s, s)
takeN_ (Int
o' forall a. Num a => a -> a -> a
- Int
o) [Char]
s)
    forall (m :: * -> *) a. Monad m => a -> m a
return Rule{environment :: [([Lexeme 'Env], [Lexeme 'Env])]
environment=[([Lexeme 'Env], [Lexeme 'Env])]
envs, [Char]
[Lexeme 'Target]
[Lexeme 'Replacement]
Maybe ([Lexeme 'Env], [Lexeme 'Env])
Flags
plaintext :: [Char]
flags :: Flags
exception :: Maybe ([Lexeme 'Env], [Lexeme 'Env])
replacement :: [Lexeme 'Replacement]
target :: [Lexeme 'Target]
plaintext :: [Char]
exception :: Maybe ([Lexeme 'Env], [Lexeme 'Env])
replacement :: [Lexeme 'Replacement]
target :: [Lexeme 'Target]
flags :: Flags
..}
  where
    notNewline :: Char -> Bool
notNewline Char
c = (Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\n') Bool -> Bool -> Bool
&& (Char
c forall a. Eq a => a -> a -> Bool
/= Char
'\r')

-- | Parse a 'String' in Brassica sound change syntax into a
-- 'Rule'. Returns 'Left' if the input string is malformed.
--
-- For details on the syntax, refer to <https://github.com/bradrn/brassica/blob/v0.1.0/Documentation.md#basic-rule-syntax>.
parseRule :: String -> Either (ParseErrorBundle String Void) Rule
parseRule :: [Char] -> Either (ParseErrorBundle [Char] Void) Rule
parseRule = Categories Grapheme
-> [Char] -> Either (ParseErrorBundle [Char] Void) Rule
parseRuleWithCategories forall k a. Map k a
M.empty

-- | Same as 'parseRule', but also allows passing in some predefined
-- categories to substitute.
parseRuleWithCategories :: C.Categories Grapheme -> String -> Either (ParseErrorBundle String Void) Rule
parseRuleWithCategories :: Categories Grapheme
-> [Char] -> Either (ParseErrorBundle [Char] Void) Rule
parseRuleWithCategories Categories Grapheme
cs [Char]
s = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState (Categories Grapheme -> Config
Config Categories Grapheme
cs) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> [Char] -> s -> m (Either (ParseErrorBundle s e) a)
runParserT (Parser ()
scn forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Rule
ruleParser forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) [Char]
"" [Char]
s

-- | Parse a list of 'SoundChanges'.
parseSoundChanges :: String -> Either (ParseErrorBundle String Void) SoundChanges
parseSoundChanges :: [Char] -> Either (ParseErrorBundle [Char] Void) SoundChanges
parseSoundChanges [Char]
s = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState (Categories Grapheme -> Config
Config forall k a. Map k a
M.empty) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> [Char] -> s -> m (Either (ParseErrorBundle s e) a)
runParserT (Parser ()
scn forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT Void [Char] (State Config) SoundChanges
parser forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) [Char]
"" [Char]
s
  where
    parser :: ParsecT Void [Char] (State Config) SoundChanges
parser = forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall a b. (a -> b) -> a -> b
$
        CategoriesDecl -> Statement
CategoriesDeclS forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser CategoriesDecl
categoriesDeclParse
        forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Rule -> Statement
RuleS forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Rule
ruleParser