{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}

module Brassica.Paradigm.Apply
       ( ResultsTree(..)
       , applyParadigm
       , formatNested
       ) where

import Brassica.Paradigm.Types

import Data.Functor ((<&>))
import Data.List (sortOn, foldl', intercalate)
import Data.Maybe (mapMaybe)
import Data.Ord (Down(Down))

data ResultsTree a = Node [ResultsTree a] | Result a
    deriving (Int -> ResultsTree a -> ShowS
forall a. Show a => Int -> ResultsTree a -> ShowS
forall a. Show a => [ResultsTree a] -> ShowS
forall a. Show a => ResultsTree a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ResultsTree a] -> ShowS
$cshowList :: forall a. Show a => [ResultsTree a] -> ShowS
show :: ResultsTree a -> String
$cshow :: forall a. Show a => ResultsTree a -> String
showsPrec :: Int -> ResultsTree a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ResultsTree a -> ShowS
Show, forall a b. a -> ResultsTree b -> ResultsTree a
forall a b. (a -> b) -> ResultsTree a -> ResultsTree b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ResultsTree b -> ResultsTree a
$c<$ :: forall a b. a -> ResultsTree b -> ResultsTree a
fmap :: forall a b. (a -> b) -> ResultsTree a -> ResultsTree b
$cfmap :: forall a b. (a -> b) -> ResultsTree a -> ResultsTree b
Functor, forall a. Eq a => a -> ResultsTree a -> Bool
forall a. Num a => ResultsTree a -> a
forall a. Ord a => ResultsTree a -> a
forall m. Monoid m => ResultsTree m -> m
forall a. ResultsTree a -> Bool
forall a. ResultsTree a -> Int
forall a. ResultsTree a -> [a]
forall a. (a -> a -> a) -> ResultsTree a -> a
forall m a. Monoid m => (a -> m) -> ResultsTree a -> m
forall b a. (b -> a -> b) -> b -> ResultsTree a -> b
forall a b. (a -> b -> b) -> b -> ResultsTree a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => ResultsTree a -> a
$cproduct :: forall a. Num a => ResultsTree a -> a
sum :: forall a. Num a => ResultsTree a -> a
$csum :: forall a. Num a => ResultsTree a -> a
minimum :: forall a. Ord a => ResultsTree a -> a
$cminimum :: forall a. Ord a => ResultsTree a -> a
maximum :: forall a. Ord a => ResultsTree a -> a
$cmaximum :: forall a. Ord a => ResultsTree a -> a
elem :: forall a. Eq a => a -> ResultsTree a -> Bool
$celem :: forall a. Eq a => a -> ResultsTree a -> Bool
length :: forall a. ResultsTree a -> Int
$clength :: forall a. ResultsTree a -> Int
null :: forall a. ResultsTree a -> Bool
$cnull :: forall a. ResultsTree a -> Bool
toList :: forall a. ResultsTree a -> [a]
$ctoList :: forall a. ResultsTree a -> [a]
foldl1 :: forall a. (a -> a -> a) -> ResultsTree a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> ResultsTree a -> a
foldr1 :: forall a. (a -> a -> a) -> ResultsTree a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> ResultsTree a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> ResultsTree a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> ResultsTree a -> b
foldl :: forall b a. (b -> a -> b) -> b -> ResultsTree a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> ResultsTree a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> ResultsTree a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> ResultsTree a -> b
foldr :: forall a b. (a -> b -> b) -> b -> ResultsTree a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> ResultsTree a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> ResultsTree a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> ResultsTree a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> ResultsTree a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> ResultsTree a -> m
fold :: forall m. Monoid m => ResultsTree m -> m
$cfold :: forall m. Monoid m => ResultsTree m -> m
Foldable)

addLevel :: (a -> [a]) -> ResultsTree a -> ResultsTree a
addLevel :: forall a. (a -> [a]) -> ResultsTree a -> ResultsTree a
addLevel a -> [a]
f (Result a
r) = forall a. [ResultsTree a] -> ResultsTree a
Node forall a b. (a -> b) -> a -> b
$ forall a. a -> ResultsTree a
Result forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> [a]
f a
r
addLevel a -> [a]
f (Node [ResultsTree a]
rs) = forall a. [ResultsTree a] -> ResultsTree a
Node forall a b. (a -> b) -> a -> b
$ forall a. (a -> [a]) -> ResultsTree a -> ResultsTree a
addLevel a -> [a]
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ResultsTree a]
rs

-- | Formats a 'ResultsTree' in a nested way, where the lowest-level
-- elements are separated by one space, the second-lowest are
-- separated by one newline, the third-lowest by two newlines, and so
-- on.
formatNested :: (a -> String) -> ResultsTree a -> String
formatNested :: forall a. (a -> String) -> ResultsTree a -> String
formatNested a -> String
f = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResultsTree a -> (Int, String)
go
  where
    go :: ResultsTree a -> (Int, String)
go (Result a
a) = (Int
0, a -> String
f a
a)
    go (Node [ResultsTree a]
rts) =
        let ([Int]
depths, [String]
formatted) = forall a b. [(a, b)] -> ([a], [b])
unzip forall a b. (a -> b) -> a -> b
$ ResultsTree a -> (Int, String)
go forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ResultsTree a]
rts
            depth :: Int
depth = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
depths
            separator :: String
separator =
                if Int
depth forall a. Eq a => a -> a -> Bool
== Int
0
                then String
" "
                else forall a. Int -> a -> [a]
replicate Int
depth Char
'\n'
        in (Int
1forall a. Num a => a -> a -> a
+Int
depth, forall a. [a] -> [[a]] -> [a]
intercalate String
separator [String]
formatted)

-- | Apply the given 'Paradigm' to a root, to produce all possible
-- derived forms.
applyParadigm :: Paradigm -> String -> ResultsTree String
applyParadigm :: Paradigm -> String -> ResultsTree 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] -> ResultsTree [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] -> ResultsTree [Grammeme]
combinations :: [Feature] -> ResultsTree [Grammeme]
combinations =
    (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ResultsTree [(Maybe FeatureName, Grammeme)]
-> Feature -> ResultsTree [(Maybe FeatureName, Grammeme)]
go (forall a. a -> ResultsTree a
Result [])
  where
    addFeature
        :: Feature
        -> [(Maybe FeatureName, Grammeme)]
        -> [[(Maybe FeatureName, Grammeme)]]
    addFeature :: Feature
-> [(Maybe FeatureName, Grammeme)]
-> [[(Maybe FeatureName, Grammeme)]]
addFeature (Feature Condition
c Maybe FeatureName
n [Grammeme]
gs) [(Maybe FeatureName, Grammeme)]
acc
        | (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
        = [Grammeme]
gs forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Grammeme
g -> (Maybe FeatureName
n, Grammeme
g)forall a. a -> [a] -> [a]
:[(Maybe FeatureName, Grammeme)]
acc
        | Bool
otherwise
        = [[(Maybe FeatureName, Grammeme)]
acc]

    go  :: ResultsTree [(Maybe FeatureName, Grammeme)]
        -> Feature
        -> ResultsTree [(Maybe FeatureName, Grammeme)]
    go :: ResultsTree [(Maybe FeatureName, Grammeme)]
-> Feature -> ResultsTree [(Maybe FeatureName, Grammeme)]
go ResultsTree [(Maybe FeatureName, Grammeme)]
rt Feature
f = forall a. (a -> [a]) -> ResultsTree a -> ResultsTree a
addLevel (Feature
-> [(Maybe FeatureName, Grammeme)]
-> [[(Maybe FeatureName, Grammeme)]]
addFeature Feature
f) ResultsTree [(Maybe FeatureName, Grammeme)]
rt

    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