{-# LANGUAGE LambdaCase #-}
module Brassica.Paradigm.Apply (applyParadigm) where
import Brassica.Paradigm.Types
import Data.List (sortOn)
import Data.Maybe (mapMaybe)
import Data.Ord (Down(Down))
applyParadigm :: Paradigm -> String -> [String]
applyParadigm :: Paradigm -> String -> [String]
applyParadigm Paradigm
p String
w =
let fs :: [Feature]
fs = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Statement -> Maybe Feature
getFeature Paradigm
p
ms :: [([AbstractGrammeme], Affix)]
ms = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Statement -> Maybe ([AbstractGrammeme], Affix)
getMapping Paradigm
p
in String -> Affix -> String
applyTo String
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. [([AbstractGrammeme], Affix)] -> [Grammeme] -> Affix
expand [([AbstractGrammeme], Affix)]
ms forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Feature] -> [[Grammeme]]
combinations [Feature]
fs
where
getFeature :: Statement -> Maybe Feature
getFeature (NewFeature Feature
f) = forall a. a -> Maybe a
Just Feature
f
getFeature Statement
_ = forall a. Maybe a
Nothing
getMapping :: Statement -> Maybe ([AbstractGrammeme], Affix)
getMapping (NewMapping [AbstractGrammeme]
k Affix
v) = forall a. a -> Maybe a
Just ([AbstractGrammeme]
k,Affix
v)
getMapping Statement
_ = forall a. Maybe a
Nothing
combinations :: [Feature] -> [[Grammeme]]
combinations :: [Feature] -> [[Grammeme]]
combinations = [(Maybe FeatureName, Grammeme)] -> [Feature] -> [[Grammeme]]
go []
where
go :: [(Maybe FeatureName, Grammeme)] -> [Feature] -> [[Grammeme]]
go :: [(Maybe FeatureName, Grammeme)] -> [Feature] -> [[Grammeme]]
go [(Maybe FeatureName, Grammeme)]
acc [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> [a]
reverse [(Maybe FeatureName, Grammeme)]
acc
go [(Maybe FeatureName, Grammeme)]
acc (Feature Condition
c Maybe FeatureName
n [Grammeme]
gs : [Feature]
fs) =
if (FeatureName -> Maybe Grammeme) -> Condition -> Bool
satisfied (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [(Maybe FeatureName, Grammeme)]
acc forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) Condition
c
then do
Grammeme
g <- [Grammeme]
gs
[(Maybe FeatureName, Grammeme)] -> [Feature] -> [[Grammeme]]
go ((Maybe FeatureName
n,Grammeme
g) forall a. a -> [a] -> [a]
: [(Maybe FeatureName, Grammeme)]
acc) [Feature]
fs
else [(Maybe FeatureName, Grammeme)] -> [Feature] -> [[Grammeme]]
go [(Maybe FeatureName, Grammeme)]
acc [Feature]
fs
satisfied
:: (FeatureName -> Maybe Grammeme)
-> Condition
-> Bool
satisfied :: (FeatureName -> Maybe Grammeme) -> Condition -> Bool
satisfied FeatureName -> Maybe Grammeme
_ Condition
Always = Bool
True
satisfied FeatureName -> Maybe Grammeme
l (Is FeatureName
n Grammeme
g) = case FeatureName -> Maybe Grammeme
l FeatureName
n of
Just Grammeme
g' -> Grammeme
g forall a. Eq a => a -> a -> Bool
== Grammeme
g'
Maybe Grammeme
Nothing -> Bool
False
satisfied FeatureName -> Maybe Grammeme
l (Not FeatureName
n Grammeme
g) = case FeatureName -> Maybe Grammeme
l FeatureName
n of
Just Grammeme
g' -> Grammeme
g forall a. Eq a => a -> a -> Bool
/= Grammeme
g'
Maybe Grammeme
Nothing -> Bool
True
expand :: [([AbstractGrammeme], Affix)] -> [Grammeme] -> [Process]
expand :: [([AbstractGrammeme], Affix)] -> [Grammeme] -> Affix
expand [([AbstractGrammeme], Affix)]
ms = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. [a] -> [a] -> [a]
(++) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Grammeme] -> [Affix]
concretes forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ([AbstractGrammeme] -> [Affix]
replace forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Grammeme] -> [AbstractGrammeme]
filterAbstract))
where
concretes :: [Grammeme] -> [Affix]
concretes :: [Grammeme] -> [Affix]
concretes = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a -> b) -> a -> b
$ \case
Concrete Affix
affix -> forall a. a -> Maybe a
Just Affix
affix
Abstract AbstractGrammeme
_ -> forall a. Maybe a
Nothing
filterAbstract :: [Grammeme] -> [AbstractGrammeme]
filterAbstract :: [Grammeme] -> [AbstractGrammeme]
filterAbstract = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a -> b) -> a -> b
$ \case
Concrete Affix
_ -> forall a. Maybe a
Nothing
Abstract AbstractGrammeme
g -> forall a. a -> Maybe a
Just AbstractGrammeme
g
replace :: [AbstractGrammeme] -> [Affix]
replace :: [AbstractGrammeme] -> [Affix]
replace [AbstractGrammeme]
gs = do
([AbstractGrammeme]
condition, Affix
replacement) <- [([AbstractGrammeme], Affix)]
ms
if [AbstractGrammeme]
condition forall {t :: * -> *} {t :: * -> *} {a}.
(Foldable t, Foldable t, Eq a) =>
t a -> t a -> Bool
`subsetOf` [AbstractGrammeme]
gs
then forall (m :: * -> *) a. Monad m => a -> m a
return Affix
replacement
else []
t a
xs subsetOf :: t a -> t a -> Bool
`subsetOf` t a
ys = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t a
ys) t a
xs
applyTo :: String -> [Process] -> String
applyTo :: String -> Affix -> String
applyTo String
w Affix
is =
let ps :: String
ps = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (forall a. a -> Down a
Down forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Process -> Maybe (Int, String)
getPrefix Affix
is
ss :: String
ss = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Process -> Maybe (Int, String)
getSuffix Affix
is
in String
ps forall a. [a] -> [a] -> [a]
++ String
w forall a. [a] -> [a] -> [a]
++ String
ss
where
getPrefix :: Process -> Maybe (Int, String)
getPrefix (Prefix Int
s String
i) = forall a. a -> Maybe a
Just (Int
s,String
i)
getPrefix Process
_ = forall a. Maybe a
Nothing
getSuffix :: Process -> Maybe (Int, String)
getSuffix (Suffix Int
s String
i) = forall a. a -> Maybe a
Just (Int
s,String
i)
getSuffix Process
_ = forall a. Maybe a
Nothing