{-# 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))

-- | Apply the given 'Paradigm' to a root, to produce all possible
-- derived forms.
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