{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures   #-}
{-# LANGUAGE RecordWildCards  #-}
{-# 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 [Char]
categories :: C.Categories Grapheme
    }
type Parser = ParsecT Void String (State Config)

class ParseLexeme (a :: LexemeType) where
    parseLexeme :: Parser (Lexeme a)
    parseCategoryElement :: Parser (CategoryElement 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]
"#[](){}>\\→/_^%~*"

parseGrapheme :: Parser (Grapheme, Bool)
parseGrapheme :: Parser ([Char], Bool)
parseGrapheme = forall a. Parser a -> Parser a
lexeme forall a b. (a -> b) -> a -> b
$ (,) 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 (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 [Char]
parseGrapheme' = forall a. Parser a -> Parser a
lexeme 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. 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 a
    = Union     (CategoryElement a)
    | Intersect (CategoryElement a)
    | Subtract  (CategoryElement a)

parseGraphemeOrCategory :: ParseLexeme a => Parser (Lexeme a)
parseGraphemeOrCategory :: forall (a :: LexemeType). ParseLexeme a => Parser (Lexeme a)
parseGraphemeOrCategory = do
    ([Char]
g, Bool
isntCat) <- Parser ([Char], 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). [Char] -> Lexeme a
Grapheme [Char]
g
        else do
            Categories [Char]
cats <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Config -> Categories [Char]
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 [Char]
g Categories [Char]
cats of
                Maybe (Category 'Expanded [Char])
Nothing -> forall (a :: LexemeType). [Char] -> Lexeme a
Grapheme [Char]
g
                Just Category 'Expanded [Char]
c  -> forall (a :: LexemeType). [CategoryElement a] -> Lexeme a
Category 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 :: LexemeType). [Char] -> CategoryElement a
GraphemeEl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Category 'Expanded [Char]
c

parseCategory :: ParseLexeme a => Parser (Lexeme a)
parseCategory :: forall (a :: LexemeType). ParseLexeme a => Parser (Lexeme a)
parseCategory = do
    [CategoryModification a]
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 forall (a :: LexemeType).
ParseLexeme a =>
Parser (CategoryModification a)
parseCategoryModification ([Char] -> Parser [Char]
symbol [Char]
"]")
    Categories [Char]
cats <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Config -> Categories [Char]
categories
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (a :: LexemeType). [CategoryElement a] -> Lexeme a
Category 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 (forall b a. Ord b => (a -> b) -> Categories a -> Categories b
C.mapCategories forall (a :: LexemeType). [Char] -> CategoryElement a
GraphemeEl Categories [Char]
cats) (forall (a :: LexemeType).
[CategoryModification a]
-> Category 'Unexpanded (CategoryElement a)
toCategory [CategoryModification a]
mods)

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

toGrapheme :: CategoryElement 'Target -> Grapheme
toGrapheme :: CategoryElement 'Target -> [Char]
toGrapheme (GraphemeEl [Char]
g) = [Char]
g

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 [Char] -> 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 [Char]
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
$ [[Char]] -> CategoriesDecl
CategoriesDecl (forall a. Ord a => Categories a -> [a]
C.values Categories [Char]
catsNew)
  where
    parseFeature :: Parser ()
parseFeature = do
        [Char]
_ <- [Char] -> Parser [Char]
symbol [Char]
"feature"
        Maybe [Char]
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 [Char]
parseGrapheme' forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* [Char] -> Parser [Char]
symbol [Char]
"="
        [CategoryModification 'Target]
modsPlain <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (forall (a :: LexemeType).
ParseLexeme a =>
Parser (CategoryModification a)
parseCategoryModification @'Target)
        Categories [Char]
cats <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets Config -> Categories [Char]
categories
        let plainCat :: Category 'Expanded [Char]
plainCat = forall a.
Ord a =>
Categories a -> Category 'Unexpanded a -> Category 'Expanded a
C.expand Categories [Char]
cats forall a b. (a -> b) -> a -> b
$ CategoryElement 'Target -> [Char]
toGrapheme forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: LexemeType).
[CategoryModification a]
-> Category 'Unexpanded (CategoryElement a)
toCategory [CategoryModification 'Target]
modsPlain
            plain :: [[Char]]
plain = forall a. Eq a => Category 'Expanded a -> [a]
C.bake Category 'Expanded [Char]
plainCat
        [([Char], Category 'Expanded [Char])]
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 ([Char], Category 'Expanded [Char])
parseCategoryStandalone) forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
scn
        let modified :: [[[Char]]]
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
<$> [([Char], Category 'Expanded [Char])]
modifiedCats
            syns :: [([Char], Category 'Expanded [Char])]
syns = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\[Char]
a [[Char]]
b -> ([Char]
a, forall (s :: CategoryState) a. [Category s a] -> Category s a
C.UnionOf [forall (s :: CategoryState) a. a -> Category s a
C.Node [Char]
a, forall a. Ord a => [a] -> Category 'Expanded a
C.categorise [[Char]]
b])) [[Char]]
plain forall a b. (a -> b) -> a -> b
$ forall a. [[a]] -> [[a]]
transpose [[[Char]]]
modified
        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \(Config Categories [Char]
cs) -> Categories [Char] -> 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 [([Char], Category 'Expanded [Char])]
syns
                , forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [([Char], Category 'Expanded [Char])]
modifiedCats
                , case Maybe [Char]
namePlain of
                      Maybe [Char]
Nothing -> forall k a. Map k a
M.empty
                      Just [Char]
n -> forall k a. k -> a -> Map k a
M.singleton [Char]
n Category 'Expanded [Char]
plainCat
                , Categories [Char]
cs
                ]
    parseCategoryDecl :: Parser ()
parseCategoryDecl = do
        ([Char]
k, Category 'Expanded [Char]
c) <- forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser ([Char], Category 'Expanded [Char])
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 [Char]
cs) -> Categories [Char] -> Config
Config (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert [Char]
k Category 'Expanded [Char]
c Categories [Char]
cs)

parseCategoryModification :: ParseLexeme a => Parser (CategoryModification a)
parseCategoryModification :: forall (a :: LexemeType).
ParseLexeme a =>
Parser (CategoryModification a)
parseCategoryModification = forall {a :: LexemeType}.
ParsecT
  Void
  [Char]
  (State Config)
  (CategoryElement a -> CategoryModification a)
parsePrefix forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (a :: LexemeType).
ParseLexeme a =>
Parser (CategoryElement a)
parseCategoryElement
  where
    parsePrefix :: ParsecT
  Void
  [Char]
  (State Config)
  (CategoryElement a -> CategoryModification a)
parsePrefix =
        (forall (a :: LexemeType).
CategoryElement a -> CategoryModification a
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
<|> (forall (a :: LexemeType).
CategoryElement a -> CategoryModification a
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 forall (a :: LexemeType).
CategoryElement a -> CategoryModification a
Union

toCategory :: [CategoryModification a] -> C.Category 'C.Unexpanded (CategoryElement a)
toCategory :: forall (a :: LexemeType).
[CategoryModification a]
-> Category 'Unexpanded (CategoryElement a)
toCategory = forall {s :: CategoryState} {a :: LexemeType}.
Category s (CategoryElement a)
-> [CategoryModification a] -> Category s (CategoryElement a)
go forall (s :: CategoryState) a. Category s a
C.Empty
  where
    go :: Category s (CategoryElement a)
-> [CategoryModification a] -> Category s (CategoryElement a)
go Category s (CategoryElement a)
c [] = Category s (CategoryElement a)
c
    go Category s (CategoryElement a)
c (Union CategoryElement a
e    :[CategoryModification a]
es) = Category s (CategoryElement a)
-> [CategoryModification a] -> Category s (CategoryElement a)
go (forall (s :: CategoryState) a. [Category s a] -> Category s a
C.UnionOf  [Category s (CategoryElement a)
c, forall (s :: CategoryState) a. a -> Category s a
C.Node CategoryElement a
e]) [CategoryModification a]
es
    go Category s (CategoryElement a)
c (Intersect CategoryElement a
e:[CategoryModification a]
es) = Category s (CategoryElement a)
-> [CategoryModification a] -> Category s (CategoryElement a)
go (forall (s :: CategoryState) a.
Category s a -> Category s a -> Category s a
C.Intersect Category s (CategoryElement a)
c (forall (s :: CategoryState) a. a -> Category s a
C.Node CategoryElement a
e)) [CategoryModification a]
es
    go Category s (CategoryElement a)
c (Subtract CategoryElement a
e :[CategoryModification a]
es) = Category s (CategoryElement a)
-> [CategoryModification a] -> Category s (CategoryElement a)
go (forall (s :: CategoryState) a.
Category s a -> Category s a -> Category s a
C.Subtract  Category s (CategoryElement a)
c (forall (s :: CategoryState) a. a -> Category s a
C.Node CategoryElement a
e)) [CategoryModification a]
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)

parseBoundary :: Parser ()
parseBoundary :: Parser ()
parseBoundary = () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [Char] -> Parser [Char]
symbol [Char]
"#"

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

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). 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
    parseCategoryElement :: Parser (CategoryElement 'Target)
parseCategoryElement = forall (a :: LexemeType). [Char] -> CategoryElement a
GraphemeEl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ([Char], Bool)
parseGrapheme

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
        , forall (a :: LexemeType). ParseLexeme a => Parser (Lexeme a)
parseGraphemeOrCategory
        ]
    parseCategoryElement :: Parser (CategoryElement 'Replacement)
parseCategoryElement = forall (a :: LexemeType). [Char] -> CategoryElement a
GraphemeEl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ([Char], Bool)
parseGrapheme

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
        , Lexeme 'Env
Boundary forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser ()
parseBoundary
        , 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
    parseCategoryElement :: Parser (CategoryElement 'Env)
parseCategoryElement = forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum
        [ CategoryElement 'Env
BoundaryEl forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser ()
parseBoundary
        , forall (a :: LexemeType). [Char] -> CategoryElement a
GraphemeEl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ([Char], Bool)
parseGrapheme
        ]

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

    let parseEnvironment :: ParsecT
  Void
  [Char]
  (State Config)
  ([Lexeme 'Env], [Lexeme 'Env],
   Maybe ([Lexeme 'Env], [Lexeme 'Env]))
parseEnvironment = do
            [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
            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
            forall (m :: * -> *) a. Monad m => a -> m a
return ([Lexeme 'Env]
env1, [Lexeme 'Env]
env2, Maybe ([Lexeme 'Env], [Lexeme 'Env])
exception)

    ([Lexeme 'Env]
env1, [Lexeme 'Env]
env2, Maybe ([Lexeme 'Env], [Lexeme 'Env])
exception) <- ParsecT
  Void
  [Char]
  (State Config)
  ([Lexeme 'Env], [Lexeme 'Env],
   Maybe ([Lexeme 'Env], [Lexeme 'Env]))
parseEnvironment forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [], forall a. Maybe a
Nothing)

    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]
env1,[Lexeme 'Env]
env2), [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.0.3/Documentation.md#basic-rule-syntax>.
parseRule :: String -> Either (ParseErrorBundle String Void) Rule
parseRule :: [Char] -> Either (ParseErrorBundle [Char] Void) Rule
parseRule = Categories [Char]
-> [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 [Char]
-> [Char] -> Either (ParseErrorBundle [Char] Void) Rule
parseRuleWithCategories Categories [Char]
cs [Char]
s = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState (Categories [Char] -> Config
Config Categories [Char]
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 [Char] -> 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