{-# LANGUAGE DataKinds      #-}
{-# LANGUAGE DeriveFunctor  #-}
{-# LANGUAGE KindSignatures #-}

module Brassica.SoundChange.Category
       (
       -- * Category construction

         Category(..)
       , CategoryState(..)
       , categorise
       -- * Category expansion

       , Categories
       , Brassica.SoundChange.Category.lookup
       , mapCategories
       , expand
       -- * Obtaining values

       , bake
       , values
       ) where

import Data.Coerce
import Data.List (intersect)
import Data.Maybe (fromMaybe)

import qualified Data.Map.Strict as M
import Data.Containers.ListUtils (nubOrd)

-- | Type-level tag for 'Category'. When parsing a category definition

-- from a string, usually categories will refer to other

-- categories. This is the 'Unexpanded' state. Once 'Expanded', these

-- references will have been inlined, and the category no longer

-- depends on other categories.

data CategoryState = Unexpanded | Expanded

-- | A set of values (usually representing phonemes) which behave the

-- same way in a sound change. A 'Category' is constructed using the

-- set operations supplied as constructors, possibly referencing other

-- 'Category's; these references can then be 'expand'ed, allowing the

-- 'Category' to be 'bake'd to a list of matching values.

--

-- Note that Brassica makes no distinction between ad-hoc categories

-- and predefined categories beyond the sound change parser; the

-- latter is merely syntax sugar for the former, and both are

-- represented using the same 'Category' type. In practise this is not

-- usually a problem, since 'Category's are still quite convenient to

-- construct manually.

data Category (s :: CategoryState) a
    = Empty
    -- ^ The empty category (@[]@ in Brassica syntax)

    | Node a
    -- ^ A single value (@[a]@)

    | UnionOf [Category s a]
    -- ^ The union of multiple categories (@[Ca Cb Cc]@)

    | Intersect (Category s a) (Category s a)
    -- ^ The intersection of two categories (@[Ca +Cb]@)

    | Subtract (Category s a) (Category s a)
    -- ^ The second category subtracted from the first (@[Ca -Cb]@)

    deriving (Int -> Category s a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (s :: CategoryState) a.
Show a =>
Int -> Category s a -> ShowS
forall (s :: CategoryState) a. Show a => [Category s a] -> ShowS
forall (s :: CategoryState) a. Show a => Category s a -> String
showList :: [Category s a] -> ShowS
$cshowList :: forall (s :: CategoryState) a. Show a => [Category s a] -> ShowS
show :: Category s a -> String
$cshow :: forall (s :: CategoryState) a. Show a => Category s a -> String
showsPrec :: Int -> Category s a -> ShowS
$cshowsPrec :: forall (s :: CategoryState) a.
Show a =>
Int -> Category s a -> ShowS
Show, Category s a -> Category s a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (s :: CategoryState) a.
Eq a =>
Category s a -> Category s a -> Bool
/= :: Category s a -> Category s a -> Bool
$c/= :: forall (s :: CategoryState) a.
Eq a =>
Category s a -> Category s a -> Bool
== :: Category s a -> Category s a -> Bool
$c== :: forall (s :: CategoryState) a.
Eq a =>
Category s a -> Category s a -> Bool
Eq, Category s a -> Category s a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {s :: CategoryState} {a}. Ord a => Eq (Category s a)
forall (s :: CategoryState) a.
Ord a =>
Category s a -> Category s a -> Bool
forall (s :: CategoryState) a.
Ord a =>
Category s a -> Category s a -> Ordering
forall (s :: CategoryState) a.
Ord a =>
Category s a -> Category s a -> Category s a
min :: Category s a -> Category s a -> Category s a
$cmin :: forall (s :: CategoryState) a.
Ord a =>
Category s a -> Category s a -> Category s a
max :: Category s a -> Category s a -> Category s a
$cmax :: forall (s :: CategoryState) a.
Ord a =>
Category s a -> Category s a -> Category s a
>= :: Category s a -> Category s a -> Bool
$c>= :: forall (s :: CategoryState) a.
Ord a =>
Category s a -> Category s a -> Bool
> :: Category s a -> Category s a -> Bool
$c> :: forall (s :: CategoryState) a.
Ord a =>
Category s a -> Category s a -> Bool
<= :: Category s a -> Category s a -> Bool
$c<= :: forall (s :: CategoryState) a.
Ord a =>
Category s a -> Category s a -> Bool
< :: Category s a -> Category s a -> Bool
$c< :: forall (s :: CategoryState) a.
Ord a =>
Category s a -> Category s a -> Bool
compare :: Category s a -> Category s a -> Ordering
$ccompare :: forall (s :: CategoryState) a.
Ord a =>
Category s a -> Category s a -> Ordering
Ord, forall a b. a -> Category s b -> Category s a
forall a b. (a -> b) -> Category s a -> Category s b
forall (s :: CategoryState) a b. a -> Category s b -> Category s a
forall (s :: CategoryState) a b.
(a -> b) -> Category s a -> Category s 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 -> Category s b -> Category s a
$c<$ :: forall (s :: CategoryState) a b. a -> Category s b -> Category s a
fmap :: forall a b. (a -> b) -> Category s a -> Category s b
$cfmap :: forall (s :: CategoryState) a b.
(a -> b) -> Category s a -> Category s b
Functor)

-- | A map from names to the (expanded) categories they

-- reference. Used to resolve cross-references between categories.

type Categories a = M.Map a (Category 'Expanded a)

-- | @Data.Map.Strict.'Data.Map.Strict.lookup'@, specialised to 'Categories'.

lookup :: Ord a => a -> Categories a -> Maybe (Category 'Expanded a)
lookup :: forall a.
Ord a =>
a -> Categories a -> Maybe (Category 'Expanded a)
lookup = forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup

-- | Map a function over all the values in a set of 'Categories'.

mapCategories :: Ord b => (a -> b) -> Categories a -> Categories b
mapCategories :: forall b a. Ord b => (a -> b) -> Categories a -> Categories b
mapCategories a -> b
f = forall a b k. (a -> b) -> Map k a -> Map k b
M.map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys a -> b
f

-- | Given a list of values, return a 'Category' which matches only

-- those values. (This is a simple wrapper around 'Node' and

-- 'UnionOf'.)

categorise :: Ord a => [a] -> Category 'Expanded a
categorise :: forall a. Ord a => [a] -> Category 'Expanded a
categorise = forall (s :: CategoryState) a. [Category s a] -> Category s a
UnionOf forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (s :: CategoryState) a. a -> Category s a
Node

-- | Expand an 'Unexpanded' category by inlining its references. The

-- references should only be to categories in the given 'Categories'.

expand :: Ord a => Categories a -> Category 'Unexpanded a -> Category 'Expanded a
expand :: forall a.
Ord a =>
Categories a -> Category 'Unexpanded a -> Category 'Expanded a
expand Categories a
_  Category 'Unexpanded a
Empty           = forall (s :: CategoryState) a. Category s a
Empty
expand Categories a
cs n :: Category 'Unexpanded a
n@(Node a
a)      = forall a. a -> Maybe a -> a
fromMaybe (coerce :: forall a b. Coercible a b => a -> b
coerce Category 'Unexpanded a
n) forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup a
a Categories a
cs
expand Categories a
cs (UnionOf [Category 'Unexpanded a]
u)     = forall (s :: CategoryState) a. [Category s a] -> Category s a
UnionOf forall a b. (a -> b) -> a -> b
$ forall a.
Ord a =>
Categories a -> Category 'Unexpanded a -> Category 'Expanded a
expand Categories a
cs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Category 'Unexpanded a]
u
expand Categories a
cs (Intersect Category 'Unexpanded a
a Category 'Unexpanded a
b) = forall (s :: CategoryState) a.
Category s a -> Category s a -> Category s a
Intersect (forall a.
Ord a =>
Categories a -> Category 'Unexpanded a -> Category 'Expanded a
expand Categories a
cs Category 'Unexpanded a
a) (forall a.
Ord a =>
Categories a -> Category 'Unexpanded a -> Category 'Expanded a
expand Categories a
cs Category 'Unexpanded a
b)
expand Categories a
cs (Subtract Category 'Unexpanded a
a Category 'Unexpanded a
b)  = forall (s :: CategoryState) a.
Category s a -> Category s a -> Category s a
Subtract  (forall a.
Ord a =>
Categories a -> Category 'Unexpanded a -> Category 'Expanded a
expand Categories a
cs Category 'Unexpanded a
a) (forall a.
Ord a =>
Categories a -> Category 'Unexpanded a -> Category 'Expanded a
expand Categories a
cs Category 'Unexpanded a
b)

-- | Given an 'Expanded' category, return the list of values which it

-- matches.

bake :: Eq a => Category 'Expanded a -> [a]
bake :: forall a. Eq a => Category 'Expanded a -> [a]
bake Category 'Expanded a
Empty           = []
bake (Node    a
a)     = [a
a]
bake (UnionOf [Category 'Expanded a]
u)     = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Eq a => Category 'Expanded a -> [a]
bake [Category 'Expanded a]
u
bake (Intersect Category 'Expanded a
a Category 'Expanded a
b) = forall a. Eq a => Category 'Expanded a -> [a]
bake Category 'Expanded a
a forall a. Eq a => [a] -> [a] -> [a]
`intersect` forall a. Eq a => Category 'Expanded a -> [a]
bake Category 'Expanded a
b
bake (Subtract  Category 'Expanded a
a Category 'Expanded a
b) = forall a. Eq a => Category 'Expanded a -> [a]
bake Category 'Expanded a
a forall {t :: * -> *} {a}. (Foldable t, Eq a) => [a] -> t a -> [a]
`difference` forall a. Eq a => Category 'Expanded a -> [a]
bake Category 'Expanded a
b
  where
    difference :: [a] -> t a -> [a]
difference [a]
l t a
m = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t a
m)) [a]
l

-- | Returns a list of every value mentioned in a set of

-- 'Categories'. This includes all values, even those which are

-- 'Intersect'ed or 'Subtract'ed out: e.g. given 'Categories'

-- including @[a b -a]@, this will return a list including

-- @["a","b"]@, not just @["b"]@.

values :: Ord a => Categories a -> [a]
values :: forall a. Ord a => Categories a -> [a]
values = forall a. Ord a => [a] -> [a]
nubOrd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {s :: CategoryState} {a}. Category s a -> [a]
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
M.elems
  where
    go :: Category s a -> [a]
go Category s a
Empty           = []
    go (Node    a
a)     = [a
a]
    go (UnionOf [Category s a]
u)     = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Category s a -> [a]
go [Category s a]
u
    go (Intersect Category s a
a Category s a
b) = Category s a -> [a]
go Category s a
a forall a. [a] -> [a] -> [a]
++ Category s a -> [a]
go Category s a
b
    go (Subtract  Category s a
a Category s a
b) = Category s a -> [a]
go Category s a
a forall a. [a] -> [a] -> [a]
++ Category s a -> [a]
go Category s a
b