{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Brassica.SoundChange.Parse
( parseRule
, parseRuleWithCategories
, parseSoundChanges
, 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)
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
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'))
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]
"="
[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
[()]
_ <- 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
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]
"//"
[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
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')
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
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
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