{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}

module Brassica.SoundChange.Category
       ( Categories
       , Brassica.SoundChange.Category.lookup
       , values
       , ExpandError(..)
       , expand
       , expandRule
       , extendCategories
       , expandSoundChanges
       ) where

import Prelude hiding (lookup)
import Control.DeepSeq (NFData)
import Control.Monad (foldM, unless)
import Control.Monad.State.Strict (StateT, evalStateT, lift, get, put, gets)
import Data.Containers.ListUtils (nubOrd)
import Data.List (intersect, transpose, foldl')
import Data.Maybe (mapMaybe, catMaybes)
import GHC.Generics (Generic)

import qualified Data.Map.Strict as M

import Brassica.SoundChange.Types
import Data.Traversable (for)

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

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

type Categories = M.Map String (Expanded 'AnyPart)

-- | Lookup a category name in 'Categories'.

lookup :: String -> Categories -> Maybe (Expanded a)
lookup :: forall (a :: LexemeType).
String -> Categories -> Maybe (Expanded a)
lookup = ((Expanded 'AnyPart -> Expanded a)
-> Maybe (Expanded 'AnyPart) -> Maybe (Expanded a)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expanded 'AnyPart -> Expanded a
forall (a :: LexemeType). Expanded 'AnyPart -> Expanded a
generaliseExpanded (Maybe (Expanded 'AnyPart) -> Maybe (Expanded a))
-> (Categories -> Maybe (Expanded 'AnyPart))
-> Categories
-> Maybe (Expanded a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((Categories -> Maybe (Expanded 'AnyPart))
 -> Categories -> Maybe (Expanded a))
-> (String -> Categories -> Maybe (Expanded 'AnyPart))
-> String
-> Categories
-> Maybe (Expanded a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Categories -> Maybe (Expanded 'AnyPart)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup

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

-- 'Categories'

values :: Categories -> [Either Grapheme [Lexeme Expanded 'AnyPart]]
values :: Categories -> [Either Grapheme [Lexeme Expanded 'AnyPart]]
values = [Either Grapheme [Lexeme Expanded 'AnyPart]]
-> [Either Grapheme [Lexeme Expanded 'AnyPart]]
forall a. Ord a => [a] -> [a]
nubOrd ([Either Grapheme [Lexeme Expanded 'AnyPart]]
 -> [Either Grapheme [Lexeme Expanded 'AnyPart]])
-> (Categories -> [Either Grapheme [Lexeme Expanded 'AnyPart]])
-> Categories
-> [Either Grapheme [Lexeme Expanded 'AnyPart]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Expanded 'AnyPart -> [Either Grapheme [Lexeme Expanded 'AnyPart]])
-> [Expanded 'AnyPart]
-> [Either Grapheme [Lexeme Expanded 'AnyPart]]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Expanded 'AnyPart -> [Either Grapheme [Lexeme Expanded 'AnyPart]]
forall (a :: LexemeType).
Expanded a -> [Either Grapheme [Lexeme Expanded a]]
elements ([Expanded 'AnyPart]
 -> [Either Grapheme [Lexeme Expanded 'AnyPart]])
-> (Categories -> [Expanded 'AnyPart])
-> Categories
-> [Either Grapheme [Lexeme Expanded 'AnyPart]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Categories -> [Expanded 'AnyPart]
forall k a. Map k a -> [a]
M.elems

-- Errors which can be emitted while inlining or expanding category

-- definitions.

data ExpandError
    = NotFound String
      -- ^ A category with that name was not found

    | InvalidBaseValue
      -- ^ A 'Lexeme' was used as a base value in a feature

    | MismatchedLengths
      -- ^ A 'FeatureSpec' contained a mismatched number of values

    deriving (Int -> ExpandError -> ShowS
[ExpandError] -> ShowS
ExpandError -> String
(Int -> ExpandError -> ShowS)
-> (ExpandError -> String)
-> ([ExpandError] -> ShowS)
-> Show ExpandError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExpandError -> ShowS
showsPrec :: Int -> ExpandError -> ShowS
$cshow :: ExpandError -> String
show :: ExpandError -> String
$cshowList :: [ExpandError] -> ShowS
showList :: [ExpandError] -> ShowS
Show, (forall x. ExpandError -> Rep ExpandError x)
-> (forall x. Rep ExpandError x -> ExpandError)
-> Generic ExpandError
forall x. Rep ExpandError x -> ExpandError
forall x. ExpandError -> Rep ExpandError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ExpandError -> Rep ExpandError x
from :: forall x. ExpandError -> Rep ExpandError x
$cto :: forall x. Rep ExpandError x -> ExpandError
to :: forall x. Rep ExpandError x -> ExpandError
Generic, ExpandError -> ()
(ExpandError -> ()) -> NFData ExpandError
forall a. (a -> ()) -> NFData a
$crnf :: ExpandError -> ()
rnf :: ExpandError -> ()
NFData)

-- | Given a category, return the list of values which it

-- matches.

expand :: Categories -> CategorySpec a -> Either ExpandError (Expanded a)
expand :: forall (a :: LexemeType).
Categories -> CategorySpec a -> Either ExpandError (Expanded a)
expand Categories
cs (MustInline String
g) = Either ExpandError (Expanded a)
-> (Expanded a -> Either ExpandError (Expanded a))
-> Maybe (Expanded a)
-> Either ExpandError (Expanded a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ExpandError -> Either ExpandError (Expanded a)
forall a b. a -> Either a b
Left (ExpandError -> Either ExpandError (Expanded a))
-> ExpandError -> Either ExpandError (Expanded a)
forall a b. (a -> b) -> a -> b
$ String -> ExpandError
NotFound String
g) Expanded a -> Either ExpandError (Expanded a)
forall a b. b -> Either a b
Right (Maybe (Expanded a) -> Either ExpandError (Expanded a))
-> Maybe (Expanded a) -> Either ExpandError (Expanded a)
forall a b. (a -> b) -> a -> b
$ String -> Categories -> Maybe (Expanded a)
forall (a :: LexemeType).
String -> Categories -> Maybe (Expanded a)
lookup String
g Categories
cs
expand Categories
cs (CategorySpec [(CategoryModification, Either Grapheme [Lexeme CategorySpec a])]
spec) = [Either Grapheme [Lexeme Expanded a]] -> Expanded a
forall (a :: LexemeType).
[Either Grapheme [Lexeme Expanded a]] -> Expanded a
FromElements ([Either Grapheme [Lexeme Expanded a]] -> Expanded a)
-> Either ExpandError [Either Grapheme [Lexeme Expanded a]]
-> Either ExpandError (Expanded a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Either Grapheme [Lexeme Expanded a]]
 -> (CategoryModification, Either Grapheme [Lexeme CategorySpec a])
 -> Either ExpandError [Either Grapheme [Lexeme Expanded a]])
-> [Either Grapheme [Lexeme Expanded a]]
-> [(CategoryModification,
     Either Grapheme [Lexeme CategorySpec a])]
-> Either ExpandError [Either Grapheme [Lexeme Expanded a]]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [Either Grapheme [Lexeme Expanded a]]
-> (CategoryModification, Either Grapheme [Lexeme CategorySpec a])
-> Either ExpandError [Either Grapheme [Lexeme Expanded a]]
go [] [(CategoryModification, Either Grapheme [Lexeme CategorySpec a])]
spec
  where
    go :: [Either Grapheme [Lexeme Expanded a]]
-> (CategoryModification, Either Grapheme [Lexeme CategorySpec a])
-> Either ExpandError [Either Grapheme [Lexeme Expanded a]]
go [Either Grapheme [Lexeme Expanded a]]
es (CategoryModification
modifier, Either Grapheme [Lexeme CategorySpec a]
e) = do
        [Either Grapheme [Lexeme Expanded a]]
new <- case Either Grapheme [Lexeme CategorySpec a]
e of
            Left (GMulti String
g)
                | Just (FromElements [Either Grapheme [Lexeme Expanded a]]
c) <- String -> Categories -> Maybe (Expanded a)
forall (a :: LexemeType).
String -> Categories -> Maybe (Expanded a)
lookup String
g Categories
cs
                -> [Either Grapheme [Lexeme Expanded a]]
-> Either ExpandError [Either Grapheme [Lexeme Expanded a]]
forall a. a -> Either ExpandError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Either Grapheme [Lexeme Expanded a]]
c
                | Bool
otherwise -> [Either Grapheme [Lexeme Expanded a]]
-> Either ExpandError [Either Grapheme [Lexeme Expanded a]]
forall a. a -> Either ExpandError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Grapheme -> Either Grapheme [Lexeme Expanded a]
forall a b. a -> Either a b
Left (String -> Grapheme
GMulti String
g)]
            Left Grapheme
GBoundary -> [Either Grapheme [Lexeme Expanded a]]
-> Either ExpandError [Either Grapheme [Lexeme Expanded a]]
forall a. a -> Either ExpandError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Grapheme -> Either Grapheme [Lexeme Expanded a]
forall a b. a -> Either a b
Left Grapheme
GBoundary]
            Right [Lexeme CategorySpec a]
ls -> Either Grapheme [Lexeme Expanded a]
-> [Either Grapheme [Lexeme Expanded a]]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either Grapheme [Lexeme Expanded a]
 -> [Either Grapheme [Lexeme Expanded a]])
-> ([Lexeme Expanded a] -> Either Grapheme [Lexeme Expanded a])
-> [Lexeme Expanded a]
-> [Either Grapheme [Lexeme Expanded a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Lexeme Expanded a] -> Either Grapheme [Lexeme Expanded a]
forall a b. b -> Either a b
Right ([Lexeme Expanded a] -> [Either Grapheme [Lexeme Expanded a]])
-> Either ExpandError [Lexeme Expanded a]
-> Either ExpandError [Either Grapheme [Lexeme Expanded a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a))
-> [Lexeme CategorySpec a]
-> Either ExpandError [Lexeme Expanded a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Categories
-> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
forall (a :: LexemeType).
Categories
-> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
expandLexeme Categories
cs) [Lexeme CategorySpec a]
ls
        [Either Grapheme [Lexeme Expanded a]]
-> Either ExpandError [Either Grapheme [Lexeme Expanded a]]
forall a. a -> Either ExpandError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Either Grapheme [Lexeme Expanded a]]
 -> Either ExpandError [Either Grapheme [Lexeme Expanded a]])
-> [Either Grapheme [Lexeme Expanded a]]
-> Either ExpandError [Either Grapheme [Lexeme Expanded a]]
forall a b. (a -> b) -> a -> b
$ case CategoryModification
modifier of
            CategoryModification
Union -> [Either Grapheme [Lexeme Expanded a]]
es [Either Grapheme [Lexeme Expanded a]]
-> [Either Grapheme [Lexeme Expanded a]]
-> [Either Grapheme [Lexeme Expanded a]]
forall a. [a] -> [a] -> [a]
++ [Either Grapheme [Lexeme Expanded a]]
new
            CategoryModification
Intersect -> [Either Grapheme [Lexeme Expanded a]]
es [Either Grapheme [Lexeme Expanded a]]
-> [Either Grapheme [Lexeme Expanded a]]
-> [Either Grapheme [Lexeme Expanded a]]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Either Grapheme [Lexeme Expanded a]]
new
            CategoryModification
Subtract -> [Either Grapheme [Lexeme Expanded a]]
es [Either Grapheme [Lexeme Expanded a]]
-> [Either Grapheme [Lexeme Expanded a]]
-> [Either Grapheme [Lexeme Expanded a]]
forall {t :: * -> *} {a}. (Foldable t, Eq a) => [a] -> t a -> [a]
`subtractAll` [Either Grapheme [Lexeme Expanded a]]
new

    -- NB. normal (\\) only removes the first matching element

    subtractAll :: [a] -> t a -> [a]
subtractAll [a]
xs t a
ys = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` t a
ys) [a]
xs

expandLexeme :: Categories -> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
expandLexeme :: forall (a :: LexemeType).
Categories
-> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
expandLexeme Categories
cs (Grapheme (GMulti String
g))
    | Just (String
g', Char
'~') <- String -> Maybe (String, Char)
forall a. [a] -> Maybe ([a], a)
unsnoc String
g
        = Lexeme Expanded a -> Either ExpandError (Lexeme Expanded a)
forall a b. b -> Either a b
Right (Lexeme Expanded a -> Either ExpandError (Lexeme Expanded a))
-> Lexeme Expanded a -> Either ExpandError (Lexeme Expanded a)
forall a b. (a -> b) -> a -> b
$ Grapheme -> Lexeme Expanded a
forall (category :: LexemeType -> *) (a :: LexemeType).
Grapheme -> Lexeme category a
Grapheme (Grapheme -> Lexeme Expanded a) -> Grapheme -> Lexeme Expanded a
forall a b. (a -> b) -> a -> b
$ String -> Grapheme
GMulti String
g'
    | Bool
otherwise = Lexeme Expanded a -> Either ExpandError (Lexeme Expanded a)
forall a b. b -> Either a b
Right (Lexeme Expanded a -> Either ExpandError (Lexeme Expanded a))
-> Lexeme Expanded a -> Either ExpandError (Lexeme Expanded a)
forall a b. (a -> b) -> a -> b
$
        case String -> Categories -> Maybe (Expanded a)
forall (a :: LexemeType).
String -> Categories -> Maybe (Expanded a)
lookup String
g Categories
cs of
            Just Expanded a
c -> Expanded a -> Lexeme Expanded a
forall (category :: LexemeType -> *) (a :: LexemeType).
category a -> Lexeme category a
Category Expanded a
c
            Maybe (Expanded a)
Nothing -> Grapheme -> Lexeme Expanded a
forall (category :: LexemeType -> *) (a :: LexemeType).
Grapheme -> Lexeme category a
Grapheme (String -> Grapheme
GMulti String
g)
  where
    -- taken from base-4.19

    unsnoc :: [a] -> Maybe ([a], a)
    unsnoc :: forall a. [a] -> Maybe ([a], a)
unsnoc = (a -> Maybe ([a], a) -> Maybe ([a], a))
-> Maybe ([a], a) -> [a] -> Maybe ([a], a)
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x -> ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just (([a], a) -> Maybe ([a], a))
-> (Maybe ([a], a) -> ([a], a)) -> Maybe ([a], a) -> Maybe ([a], a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a], a) -> (([a], a) -> ([a], a)) -> Maybe ([a], a) -> ([a], a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([], a
x) (\(~([a]
a, a
b)) -> (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
a, a
b))) Maybe ([a], a)
forall a. Maybe a
Nothing
    {-# INLINABLE unsnoc #-}

expandLexeme Categories
_  (Grapheme Grapheme
GBoundary) = Lexeme Expanded a -> Either ExpandError (Lexeme Expanded a)
forall a b. b -> Either a b
Right (Lexeme Expanded a -> Either ExpandError (Lexeme Expanded a))
-> Lexeme Expanded a -> Either ExpandError (Lexeme Expanded a)
forall a b. (a -> b) -> a -> b
$ Grapheme -> Lexeme Expanded a
forall (category :: LexemeType -> *) (a :: LexemeType).
Grapheme -> Lexeme category a
Grapheme Grapheme
GBoundary
expandLexeme Categories
cs (Category CategorySpec a
c) = Expanded a -> Lexeme Expanded a
forall (category :: LexemeType -> *) (a :: LexemeType).
category a -> Lexeme category a
Category (Expanded a -> Lexeme Expanded a)
-> Either ExpandError (Expanded a)
-> Either ExpandError (Lexeme Expanded a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Categories -> CategorySpec a -> Either ExpandError (Expanded a)
forall (a :: LexemeType).
Categories -> CategorySpec a -> Either ExpandError (Expanded a)
expand Categories
cs CategorySpec a
c
expandLexeme Categories
cs (Optional [Lexeme CategorySpec a]
ls) = [Lexeme Expanded a] -> Lexeme Expanded a
forall (category :: LexemeType -> *) (a :: LexemeType).
[Lexeme category a] -> Lexeme category a
Optional ([Lexeme Expanded a] -> Lexeme Expanded a)
-> Either ExpandError [Lexeme Expanded a]
-> Either ExpandError (Lexeme Expanded a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a))
-> [Lexeme CategorySpec a]
-> Either ExpandError [Lexeme Expanded a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Categories
-> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
forall (a :: LexemeType).
Categories
-> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
expandLexeme Categories
cs) [Lexeme CategorySpec a]
ls
expandLexeme Categories
_  Lexeme CategorySpec a
Metathesis = Lexeme Expanded a -> Either ExpandError (Lexeme Expanded a)
forall a b. b -> Either a b
Right Lexeme Expanded a
Lexeme Expanded 'Replacement
forall (category :: LexemeType -> *). Lexeme category 'Replacement
Metathesis
expandLexeme Categories
_  Lexeme CategorySpec a
Geminate = Lexeme Expanded a -> Either ExpandError (Lexeme Expanded a)
forall a b. b -> Either a b
Right Lexeme Expanded a
forall (category :: LexemeType -> *) (a :: LexemeType).
Lexeme category a
Geminate
expandLexeme Categories
cs (Wildcard Lexeme CategorySpec a
l) = Lexeme Expanded a -> Lexeme Expanded a
forall (category :: LexemeType -> *) (a :: LexemeType).
Lexeme category a -> Lexeme category a
Wildcard (Lexeme Expanded a -> Lexeme Expanded a)
-> Either ExpandError (Lexeme Expanded a)
-> Either ExpandError (Lexeme Expanded a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Categories
-> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
forall (a :: LexemeType).
Categories
-> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
expandLexeme Categories
cs Lexeme CategorySpec a
l
expandLexeme Categories
cs (Kleene Lexeme CategorySpec a
l) = Lexeme Expanded a -> Lexeme Expanded a
forall (category :: LexemeType -> *) (a :: LexemeType).
Lexeme category a -> Lexeme category a
Kleene (Lexeme Expanded a -> Lexeme Expanded a)
-> Either ExpandError (Lexeme Expanded a)
-> Either ExpandError (Lexeme Expanded a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Categories
-> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
forall (a :: LexemeType).
Categories
-> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
expandLexeme Categories
cs Lexeme CategorySpec a
l
expandLexeme Categories
_  Lexeme CategorySpec a
Discard = Lexeme Expanded a -> Either ExpandError (Lexeme Expanded a)
forall a b. b -> Either a b
Right Lexeme Expanded a
Lexeme Expanded 'Replacement
forall (category :: LexemeType -> *). Lexeme category 'Replacement
Discard
expandLexeme Categories
cs (Backreference Int
i CategorySpec a
c) = Int -> Expanded a -> Lexeme Expanded a
forall (category :: LexemeType -> *) (a :: LexemeType).
Int -> category a -> Lexeme category a
Backreference Int
i (Expanded a -> Lexeme Expanded a)
-> Either ExpandError (Expanded a)
-> Either ExpandError (Lexeme Expanded a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Categories -> CategorySpec a -> Either ExpandError (Expanded a)
forall (a :: LexemeType).
Categories -> CategorySpec a -> Either ExpandError (Expanded a)
expand Categories
cs CategorySpec a
c
expandLexeme Categories
cs (Multiple CategorySpec 'Replacement
c) = Expanded 'Replacement -> Lexeme Expanded a
Expanded 'Replacement -> Lexeme Expanded 'Replacement
forall (category :: LexemeType -> *).
category 'Replacement -> Lexeme category 'Replacement
Multiple (Expanded 'Replacement -> Lexeme Expanded a)
-> Either ExpandError (Expanded 'Replacement)
-> Either ExpandError (Lexeme Expanded a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Categories
-> CategorySpec 'Replacement
-> Either ExpandError (Expanded 'Replacement)
forall (a :: LexemeType).
Categories -> CategorySpec a -> Either ExpandError (Expanded a)
expand Categories
cs CategorySpec 'Replacement
c

expandRule :: Categories -> Rule CategorySpec -> Either ExpandError (Rule Expanded)
expandRule :: Categories
-> Rule CategorySpec -> Either ExpandError (Rule Expanded)
expandRule Categories
cs Rule CategorySpec
r = [Lexeme Expanded 'Matched]
-> [Lexeme Expanded 'Replacement]
-> [Environment Expanded]
-> Maybe (Environment Expanded)
-> Flags
-> String
-> Rule Expanded
forall (c :: LexemeType -> *).
[Lexeme c 'Matched]
-> [Lexeme c 'Replacement]
-> [Environment c]
-> Maybe (Environment c)
-> Flags
-> String
-> Rule c
Rule
    ([Lexeme Expanded 'Matched]
 -> [Lexeme Expanded 'Replacement]
 -> [Environment Expanded]
 -> Maybe (Environment Expanded)
 -> Flags
 -> String
 -> Rule Expanded)
-> Either ExpandError [Lexeme Expanded 'Matched]
-> Either
     ExpandError
     ([Lexeme Expanded 'Replacement]
      -> [Environment Expanded]
      -> Maybe (Environment Expanded)
      -> Flags
      -> String
      -> Rule Expanded)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Lexeme CategorySpec 'Matched
 -> Either ExpandError (Lexeme Expanded 'Matched))
-> [Lexeme CategorySpec 'Matched]
-> Either ExpandError [Lexeme Expanded 'Matched]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Categories
-> Lexeme CategorySpec 'Matched
-> Either ExpandError (Lexeme Expanded 'Matched)
forall (a :: LexemeType).
Categories
-> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
expandLexeme Categories
cs) (Rule CategorySpec -> [Lexeme CategorySpec 'Matched]
forall (c :: LexemeType -> *). Rule c -> [Lexeme c 'Matched]
target Rule CategorySpec
r)
    Either
  ExpandError
  ([Lexeme Expanded 'Replacement]
   -> [Environment Expanded]
   -> Maybe (Environment Expanded)
   -> Flags
   -> String
   -> Rule Expanded)
-> Either ExpandError [Lexeme Expanded 'Replacement]
-> Either
     ExpandError
     ([Environment Expanded]
      -> Maybe (Environment Expanded)
      -> Flags
      -> String
      -> Rule Expanded)
forall a b.
Either ExpandError (a -> b)
-> Either ExpandError a -> Either ExpandError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Lexeme CategorySpec 'Replacement
 -> Either ExpandError (Lexeme Expanded 'Replacement))
-> [Lexeme CategorySpec 'Replacement]
-> Either ExpandError [Lexeme Expanded 'Replacement]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Categories
-> Lexeme CategorySpec 'Replacement
-> Either ExpandError (Lexeme Expanded 'Replacement)
forall (a :: LexemeType).
Categories
-> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
expandLexeme Categories
cs) (Rule CategorySpec -> [Lexeme CategorySpec 'Replacement]
forall (c :: LexemeType -> *). Rule c -> [Lexeme c 'Replacement]
replacement Rule CategorySpec
r)
    Either
  ExpandError
  ([Environment Expanded]
   -> Maybe (Environment Expanded)
   -> Flags
   -> String
   -> Rule Expanded)
-> Either ExpandError [Environment Expanded]
-> Either
     ExpandError
     (Maybe (Environment Expanded) -> Flags -> String -> Rule Expanded)
forall a b.
Either ExpandError (a -> b)
-> Either ExpandError a -> Either ExpandError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (([Lexeme CategorySpec 'Matched], [Lexeme CategorySpec 'Matched])
 -> Either ExpandError (Environment Expanded))
-> [([Lexeme CategorySpec 'Matched],
     [Lexeme CategorySpec 'Matched])]
-> Either ExpandError [Environment Expanded]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ([Lexeme CategorySpec 'Matched], [Lexeme CategorySpec 'Matched])
-> Either ExpandError (Environment Expanded)
expandEnvironment (Rule CategorySpec
-> [([Lexeme CategorySpec 'Matched],
     [Lexeme CategorySpec 'Matched])]
forall (c :: LexemeType -> *). Rule c -> [Environment c]
environment Rule CategorySpec
r)
    Either
  ExpandError
  (Maybe (Environment Expanded) -> Flags -> String -> Rule Expanded)
-> Either ExpandError (Maybe (Environment Expanded))
-> Either ExpandError (Flags -> String -> Rule Expanded)
forall a b.
Either ExpandError (a -> b)
-> Either ExpandError a -> Either ExpandError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (([Lexeme CategorySpec 'Matched], [Lexeme CategorySpec 'Matched])
 -> Either ExpandError (Environment Expanded))
-> Maybe
     ([Lexeme CategorySpec 'Matched], [Lexeme CategorySpec 'Matched])
-> Either ExpandError (Maybe (Environment Expanded))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse ([Lexeme CategorySpec 'Matched], [Lexeme CategorySpec 'Matched])
-> Either ExpandError (Environment Expanded)
expandEnvironment (Rule CategorySpec
-> Maybe
     ([Lexeme CategorySpec 'Matched], [Lexeme CategorySpec 'Matched])
forall (c :: LexemeType -> *). Rule c -> Maybe (Environment c)
exception Rule CategorySpec
r)
    Either ExpandError (Flags -> String -> Rule Expanded)
-> Either ExpandError Flags
-> Either ExpandError (String -> Rule Expanded)
forall a b.
Either ExpandError (a -> b)
-> Either ExpandError a -> Either ExpandError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Flags -> Either ExpandError Flags
forall a. a -> Either ExpandError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rule CategorySpec -> Flags
forall (c :: LexemeType -> *). Rule c -> Flags
flags Rule CategorySpec
r)
    Either ExpandError (String -> Rule Expanded)
-> Either ExpandError String -> Either ExpandError (Rule Expanded)
forall a b.
Either ExpandError (a -> b)
-> Either ExpandError a -> Either ExpandError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Either ExpandError String
forall a. a -> Either ExpandError a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Rule CategorySpec -> String
forall (c :: LexemeType -> *). Rule c -> String
plaintext Rule CategorySpec
r)
  where
    expandEnvironment :: ([Lexeme CategorySpec 'Matched], [Lexeme CategorySpec 'Matched])
-> Either ExpandError (Environment Expanded)
expandEnvironment ([Lexeme CategorySpec 'Matched]
e1, [Lexeme CategorySpec 'Matched]
e2) = (,)
        ([Lexeme Expanded 'Matched]
 -> [Lexeme Expanded 'Matched] -> Environment Expanded)
-> Either ExpandError [Lexeme Expanded 'Matched]
-> Either
     ExpandError ([Lexeme Expanded 'Matched] -> Environment Expanded)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Lexeme CategorySpec 'Matched
 -> Either ExpandError (Lexeme Expanded 'Matched))
-> [Lexeme CategorySpec 'Matched]
-> Either ExpandError [Lexeme Expanded 'Matched]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Categories
-> Lexeme CategorySpec 'Matched
-> Either ExpandError (Lexeme Expanded 'Matched)
forall (a :: LexemeType).
Categories
-> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
expandLexeme Categories
cs) [Lexeme CategorySpec 'Matched]
e1
        Either
  ExpandError ([Lexeme Expanded 'Matched] -> Environment Expanded)
-> Either ExpandError [Lexeme Expanded 'Matched]
-> Either ExpandError (Environment Expanded)
forall a b.
Either ExpandError (a -> b)
-> Either ExpandError a -> Either ExpandError b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Lexeme CategorySpec 'Matched
 -> Either ExpandError (Lexeme Expanded 'Matched))
-> [Lexeme CategorySpec 'Matched]
-> Either ExpandError [Lexeme Expanded 'Matched]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Categories
-> Lexeme CategorySpec 'Matched
-> Either ExpandError (Lexeme Expanded 'Matched)
forall (a :: LexemeType).
Categories
-> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
expandLexeme Categories
cs) [Lexeme CategorySpec 'Matched]
e2

expandFilter :: Categories -> Filter CategorySpec -> Either ExpandError (Filter Expanded)
expandFilter :: Categories
-> Filter CategorySpec -> Either ExpandError (Filter Expanded)
expandFilter Categories
cs (Filter String
p [Lexeme CategorySpec 'Matched]
f) = String -> [Lexeme Expanded 'Matched] -> Filter Expanded
forall (c :: LexemeType -> *).
String -> [Lexeme c 'Matched] -> Filter c
Filter String
p ([Lexeme Expanded 'Matched] -> Filter Expanded)
-> Either ExpandError [Lexeme Expanded 'Matched]
-> Either ExpandError (Filter Expanded)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Lexeme CategorySpec 'Matched
 -> Either ExpandError (Lexeme Expanded 'Matched))
-> [Lexeme CategorySpec 'Matched]
-> Either ExpandError [Lexeme Expanded 'Matched]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Categories
-> Lexeme CategorySpec 'Matched
-> Either ExpandError (Lexeme Expanded 'Matched)
forall (a :: LexemeType).
Categories
-> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
expandLexeme Categories
cs) [Lexeme CategorySpec 'Matched]
f

extendCategories
    :: Categories
    -> (Bool, [CategoryDefinition])  -- ^ The fields of a v'Categories' directive

    -> Either ExpandError Categories
extendCategories :: Categories
-> (Bool, [CategoryDefinition]) -> Either ExpandError Categories
extendCategories Categories
cs' (Bool
overwrite, [CategoryDefinition]
defs) =
    (Categories -> CategoryDefinition -> Either ExpandError Categories)
-> Categories
-> [CategoryDefinition]
-> Either ExpandError Categories
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Categories -> CategoryDefinition -> Either ExpandError Categories
go (if Bool
overwrite then Categories
forall k a. Map k a
M.empty else Categories
cs') [CategoryDefinition]
defs
  where
    go :: Categories -> CategoryDefinition -> Either ExpandError Categories
    go :: Categories -> CategoryDefinition -> Either ExpandError Categories
go Categories
cs (DefineCategory String
name CategorySpec 'AnyPart
val) = (Expanded 'AnyPart -> Categories -> Categories)
-> Categories -> Expanded 'AnyPart -> Categories
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String -> Expanded 'AnyPart -> Categories -> Categories
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
name) Categories
cs (Expanded 'AnyPart -> Categories)
-> Either ExpandError (Expanded 'AnyPart)
-> Either ExpandError Categories
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Categories
-> CategorySpec 'AnyPart -> Either ExpandError (Expanded 'AnyPart)
forall (a :: LexemeType).
Categories -> CategorySpec a -> Either ExpandError (Expanded a)
expand Categories
cs CategorySpec 'AnyPart
val
    go Categories
cs (DefineFeature FeatureSpec
spec) = do
        Expanded 'AnyPart
baseValues <- Categories
-> CategorySpec 'AnyPart -> Either ExpandError (Expanded 'AnyPart)
forall (a :: LexemeType).
Categories -> CategorySpec a -> Either ExpandError (Expanded a)
expand Categories
cs (CategorySpec 'AnyPart -> Either ExpandError (Expanded 'AnyPart))
-> CategorySpec 'AnyPart -> Either ExpandError (Expanded 'AnyPart)
forall a b. (a -> b) -> a -> b
$ FeatureSpec -> CategorySpec 'AnyPart
featureBaseValues FeatureSpec
spec
        [(String, Expanded 'AnyPart)]
derivedCats <- ((String, CategorySpec 'AnyPart)
 -> Either ExpandError (String, Expanded 'AnyPart))
-> [(String, CategorySpec 'AnyPart)]
-> Either ExpandError [(String, Expanded 'AnyPart)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((CategorySpec 'AnyPart -> Either ExpandError (Expanded 'AnyPart))
-> (String, CategorySpec 'AnyPart)
-> Either ExpandError (String, Expanded 'AnyPart)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (String, a) -> f (String, b)
traverse ((CategorySpec 'AnyPart -> Either ExpandError (Expanded 'AnyPart))
 -> (String, CategorySpec 'AnyPart)
 -> Either ExpandError (String, Expanded 'AnyPart))
-> (CategorySpec 'AnyPart
    -> Either ExpandError (Expanded 'AnyPart))
-> (String, CategorySpec 'AnyPart)
-> Either ExpandError (String, Expanded 'AnyPart)
forall a b. (a -> b) -> a -> b
$ Categories
-> CategorySpec 'AnyPart -> Either ExpandError (Expanded 'AnyPart)
forall (a :: LexemeType).
Categories -> CategorySpec a -> Either ExpandError (Expanded a)
expand Categories
cs) ([(String, CategorySpec 'AnyPart)]
 -> Either ExpandError [(String, Expanded 'AnyPart)])
-> [(String, CategorySpec 'AnyPart)]
-> Either ExpandError [(String, Expanded 'AnyPart)]
forall a b. (a -> b) -> a -> b
$ FeatureSpec -> [(String, CategorySpec 'AnyPart)]
featureDerived FeatureSpec
spec

        [String]
baseValues' <- [Either Grapheme [Lexeme Expanded 'AnyPart]]
-> (Either Grapheme [Lexeme Expanded 'AnyPart]
    -> Either ExpandError String)
-> Either ExpandError [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (Expanded 'AnyPart -> [Either Grapheme [Lexeme Expanded 'AnyPart]]
forall (a :: LexemeType).
Expanded a -> [Either Grapheme [Lexeme Expanded a]]
elements Expanded 'AnyPart
baseValues) ((Either Grapheme [Lexeme Expanded 'AnyPart]
  -> Either ExpandError String)
 -> Either ExpandError [String])
-> (Either Grapheme [Lexeme Expanded 'AnyPart]
    -> Either ExpandError String)
-> Either ExpandError [String]
forall a b. (a -> b) -> a -> b
$ \case
            Left (GMulti String
g) -> String -> Either ExpandError String
forall a b. b -> Either a b
Right String
g
            Either Grapheme [Lexeme Expanded 'AnyPart]
_ -> ExpandError -> Either ExpandError String
forall a b. a -> Either a b
Left ExpandError
InvalidBaseValue
        let baseLen :: Int
baseLen = [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
baseValues'
            derivedValues :: [[Either Grapheme [Lexeme Expanded 'AnyPart]]]
derivedValues = Expanded 'AnyPart -> [Either Grapheme [Lexeme Expanded 'AnyPart]]
forall (a :: LexemeType).
Expanded a -> [Either Grapheme [Lexeme Expanded a]]
elements (Expanded 'AnyPart -> [Either Grapheme [Lexeme Expanded 'AnyPart]])
-> ((String, Expanded 'AnyPart) -> Expanded 'AnyPart)
-> (String, Expanded 'AnyPart)
-> [Either Grapheme [Lexeme Expanded 'AnyPart]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Expanded 'AnyPart) -> Expanded 'AnyPart
forall a b. (a, b) -> b
snd ((String, Expanded 'AnyPart)
 -> [Either Grapheme [Lexeme Expanded 'AnyPart]])
-> [(String, Expanded 'AnyPart)]
-> [[Either Grapheme [Lexeme Expanded 'AnyPart]]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(String, Expanded 'AnyPart)]
derivedCats
        Bool -> Either ExpandError () -> Either ExpandError ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (([Either Grapheme [Lexeme Expanded 'AnyPart]] -> Bool)
-> [[Either Grapheme [Lexeme Expanded 'AnyPart]]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
baseLen) (Int -> Bool)
-> ([Either Grapheme [Lexeme Expanded 'AnyPart]] -> Int)
-> [Either Grapheme [Lexeme Expanded 'AnyPart]]
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Either Grapheme [Lexeme Expanded 'AnyPart]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [[Either Grapheme [Lexeme Expanded 'AnyPart]]]
derivedValues) (Either ExpandError () -> Either ExpandError ())
-> Either ExpandError () -> Either ExpandError ()
forall a b. (a -> b) -> a -> b
$
            ExpandError -> Either ExpandError ()
forall a b. a -> Either a b
Left ExpandError
MismatchedLengths

        let features :: [(String, Expanded 'AnyPart)]
features = (String
 -> [Either Grapheme [Lexeme Expanded 'AnyPart]]
 -> (String, Expanded 'AnyPart))
-> [String]
-> [[Either Grapheme [Lexeme Expanded 'AnyPart]]]
-> [(String, Expanded 'AnyPart)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
               (\String
base [Either Grapheme [Lexeme Expanded 'AnyPart]]
ds -> (String
base, [Either Grapheme [Lexeme Expanded 'AnyPart]] -> Expanded 'AnyPart
forall (a :: LexemeType).
[Either Grapheme [Lexeme Expanded a]] -> Expanded a
FromElements ([Either Grapheme [Lexeme Expanded 'AnyPart]] -> Expanded 'AnyPart)
-> [Either Grapheme [Lexeme Expanded 'AnyPart]]
-> Expanded 'AnyPart
forall a b. (a -> b) -> a -> b
$ Grapheme -> Either Grapheme [Lexeme Expanded 'AnyPart]
forall a b. a -> Either a b
Left (String -> Grapheme
GMulti String
base) Either Grapheme [Lexeme Expanded 'AnyPart]
-> [Either Grapheme [Lexeme Expanded 'AnyPart]]
-> [Either Grapheme [Lexeme Expanded 'AnyPart]]
forall a. a -> [a] -> [a]
: [Either Grapheme [Lexeme Expanded 'AnyPart]]
ds))
               [String]
baseValues'
               ([[Either Grapheme [Lexeme Expanded 'AnyPart]]]
-> [[Either Grapheme [Lexeme Expanded 'AnyPart]]]
forall a. [[a]] -> [[a]]
transpose [[Either Grapheme [Lexeme Expanded 'AnyPart]]]
derivedValues)
            newCats :: [(String, Expanded 'AnyPart)]
newCats =
                [(String, Expanded 'AnyPart)]
-> (String -> [(String, Expanded 'AnyPart)])
-> Maybe String
-> [(String, Expanded 'AnyPart)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((String, Expanded 'AnyPart) -> [(String, Expanded 'AnyPart)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String, Expanded 'AnyPart) -> [(String, Expanded 'AnyPart)])
-> (String -> (String, Expanded 'AnyPart))
-> String
-> [(String, Expanded 'AnyPart)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,Expanded 'AnyPart
baseValues)) (FeatureSpec -> Maybe String
featureBaseName FeatureSpec
spec)
                [(String, Expanded 'AnyPart)]
-> [(String, Expanded 'AnyPart)] -> [(String, Expanded 'AnyPart)]
forall a. [a] -> [a] -> [a]
++ [(String, Expanded 'AnyPart)]
derivedCats
                [(String, Expanded 'AnyPart)]
-> [(String, Expanded 'AnyPart)] -> [(String, Expanded 'AnyPart)]
forall a. [a] -> [a] -> [a]
++ [(String, Expanded 'AnyPart)]
features
        Categories -> Either ExpandError Categories
forall a b. b -> Either a b
Right (Categories -> Either ExpandError Categories)
-> Categories -> Either ExpandError Categories
forall a b. (a -> b) -> a -> b
$ (Categories -> (String, Expanded 'AnyPart) -> Categories)
-> Categories -> [(String, Expanded 'AnyPart)] -> Categories
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (((String, Expanded 'AnyPart) -> Categories -> Categories)
-> Categories -> (String, Expanded 'AnyPart) -> Categories
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((String, Expanded 'AnyPart) -> Categories -> Categories)
 -> Categories -> (String, Expanded 'AnyPart) -> Categories)
-> ((String, Expanded 'AnyPart) -> Categories -> Categories)
-> Categories
-> (String, Expanded 'AnyPart)
-> Categories
forall a b. (a -> b) -> a -> b
$ (String -> Expanded 'AnyPart -> Categories -> Categories)
-> (String, Expanded 'AnyPart) -> Categories -> Categories
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry String -> Expanded 'AnyPart -> Categories -> Categories
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert) Categories
cs [(String, Expanded 'AnyPart)]
newCats

expandSoundChanges
    :: SoundChanges CategorySpec Directive
    -> Either ExpandError (SoundChanges Expanded [Grapheme])
expandSoundChanges :: SoundChanges CategorySpec Directive
-> Either ExpandError (SoundChanges Expanded [Grapheme])
expandSoundChanges = ([Maybe (Statement Expanded [Grapheme])]
 -> SoundChanges Expanded [Grapheme])
-> Either ExpandError [Maybe (Statement Expanded [Grapheme])]
-> Either ExpandError (SoundChanges Expanded [Grapheme])
forall a b.
(a -> b) -> Either ExpandError a -> Either ExpandError b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe (Statement Expanded [Grapheme])]
-> SoundChanges Expanded [Grapheme]
forall a. [Maybe a] -> [a]
catMaybes (Either ExpandError [Maybe (Statement Expanded [Grapheme])]
 -> Either ExpandError (SoundChanges Expanded [Grapheme]))
-> (SoundChanges CategorySpec Directive
    -> Either ExpandError [Maybe (Statement Expanded [Grapheme])])
-> SoundChanges CategorySpec Directive
-> Either ExpandError (SoundChanges Expanded [Grapheme])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT
   (Categories, [String])
   (Either ExpandError)
   [Maybe (Statement Expanded [Grapheme])]
 -> (Categories, [String])
 -> Either ExpandError [Maybe (Statement Expanded [Grapheme])])
-> (Categories, [String])
-> StateT
     (Categories, [String])
     (Either ExpandError)
     [Maybe (Statement Expanded [Grapheme])]
-> Either ExpandError [Maybe (Statement Expanded [Grapheme])]
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT
  (Categories, [String])
  (Either ExpandError)
  [Maybe (Statement Expanded [Grapheme])]
-> (Categories, [String])
-> Either ExpandError [Maybe (Statement Expanded [Grapheme])]
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Categories
forall k a. Map k a
M.empty, []) (StateT
   (Categories, [String])
   (Either ExpandError)
   [Maybe (Statement Expanded [Grapheme])]
 -> Either ExpandError [Maybe (Statement Expanded [Grapheme])])
-> (SoundChanges CategorySpec Directive
    -> StateT
         (Categories, [String])
         (Either ExpandError)
         [Maybe (Statement Expanded [Grapheme])])
-> SoundChanges CategorySpec Directive
-> Either ExpandError [Maybe (Statement Expanded [Grapheme])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Statement CategorySpec Directive
 -> StateT
      (Categories, [String])
      (Either ExpandError)
      (Maybe (Statement Expanded [Grapheme])))
-> SoundChanges CategorySpec Directive
-> StateT
     (Categories, [String])
     (Either ExpandError)
     [Maybe (Statement Expanded [Grapheme])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Statement CategorySpec Directive
-> StateT
     (Categories, [String])
     (Either ExpandError)
     (Maybe (Statement Expanded [Grapheme]))
go
  where
    go  :: Statement CategorySpec Directive
        -> StateT
            (Categories, [String])
            (Either ExpandError)
            (Maybe (Statement Expanded [Grapheme]))
    go :: Statement CategorySpec Directive
-> StateT
     (Categories, [String])
     (Either ExpandError)
     (Maybe (Statement Expanded [Grapheme]))
go (RuleS Rule CategorySpec
r) = do
        Categories
cs <- ((Categories, [String]) -> Categories)
-> StateT (Categories, [String]) (Either ExpandError) Categories
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Categories, [String]) -> Categories
forall a b. (a, b) -> a
fst
        Either ExpandError (Maybe (Statement Expanded [Grapheme]))
-> StateT
     (Categories, [String])
     (Either ExpandError)
     (Maybe (Statement Expanded [Grapheme]))
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Categories, [String]) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either ExpandError (Maybe (Statement Expanded [Grapheme]))
 -> StateT
      (Categories, [String])
      (Either ExpandError)
      (Maybe (Statement Expanded [Grapheme])))
-> Either ExpandError (Maybe (Statement Expanded [Grapheme]))
-> StateT
     (Categories, [String])
     (Either ExpandError)
     (Maybe (Statement Expanded [Grapheme]))
forall a b. (a -> b) -> a -> b
$ Statement Expanded [Grapheme]
-> Maybe (Statement Expanded [Grapheme])
forall a. a -> Maybe a
Just (Statement Expanded [Grapheme]
 -> Maybe (Statement Expanded [Grapheme]))
-> (Rule Expanded -> Statement Expanded [Grapheme])
-> Rule Expanded
-> Maybe (Statement Expanded [Grapheme])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule Expanded -> Statement Expanded [Grapheme]
forall (c :: LexemeType -> *) decl. Rule c -> Statement c decl
RuleS (Rule Expanded -> Maybe (Statement Expanded [Grapheme]))
-> Either ExpandError (Rule Expanded)
-> Either ExpandError (Maybe (Statement Expanded [Grapheme]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Categories
-> Rule CategorySpec -> Either ExpandError (Rule Expanded)
expandRule Categories
cs Rule CategorySpec
r
    go (FilterS Filter CategorySpec
f) = do
        Categories
cs <- ((Categories, [String]) -> Categories)
-> StateT (Categories, [String]) (Either ExpandError) Categories
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Categories, [String]) -> Categories
forall a b. (a, b) -> a
fst
        Either ExpandError (Maybe (Statement Expanded [Grapheme]))
-> StateT
     (Categories, [String])
     (Either ExpandError)
     (Maybe (Statement Expanded [Grapheme]))
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Categories, [String]) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either ExpandError (Maybe (Statement Expanded [Grapheme]))
 -> StateT
      (Categories, [String])
      (Either ExpandError)
      (Maybe (Statement Expanded [Grapheme])))
-> Either ExpandError (Maybe (Statement Expanded [Grapheme]))
-> StateT
     (Categories, [String])
     (Either ExpandError)
     (Maybe (Statement Expanded [Grapheme]))
forall a b. (a -> b) -> a -> b
$ Statement Expanded [Grapheme]
-> Maybe (Statement Expanded [Grapheme])
forall a. a -> Maybe a
Just (Statement Expanded [Grapheme]
 -> Maybe (Statement Expanded [Grapheme]))
-> (Filter Expanded -> Statement Expanded [Grapheme])
-> Filter Expanded
-> Maybe (Statement Expanded [Grapheme])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Filter Expanded -> Statement Expanded [Grapheme]
forall (c :: LexemeType -> *) decl. Filter c -> Statement c decl
FilterS (Filter Expanded -> Maybe (Statement Expanded [Grapheme]))
-> Either ExpandError (Filter Expanded)
-> Either ExpandError (Maybe (Statement Expanded [Grapheme]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Categories
-> Filter CategorySpec -> Either ExpandError (Filter Expanded)
expandFilter Categories
cs Filter CategorySpec
f
    go (DirectiveS (ExtraGraphemes [String]
extra)) = do
        (Categories
cs, [String]
_) <- StateT
  (Categories, [String]) (Either ExpandError) (Categories, [String])
forall s (m :: * -> *). MonadState s m => m s
get
        (Categories, [String])
-> StateT (Categories, [String]) (Either ExpandError) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Categories
cs, [String]
extra)
        Maybe (Statement Expanded [Grapheme])
-> StateT
     (Categories, [String])
     (Either ExpandError)
     (Maybe (Statement Expanded [Grapheme]))
forall a. a -> StateT (Categories, [String]) (Either ExpandError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Statement Expanded [Grapheme])
forall a. Maybe a
Nothing
    go (DirectiveS (Categories Bool
overwrite Bool
noreplace [CategoryDefinition]
defs)) = do
        (Categories
cs, [String]
extra) <- StateT
  (Categories, [String]) (Either ExpandError) (Categories, [String])
forall s (m :: * -> *). MonadState s m => m s
get
        Categories
cs' <- Either ExpandError Categories
-> StateT (Categories, [String]) (Either ExpandError) Categories
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Categories, [String]) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either ExpandError Categories
 -> StateT (Categories, [String]) (Either ExpandError) Categories)
-> Either ExpandError Categories
-> StateT (Categories, [String]) (Either ExpandError) Categories
forall a b. (a -> b) -> a -> b
$ Categories
-> (Bool, [CategoryDefinition]) -> Either ExpandError Categories
extendCategories Categories
cs (Bool
overwrite, [CategoryDefinition]
defs)
        (Categories, [String])
-> StateT (Categories, [String]) (Either ExpandError) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Categories
cs', [String]
extra)
        Maybe (Statement Expanded [Grapheme])
-> StateT
     (Categories, [String])
     (Either ExpandError)
     (Maybe (Statement Expanded [Grapheme]))
forall a. a -> StateT (Categories, [String]) (Either ExpandError) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Statement Expanded [Grapheme])
 -> StateT
      (Categories, [String])
      (Either ExpandError)
      (Maybe (Statement Expanded [Grapheme])))
-> Maybe (Statement Expanded [Grapheme])
-> StateT
     (Categories, [String])
     (Either ExpandError)
     (Maybe (Statement Expanded [Grapheme]))
forall a b. (a -> b) -> a -> b
$ if Bool
noreplace
            then Maybe (Statement Expanded [Grapheme])
forall a. Maybe a
Nothing
            else Statement Expanded [Grapheme]
-> Maybe (Statement Expanded [Grapheme])
forall a. a -> Maybe a
Just (Statement Expanded [Grapheme]
 -> Maybe (Statement Expanded [Grapheme]))
-> Statement Expanded [Grapheme]
-> Maybe (Statement Expanded [Grapheme])
forall a b. (a -> b) -> a -> b
$ [Grapheme] -> Statement Expanded [Grapheme]
forall (c :: LexemeType -> *) decl. decl -> Statement c decl
DirectiveS ([Grapheme] -> Statement Expanded [Grapheme])
-> [Grapheme] -> Statement Expanded [Grapheme]
forall a b. (a -> b) -> a -> b
$ (String -> Grapheme) -> [String] -> [Grapheme]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Grapheme
GMulti [String]
extra [Grapheme] -> [Grapheme] -> [Grapheme]
forall a. [a] -> [a] -> [a]
++ (Either Grapheme [Lexeme Expanded 'AnyPart] -> Maybe Grapheme)
-> [Either Grapheme [Lexeme Expanded 'AnyPart]] -> [Grapheme]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Either Grapheme [Lexeme Expanded 'AnyPart] -> Maybe Grapheme
forall {a} {b}. Either a b -> Maybe a
left (Categories -> [Either Grapheme [Lexeme Expanded 'AnyPart]]
values Categories
cs')

    left :: Either a b -> Maybe a
left (Left a
l) = a -> Maybe a
forall a. a -> Maybe a
Just a
l
    left (Right b
_) = Maybe a
forall a. Maybe a
Nothing