{-# 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
       , extend
       , 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)
import Data.Containers.ListUtils (nubOrd)
import Data.List (intersect, transpose, foldl')
import Data.Maybe (mapMaybe)
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 = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (a :: LexemeType). Expanded 'AnyPart -> Expanded a
generaliseExpanded forall b c a. (b -> c) -> (a -> b) -> a -> c
.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = 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 (a :: LexemeType).
Expanded a -> [Either Grapheme [Lexeme Expanded a]]
elements forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExpandError] -> ShowS
$cshowList :: [ExpandError] -> ShowS
show :: ExpandError -> String
$cshow :: ExpandError -> String
showsPrec :: Int -> ExpandError -> ShowS
$cshowsPrec :: Int -> ExpandError -> ShowS
Show, 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
$cto :: forall x. Rep ExpandError x -> ExpandError
$cfrom :: forall x. ExpandError -> Rep ExpandError x
Generic, ExpandError -> ()
forall a. (a -> ()) -> NFData a
rnf :: ExpandError -> ()
$crnf :: 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) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> ExpandError
NotFound String
g) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (a :: LexemeType).
String -> Categories -> Maybe (Expanded a)
lookup String
g Categories
cs
expand Categories
cs (CategorySpec [(CategoryModification, Either Grapheme [Lexeme CategorySpec a])]
spec) = forall (a :: LexemeType).
[Either Grapheme [Lexeme Expanded a]] -> Expanded a
FromElements forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) <- forall (a :: LexemeType).
String -> Categories -> Maybe (Expanded a)
lookup String
g Categories
cs
                -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [Either Grapheme [Lexeme Expanded a]]
c
                | Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall a b. a -> Either a b
Left (String -> Grapheme
GMulti String
g)]
            Left Grapheme
GBoundary -> forall (f :: * -> *) a. Applicative f => a -> f a
pure [forall a b. a -> Either a b
Left Grapheme
GBoundary]
            Right [Lexeme CategorySpec a]
ls -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (a :: LexemeType).
Categories
-> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
expandLexeme Categories
cs) [Lexeme CategorySpec a]
ls
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case CategoryModification
modifier of
            CategoryModification
Union -> [Either Grapheme [Lexeme Expanded a]]
es forall a. [a] -> [a] -> [a]
++ [Either Grapheme [Lexeme Expanded a]]
new
            CategoryModification
Intersect -> [Either Grapheme [Lexeme Expanded a]]
es forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Either Grapheme [Lexeme Expanded a]]
new
            CategoryModification
Subtract -> [Either Grapheme [Lexeme Expanded a]]
es 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 = forall a. (a -> Bool) -> [a] -> [a]
filter (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
'~') <- forall a. [a] -> Maybe ([a], a)
unsnoc String
g
        = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (category :: LexemeType -> *) (a :: LexemeType).
Grapheme -> Lexeme category a
Grapheme forall a b. (a -> b) -> a -> b
$ String -> Grapheme
GMulti String
g'
    | Bool
otherwise = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
        case forall (a :: LexemeType).
String -> Categories -> Maybe (Expanded a)
lookup String
g Categories
cs of
            Just Expanded a
c -> forall (category :: LexemeType -> *) (a :: LexemeType).
category a -> Lexeme category a
Category Expanded a
c
            Maybe (Expanded a)
Nothing -> 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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\a
x -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([], a
x) (\(~([a]
a, a
b)) -> (a
x forall a. a -> [a] -> [a]
: [a]
a, a
b))) forall a. Maybe a
Nothing
    {-# INLINABLE unsnoc #-}

expandLexeme Categories
_  (Grapheme Grapheme
GBoundary) = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (category :: LexemeType -> *) (a :: LexemeType).
Grapheme -> Lexeme category a
Grapheme Grapheme
GBoundary
expandLexeme Categories
cs (Category CategorySpec a
c) = forall (category :: LexemeType -> *) (a :: LexemeType).
category a -> Lexeme category a
Category forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: LexemeType).
Categories -> CategorySpec a -> Either ExpandError (Expanded a)
expand Categories
cs CategorySpec a
c
expandLexeme Categories
cs (Optional [Lexeme CategorySpec a]
ls) = forall (category :: LexemeType -> *) (a :: LexemeType).
[Lexeme category a] -> Lexeme category a
Optional forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (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 = forall a b. b -> Either a b
Right forall (category :: LexemeType -> *). Lexeme category 'Replacement
Metathesis
expandLexeme Categories
_  Lexeme CategorySpec a
Geminate = forall a b. b -> Either a b
Right forall (category :: LexemeType -> *) (a :: LexemeType).
Lexeme category a
Geminate
expandLexeme Categories
cs (Wildcard Lexeme CategorySpec a
l) = forall (a :: LexemeType) (category :: LexemeType -> *).
OneOf a 'Target 'Env =>
Lexeme category a -> Lexeme category a
Wildcard forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) = forall (a :: LexemeType) (category :: LexemeType -> *).
OneOf a 'Target 'Env =>
Lexeme category a -> Lexeme category a
Kleene forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall a b. b -> Either a b
Right forall (category :: LexemeType -> *). Lexeme category 'Replacement
Discard
expandLexeme Categories
cs (Backreference Int
i CategorySpec a
c) = forall (category :: LexemeType -> *) (a :: LexemeType).
Int -> category a -> Lexeme category a
Backreference Int
i forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: LexemeType).
Categories -> CategorySpec a -> Either ExpandError (Expanded a)
expand Categories
cs CategorySpec a
c
expandLexeme Categories
cs (Multiple CategorySpec 'Replacement
c) = forall (category :: LexemeType -> *).
category 'Replacement -> Lexeme category 'Replacement
Multiple forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall (c :: LexemeType -> *).
[Lexeme c 'Target]
-> [Lexeme c 'Replacement]
-> [Environment c]
-> Maybe (Environment c)
-> Flags
-> String
-> Rule c
Rule
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (a :: LexemeType).
Categories
-> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
expandLexeme Categories
cs) (forall (c :: LexemeType -> *). Rule c -> [Lexeme c 'Target]
target Rule CategorySpec
r)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (a :: LexemeType).
Categories
-> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
expandLexeme Categories
cs) (forall (c :: LexemeType -> *). Rule c -> [Lexeme c 'Replacement]
replacement Rule CategorySpec
r)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([Lexeme CategorySpec 'Env], [Lexeme CategorySpec 'Env])
-> Either ExpandError (Environment Expanded)
expandEnvironment (forall (c :: LexemeType -> *). Rule c -> [Environment c]
environment Rule CategorySpec
r)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ([Lexeme CategorySpec 'Env], [Lexeme CategorySpec 'Env])
-> Either ExpandError (Environment Expanded)
expandEnvironment (forall (c :: LexemeType -> *). Rule c -> Maybe (Environment c)
exception Rule CategorySpec
r)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (c :: LexemeType -> *). Rule c -> Flags
flags Rule CategorySpec
r)
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (c :: LexemeType -> *). Rule c -> String
plaintext Rule CategorySpec
r)
  where
    expandEnvironment :: ([Lexeme CategorySpec 'Env], [Lexeme CategorySpec 'Env])
-> Either ExpandError (Environment Expanded)
expandEnvironment ([Lexeme CategorySpec 'Env]
e1, [Lexeme CategorySpec 'Env]
e2) = (,)
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (a :: LexemeType).
Categories
-> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
expandLexeme Categories
cs) [Lexeme CategorySpec 'Env]
e1
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (a :: LexemeType).
Categories
-> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
expandLexeme Categories
cs) [Lexeme CategorySpec 'Env]
e2

extend :: Categories -> Directive -> Either ExpandError Categories
extend :: Categories -> Directive -> Either ExpandError Categories
extend Categories
cs' (Categories Bool
overwrite [CategoryDefinition]
defs) =
    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 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) = forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
name) Categories
cs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 <- forall (a :: LexemeType).
Categories -> CategorySpec a -> Either ExpandError (Expanded a)
expand Categories
cs forall a b. (a -> b) -> a -> b
$ FeatureSpec -> CategorySpec 'AnyPart
featureBaseValues FeatureSpec
spec
        [(String, Expanded 'AnyPart)]
derivedCats <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ forall (a :: LexemeType).
Categories -> CategorySpec a -> Either ExpandError (Expanded a)
expand Categories
cs) forall a b. (a -> b) -> a -> b
$ FeatureSpec -> [(String, CategorySpec 'AnyPart)]
featureDerived FeatureSpec
spec

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

        let features :: [(String, Expanded 'AnyPart)]
features = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith
               (\String
base [Either Grapheme [Lexeme Expanded 'AnyPart]]
ds -> (String
base, forall (a :: LexemeType).
[Either Grapheme [Lexeme Expanded a]] -> Expanded a
FromElements forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (String -> Grapheme
GMulti String
base) forall a. a -> [a] -> [a]
: [Either Grapheme [Lexeme Expanded 'AnyPart]]
ds))
               [String]
baseValues'
               (forall a. [[a]] -> [[a]]
transpose [[Either Grapheme [Lexeme Expanded 'AnyPart]]]
derivedValues)
            newCats :: [(String, Expanded 'AnyPart)]
newCats =
                forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,Expanded 'AnyPart
baseValues)) (FeatureSpec -> Maybe String
featureBaseName FeatureSpec
spec)
                forall a. [a] -> [a] -> [a]
++ [(String, Expanded 'AnyPart)]
derivedCats
                forall a. [a] -> [a] -> [a]
++ [(String, Expanded 'AnyPart)]
features
        forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT forall k a. Map k a
M.empty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Statement CategorySpec Directive
-> StateT
     Categories (Either ExpandError) (Statement Expanded [Grapheme])
go
  where
    go  :: Statement CategorySpec Directive
        -> StateT Categories (Either ExpandError) (Statement Expanded [Grapheme])
    go :: Statement CategorySpec Directive
-> StateT
     Categories (Either ExpandError) (Statement Expanded [Grapheme])
go (RuleS Rule CategorySpec
r) = do
        Categories
cs <- forall s (m :: * -> *). MonadState s m => m s
get
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (c :: LexemeType -> *) decl. Rule c -> Statement c decl
RuleS 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 (DirectiveS Directive
d) = do
        Categories
cs <- forall s (m :: * -> *). MonadState s m => m s
get
        Categories
cs' <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Categories -> Directive -> Either ExpandError Categories
extend Categories
cs Directive
d
        forall s (m :: * -> *). MonadState s m => s -> m ()
put Categories
cs'
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (c :: LexemeType -> *) decl. decl -> Statement c decl
DirectiveS forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a} {b}. Either a b -> Maybe a
left forall a b. (a -> b) -> a -> b
$ Categories -> [Either Grapheme [Lexeme Expanded 'AnyPart]]
values Categories
cs'

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