brassica 0.1.1 → 0.2.0

raw patch · 18 files changed

+665/−459 lines, 18 filesdep +vectordep ~bytestringdep ~criteriondep ~deepseqPVP ok

version bump matches the API change (PVP)

Dependencies added: vector

Dependency ranges changed: bytestring, criterion, deepseq, megaparsec, mtl, optparse-applicative, text, transformers

API changes (from Hackage documentation)

Files

• ChangeLog.md +13/−0
• LICENSE +1/−1
• README.md +2/−2
• bench/Changes.hs +17/−11
• brassica.cabal +12/−11
• cli/Main.hs +23/−17
• cli/Server.hs +14/−3
• src/Brassica/Paradigm.hs +2/−3
• src/Brassica/Paradigm/Apply.hs +53/−15
• src/Brassica/Paradigm/Parse.hs +1/−1
• src/Brassica/SoundChange/Apply/Internal.hs +72/−51
• src/Brassica/SoundChange/Apply/Internal/MultiZipper.hs +43/−48
• src/Brassica/SoundChange/Category.hs +142/−89
• src/Brassica/SoundChange/Frontend/Internal.hs +34/−29
• src/Brassica/SoundChange/Parse.hs +87/−131
• src/Brassica/SoundChange/Tokenise.hs +3/−3
• src/Brassica/SoundChange/Types.hs +137/−41
• test/Spec.hs +9/−3

@@ -1,5 +1,18 @@ # Brassica changelog +## v0.2.0++- Allow grapheme to begin with star+- Allow lexeme sequences in categories using `{…}` syntax+- Allow backreferences to occur in the environment+- Allow user to choose separator used between multiple results (previously a space)+- Internal refactor: category expansion is now separate from parsing+- Add `--version` command-line option+- Store `MultiZipper` data in a `Vector` rather than a linked list (for performance)+- Bugfix: subtraction now removes all subtracted graphemes+- Store paradigm builder output in a tree data structure, allowing a more compact output format+- Documented abstract features in paradigm builder (previously present but undocumented)+ ## v0.1.1  - Rewrote executables with a client/server architecture for better Windows support.

@@ -1,4 +1,4 @@-Copyright Brad Neimann (c) 2020-2023+Copyright Brad Neimann (c) 2020-2024  All rights reserved. 

@@ -5,7 +5,7 @@ Brassica is a new sound change applier. Its features include: -- Can be used interactively both [online](http://bradrn.com/brassica/index.html) and as a desktop application, or non-interactively in batch mode on the command-line or as a [Haskell library](https://hackage.haskell.org/package/brassica)+- Can be used interactively both [online](https://bradrn.com/brassica/index.html) and as a desktop application, or non-interactively in batch mode on the command-line or as a [Haskell library](https://hackage.haskell.org/package/brassica) - Natively supports the MDF dictionary format, also used by tools including [SIL Toolbox](https://software.sil.org/toolbox/) and [Lexique Pro](https://software.sil.org/lexiquepro/) - First-class support for multigraphs - Easy control over rule application: apply sound changes sporadically, right-to-left, between words, and in many more ways@@ -13,7 +13,7 @@ - Highlight and visualise results in numerous ways - Category operations allow phonetic rules to be written in both featural and character-based ways - Support for ‘features’ lets rules easily manipulate stress, tone and other suprasegmentals-- Comes with a paradigm builder for quickly investigating inflectional and other patterns+- Comes with a [paradigm builder](https://bradrn.com/brassica/builder.html) for quickly investigating inflectional and other patterns - Rich syntax for specifying phonetic rules, including wildcards, optional elements and more  And many more!

@@ -1,13 +1,15 @@+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module Main where
 
-import Criterion.Main (defaultMain, bench, nf, bgroup)
+import Criterion.Main (defaultMain, bench, nf, bgroup, Benchmark)
 import Data.FileEmbed (embedFile)
 import Data.Text (unpack)
 import Data.Text.Encoding (decodeUtf8)
 
 import Brassica.SoundChange
+import Brassica.SoundChange.Frontend.Internal
 
 main :: IO ()
 main = defaultMain
@@ -33,16 +35,19 @@       [ bench "parse" $ nf parseSoundChanges manyChanges
       , bench "parseRun" $ case parseSoundChanges manyChanges of
             Left _ -> error "invalid changes file"
-            Right cs -> case withFirstCategoriesDecl tokeniseWords cs manyWords of
-                Left _ -> error "invalid words file"
-                Right ws -> nf (fmap $ applyChanges cs) $ getWords ws
+            Right cs -> nf (parseTokeniseAndApplyRules
+                    cs
+                    manyWords
+                    Raw
+                    (ApplyRules NoHighlight WordsOnlyOutput "/"))
+                    Nothing
       ]
     ]
   where
     basic = Rule
         { target = [Grapheme "a"]
         , replacement = [Grapheme "b"]
-        , environment = ([], [])
+        , environment = [([], [])]
         , exception = Nothing
         , flags = defFlags
         , plaintext = "a/b"
@@ -50,23 +55,24 @@ 
     complex = Rule
         { target =
-            [ Category [GraphemeEl "t", GraphemeEl "d", GraphemeEl "n"]
+            [ Category $ FromElements $ Left <$> ["t", "d", "n"]
             , Optional [Grapheme "y"]
-            , Category [GraphemeEl "i", GraphemeEl "e"]
+            , Category $ FromElements $ Left <$> ["i", "e"]
             ]
         , replacement =
-            [ Category [GraphemeEl "c", GraphemeEl "j", GraphemeEl "nh"]
+            [ Category $ FromElements $ Left <$> ["c", "j", "nh"]
             , Optional [Geminate]
             ]
-        , environment =
-            ( [Category [BoundaryEl, GraphemeEl "a", GraphemeEl "e", GraphemeEl "i"]]
-            , [Category [GraphemeEl "a", GraphemeEl "e", GraphemeEl "i", GraphemeEl "o", GraphemeEl "u"]]
+        , environment = pure
+            ( [Category $ FromElements $ Left <$> [GBoundary, "a", "e", "i"]]
+            , [Category $ FromElements $ Left <$> ["a", "e", "i", "o", "u"]]
             )
         , exception = Nothing
         , flags = defFlags
         , plaintext = "[t d n] (y) [i e] / [č j ñ] (>) / [# a e i] _ [a e i o u]"
         }
 
+    benchChanges :: Rule Expanded -> PWord -> [Benchmark]
     benchChanges cs l =
         -- [ bench "log" $ nf (applyStatementWithLogs (RuleS cs)) l
         -- given the implementation of logging, the above benchmark doesn't help very much at all

@@ -1,6 +1,6 @@ cabal-version:      2.0 name:               brassica-version:            0.1.1+version:            0.2.0 synopsis:           Featureful sound change applier description:   The Brassica library for the simulation of sound changes in historical linguistics and language construction.@@ -43,12 +43,13 @@   build-depends:                    base >=4.7 && <5                  , containers >=0.6 && <0.7-                 , deepseq >=1.4 && <1.5-                 , megaparsec >=8.0 && <9.3-                 , mtl >=2.2 && <2.3+                 , deepseq >=1.4 && <1.6+                 , megaparsec >=8.0 && <9.7+                 , mtl >=2.2 && <2.4                  , parser-combinators >=1.2 && <1.3                  , split >=0.2 && <0.3-                 , transformers >=0.5 && <0.6+                 , transformers >=0.5 && <0.7+                 , vector >=0.13 && <0.14    default-language: Haskell2010 @@ -62,12 +63,12 @@                   , brassica                   , aeson ^>=2.2                   , attoparsec-aeson ^>=2.2-                  , bytestring >=0.10 && <0.12+                  , bytestring >=0.10 && <0.13                   , conduit ^>=1.3                   , conduit-extra ^>=1.3-                  , deepseq >=1.4 && <1.5-                  , optparse-applicative ^>=0.17-                  , text >=1.2 && <2.1+                  , deepseq >=1.4 && <1.6+                  , optparse-applicative ^>=0.17 || ^>=0.18+                  , text >=1.2 && <2.2    default-language: Haskell2010 @@ -79,7 +80,7 @@   build-depends:                     base >=4.7 && <5                   , brassica-                  , criterion >=1.5 && <1.6+                  , criterion >=1.5 && <1.7                   , file-embed >=0.0.15 && <0.0.16                   , text >=1.2 && <1.3 @@ -93,7 +94,7 @@   build-depends:                     base >=4.7 && <5                   , brassica-                  , criterion >=1.5 && <1.6+                  , criterion >=1.5 && <1.7    default-language: Haskell2010 

@@ -33,7 +33,7 @@                     .| outC    where-    opts = info (args <**> helper) fullDesc+    opts = info (args <**> helper <**> simpleVersioner "v0.2.0") fullDesc      args = batchArgs <|> serverArgs     serverArgs = flag' Server (long "server" <> help "Run server (for internal use only)")@@ -42,20 +42,22 @@             (metavar "RULES" <> help "File containing sound changes")         <*> flag Raw MDF             (long "mdf" <> help "Parse input words in MDF format")-        <*> asum-            [ flag' ReportRulesApplied-                (long "report" <> help "Report rules applied rather than outputting words")-            , flag' (ApplyRules NoHighlight MDFOutput)-                (long "mdf-out" <> help "With --mdf, output MDF dictionary")-            , flag' (ApplyRules NoHighlight MDFOutputWithEtymons)-                (long "etymons" <> help "With --mdf, output MDF dictionary with etymologies")-            , flag' (ApplyRules NoHighlight WordsWithProtoOutput)-                (long "show-input" <> help "Output an input→output wordlist")-            , flag-                (ApplyRules NoHighlight WordsOnlyOutput)-                (ApplyRules NoHighlight WordsOnlyOutput)-                (long "wordlist" <> help "Output only a list of the derived words (default)")-            ]+        <*> (asum+                [ flag' (const ReportRulesApplied)+                    (long "report" <> help "Report rules applied rather than outputting words")+                , flag' (ApplyRules NoHighlight MDFOutput)+                    (long "mdf-out" <> help "With --mdf, output MDF dictionary")+                , flag' (ApplyRules NoHighlight MDFOutputWithEtymons)+                    (long "etymons" <> help "With --mdf, output MDF dictionary with etymologies")+                , flag' (ApplyRules NoHighlight WordsWithProtoOutput)+                    (long "show-input" <> help "Output an input→output wordlist")+                , flag+                    (ApplyRules NoHighlight WordsOnlyOutput)+                    (ApplyRules NoHighlight WordsOnlyOutput)+                    (long "wordlist" <> help "Output only a list of the derived words (default)")+                ]+            <*> strOption+                (long "separator" <> short 's' <> value "/" <> help "Separator between multiple results (default: /)"))         <*> optional (strOption             (long "in" <> short 'i' <> help "File containing input words (if not specified will read from stdin)"))         <*> optional (strOption@@ -83,7 +85,7 @@ processWords     :: (MonadIO m, MonadThrow m)     => Bool  -- split into lines?-    -> SoundChanges+    -> SoundChanges CategorySpec Directive     -> InputLexiconFormat     -> ApplicationMode     -> ConduitT B.ByteString B.ByteString m ()@@ -101,10 +103,14 @@         Left e -> throwM e         Right r -> yield r -    processApplicationOutput :: ApplicationOutput PWord Statement -> Either ParseException Text+    processApplicationOutput :: ApplicationOutput PWord (Statement Expanded [Grapheme]) -> Either ParseException Text     processApplicationOutput (HighlightedWords cs) = Right $ pack $ detokeniseWords $ (fmap.fmap) fst cs     processApplicationOutput (AppliedRulesTable is) = Right $ pack $ unlines $ reportAsText plaintext' <$> is     processApplicationOutput (ParseError e) = Left $ ParseException $ errorBundlePretty e+    processApplicationOutput (ExpandError e) = Left $ ParseException $ case e of+        (NotFound s) -> "Could not find category: " ++ s+        InvalidBaseValue -> "Invalid value used as base grapheme in feature definition"+        MismatchedLengths -> "Mismatched lengths in feature definition"  newtype ParseException = ParseException String     deriving Show

@@ -18,13 +18,14 @@ import Data.Aeson.TH (deriveJSON, defaultOptions, defaultTaggedObject, constructorTagModifier, sumEncoding, tagFieldName) import Data.ByteString (toStrict) import Data.Conduit.Attoparsec (conduitParser)+import Data.Foldable (toList) import GHC.Generics (Generic) import System.IO (hSetBuffering, stdin, stdout, BufferMode(NoBuffering)) import System.Timeout  import Brassica.SoundChange import Brassica.SoundChange.Frontend.Internal-import Brassica.Paradigm (applyParadigm, parseParadigm)+import Brassica.Paradigm (applyParadigm, parseParadigm, formatNested, ResultsTree (..))  data Request     = ReqRules@@ -35,10 +36,12 @@         , hlMode :: HighlightMode         , outMode :: OutputMode         , prev :: Maybe [Component PWord]+        , sep :: String         }     | ReqParadigm         { pText :: String         , input :: String+        , separateLines :: Bool         }     deriving (Show) @@ -95,7 +98,7 @@     let mode =             if report             then ReportRulesApplied-            else ApplyRules hlMode outMode+            else ApplyRules hlMode outMode sep     in case parseSoundChanges changes of         Left e -> RespError $ "<pre>" ++ errorBundlePretty e ++ "</pre>"         Right statements ->@@ -108,6 +111,10 @@                     (escape $ detokeniseWords' highlightWord result)                 AppliedRulesTable items -> RespRules Nothing $                     surroundTable $ concatMap (reportAsHtmlRows plaintext') items+                ExpandError err -> RespError $ ("<pre>"++) $ (++"</pre>") $ case err of+                    (NotFound s) -> "Could not find category: " ++ s+                    InvalidBaseValue -> "Invalid value used as base grapheme in feature definition"+                    MismatchedLengths -> "Mismatched lengths in feature definition"   where     highlightWord (s, False) = concatWithBoundary s     highlightWord (s, True) = "<b>" ++ concatWithBoundary s ++ "</b>"@@ -120,7 +127,11 @@ parseAndBuildParadigmWrapper ReqParadigm{..} =     case parseParadigm pText of         Left e -> RespError $ "<pre>" ++ errorBundlePretty e ++ "</pre>"-        Right p -> RespParadigm $ escape $ unlines $ concatMap (applyParadigm p) $ lines input+        Right p -> RespParadigm $ escape $+            (if separateLines+                then unlines . toList+                else formatNested id)+            $ Node $ applyParadigm p <$> lines input parseAndBuildParadigmWrapper _ = error "parseAndBuildParadigmWrapper: unexpected request!"  escape :: String -> String

@@ -1,6 +1,5 @@ module Brassica.Paradigm        (-       -- * Types          Process(..)        , Affix        , Grammeme(..)@@ -10,10 +9,10 @@        , FeatureName(..)        , Statement(..)        , Paradigm-       -- * Application+       , ResultsTree(..)        , applyParadigm-       -- * Parsing        , parseParadigm+       , formatNested        -- ** Re-export        , errorBundlePretty        ) where

@@ -1,16 +1,47 @@-{-# LANGUAGE LambdaCase    #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE LambdaCase #-} -module Brassica.Paradigm.Apply (applyParadigm) where+module Brassica.Paradigm.Apply+       ( ResultsTree(..)+       , applyParadigm+       , formatNested+       ) where  import Brassica.Paradigm.Types -import Data.List (sortOn)+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 (Show, Functor, Foldable)++addLevel :: (a -> [a]) -> ResultsTree a -> ResultsTree a+addLevel f (Result r) = Node $ Result <$> f r+addLevel f (Node rs) = Node $ addLevel f <$> 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 f = snd . go+  where+    go (Result a) = (0, f a)+    go (Node rts) =+        let (depths, formatted) = unzip $ go <$> rts+            depth = maximum depths+            separator =+                if depth == 0+                then " "+                else replicate depth '\n'+        in (1+depth, intercalate separator formatted)+ -- | Apply the given 'Paradigm' to a root, to produce all possible -- derived forms.-applyParadigm :: Paradigm -> String -> [String]+applyParadigm :: Paradigm -> String -> ResultsTree String applyParadigm p w =     let fs = mapMaybe getFeature p         ms = mapMaybe getMapping p@@ -21,18 +52,25 @@      getMapping (NewMapping k v) = Just (k,v)     getMapping _ = Nothing-      -combinations :: [Feature] -> [[Grammeme]]-combinations = go []++combinations :: [Feature] -> ResultsTree [Grammeme]+combinations =+    (fmap.fmap) snd . foldl' go (Result [])   where-    go :: [(Maybe FeatureName, Grammeme)] -> [Feature] -> [[Grammeme]]-    go acc [] = return $ snd <$> reverse acc-    go acc (Feature c n gs : fs) =-        if satisfied (flip lookup acc . Just) c-        then do-            g <- gs-            go ((n,g) : acc) fs-        else go acc fs+    addFeature+        :: Feature+        -> [(Maybe FeatureName, Grammeme)]+        -> [[(Maybe FeatureName, Grammeme)]]+    addFeature (Feature c n gs) acc+        | satisfied (flip lookup acc . Just) c+        = gs <&> \g -> (n, g):acc+        | otherwise+        = [acc]++    go  :: ResultsTree [(Maybe FeatureName, Grammeme)]+        -> Feature+        -> ResultsTree [(Maybe FeatureName, Grammeme)]+    go rt f = addLevel (addFeature f) rt      satisfied         :: (FeatureName -> Maybe Grammeme)

@@ -86,6 +86,6 @@ -- | Parse a 'String' in Brassica paradigm syntax into a 'Paradigm'.
 -- Returns 'Left' if the input string is malformed.
 --
--- For details on the syntax, refer to <https://github.com/bradrn/brassica/blob/v0.1.1/Documentation.md#paradigm-builder>.
+-- For details on the syntax, refer to <https://github.com/bradrn/brassica/blob/v0.2.0/Documentation.md#paradigm-builder>.
 parseParadigm :: String -> Either (ParseErrorBundle String Void) Paradigm
 parseParadigm = runParser (many statement) ""

@@ -57,8 +57,8 @@ 
 import Control.Applicative ((<|>))
 import Control.Category ((>>>))
+import Control.Monad ((>=>), join)  -- needed for mtl>=2.3
 import Data.Containers.ListUtils (nubOrd)
-import Data.Function ((&))
 import Data.Functor ((<&>))
 import Data.Maybe (maybeToList, fromMaybe, listToMaybe, mapMaybe)
 import GHC.Generics (Generic)
@@ -128,13 +128,17 @@ instance Semigroup MatchOutput where
     (MatchOutput a1 b1 c1) <> (MatchOutput a2 b2 c2) = MatchOutput (a1++a2) (b1++b2) (c1++c2)
 
+zipWith' :: [a] -> [b] -> (a -> b -> c) -> [c]
+zipWith' xs ys f = zipWith f xs ys
+
 -- | Match a single 'Lexeme' against a 'MultiZipper', and advance the
 -- 'MultiZipper' past the match. For each match found, returns the
 -- 'MatchOutput' tupled with the updated 'MultiZipper'.
-match :: OneOf a 'Target 'Env
+match :: forall a t.
+         OneOf a 'Target 'Env
       => MatchOutput          -- ^ The previous 'MatchOutput'
       -> Maybe Grapheme       -- ^ The previously-matched grapheme, if any. (Used to match a 'Geminate'.)
-      -> Lexeme a             -- ^ The lexeme to match.
+      -> Lexeme Expanded a    -- ^ The lexeme to match.
       -> MultiZipper t Grapheme   -- ^ The 'MultiZipper' to match against.
       -> [(MatchOutput, MultiZipper t Grapheme)]
       -- ^ The output: a tuple @(g, mz)@ as described below.
@@ -152,26 +156,21 @@         [] -> error "match: Kleene should never fail"
         r' -> r'
 match out _ (Grapheme g) mz = (out <> MatchOutput [] [] [g],) <$> maybeToList (matchGrapheme g mz)
-match out _ (Category gs) mz =
-    gs
-    -- Attempt to match each option in category...
-    & fmap (matchCategoryEl mz)
-    -- ...get the index of each match...
-    & zipWith (\i m -> fmap (i,) m) [0..]
-    -- ...and take all matches
-    & (>>= maybeToList)
-    & fmap (\(i, (g, mz')) -> (out <> MatchOutput [i] [] g, mz'))
+match out prev (Category (FromElements gs)) mz =
+    concat $ zipWith' gs [0..] $ \e i ->
+        first (<> MatchOutput [i] [] []) <$>
+            case e of
+                Left  g  -> match out prev (Grapheme g :: Lexeme Expanded a) mz
+                Right ls -> matchMany out prev ls mz
 match out prev Geminate mz = case prev of
     Nothing -> []
     Just prev' -> (out <> MatchOutput [] [] [prev'],) <$> maybeToList (matchGrapheme prev' mz)
-match out _prev (Backreference i gs) mz = maybeToList $ do
-    catIx <- matchedCatIxs out !? (i-1)
-    g <- gs !? catIx
-    (matched, mz') <- matchCategoryEl mz g
-    pure (modifyMatchedGraphemes (++matched) out, mz')
-
-matchCategoryEl :: MultiZipper t Grapheme -> Grapheme -> Maybe ([Grapheme], MultiZipper t Grapheme)
-matchCategoryEl mz g = ([g],) <$> matchGrapheme g mz
+match out prev (Backreference i (FromElements gs)) mz = do
+    e <- maybeToList $
+        (gs !?) =<< matchedCatIxs out !? (i-1)
+    case e of
+        Left  g  -> match out prev (Grapheme g :: Lexeme Expanded a) mz
+        Right ls -> matchMany out prev ls mz
 
 matchGrapheme :: Grapheme -> MultiZipper t Grapheme -> Maybe (MultiZipper t Grapheme)
 matchGrapheme g = matchGraphemeP (==g)
@@ -186,7 +185,7 @@ matchMany :: OneOf a 'Target 'Env
           => MatchOutput
           -> Maybe Grapheme
-          -> [Lexeme a]
+          -> [Lexeme Expanded a]
           -> MultiZipper t Grapheme
           -> [(MatchOutput, MultiZipper t Grapheme)]
 matchMany out _ [] mz = [(out, mz)]
@@ -197,7 +196,7 @@ -- | 'matchMany' without any previous match output.
 matchMany' :: OneOf a 'Target 'Env
           => Maybe Grapheme
-          -> [Lexeme a]
+          -> [Lexeme Expanded a]
           -> MultiZipper t Grapheme
           -> [(MatchOutput, MultiZipper t Grapheme)]
 matchMany' = matchMany (MatchOutput [] [] [])
@@ -243,7 +242,7 @@ -- possible replacements and apply them to the given input.
 mkReplacement
     :: MatchOutput              -- ^ The result of matching against the target
-    -> [Lexeme 'Replacement]    -- ^ The 'Lexeme's specifying the replacement.
+    -> [Lexeme Expanded 'Replacement]    -- ^ The 'Lexeme's specifying the replacement.
     -> MultiZipper t Grapheme
     -> [MultiZipper t Grapheme]
 mkReplacement out = \ls -> fmap (fst . snd) . go startIxs ls . (,Nothing)
@@ -252,7 +251,7 @@ 
     go
         :: ReplacementIndices
-        -> [Lexeme 'Replacement]
+        -> [Lexeme Expanded 'Replacement]
         -> (MultiZipper t Grapheme, Maybe Grapheme)
         -> [(ReplacementIndices, (MultiZipper t Grapheme, Maybe Grapheme))]
     go ixs []     (mz, prev) = [(ixs, (mz, prev))]
@@ -264,19 +263,22 @@ 
     replaceLex
         :: ReplacementIndices
-        -> Lexeme 'Replacement
+        -> Lexeme Expanded 'Replacement
         -> MultiZipper t Grapheme
         -> Maybe Grapheme
         -> [(ReplacementIndices, (MultiZipper t Grapheme, Maybe Grapheme))]
     replaceLex ixs (Grapheme g) mz _prev = [(ixs, (insert g mz, Just g))]
-    replaceLex ixs (Category gs) mz _prev =
+    replaceLex ixs (Category (FromElements gs)) mz prev =
         case advanceCategory ixs numCatsMatched of
             (CategoryNumber ci, ixs') ->
                 let i = matchedCatIxs out !! ci in
                     case gs !? i of
-                        Just g   -> [(ixs', (insert g mz, Just g))]
+                        Just (Left g) -> [(ixs', (insert g mz, Just g))]
+                        Just (Right ls) -> go ixs' ls (mz, prev)
                         Nothing  -> [(ixs', (insert (GMulti "\xfffd") mz, Nothing))]  -- Unicode replacement character
-            (Nondeterministic, ixs') -> gs <&> \g -> (ixs', (insert g mz, Just g))
+            (Nondeterministic, ixs') -> gs >>= \case
+                Left g -> [(ixs', (insert g mz, Just g))]
+                Right ls -> go ixs' ls (mz, prev)
     replaceLex ixs (Optional ls) mz prev =
         let (co, ixs') = advanceOptional ixs in
             case matchedOptionals out !? co of
@@ -304,12 +306,15 @@ -- 'exception' of that rule (if any) applies starting at the current
 -- position of the 'MultiZipper'; if it does, returns the index of the
 -- first element of each matching 'target'.
-exceptionAppliesAtPoint :: [Lexeme 'Target] -> Environment -> MultiZipper RuleTag Grapheme -> [Int]
+exceptionAppliesAtPoint
+    :: [Lexeme Expanded 'Target]
+    -> Environment Expanded
+    -> MultiZipper RuleTag Grapheme -> [Int]
 exceptionAppliesAtPoint target (ex1, ex2) mz = fmap fst $ flip runRuleAp mz $ do
-    _ <- RuleAp $ matchMany' Nothing ex1
+    ex1Out <- RuleAp $ matchMany' Nothing ex1
     pos <- gets curPos
     MatchOutput{matchedGraphemes} <- RuleAp $ matchMany' Nothing target
-    _ <- RuleAp $ matchMany' (listToMaybe matchedGraphemes) ex2
+    _ <- RuleAp $ matchMany ex1Out (listToMaybe matchedGraphemes) ex2
     return pos
 
 -- | Given a target and environment, determine if they rule
@@ -318,12 +323,12 @@ -- t'Grapheme's, and @is@ is a list of indices, one for each
 -- 'Category' lexeme matched.
 matchRuleAtPoint
-    :: [Lexeme 'Target]
-    -> Environment
+    :: [Lexeme Expanded 'Target]
+    -> Environment Expanded
     -> MultiZipper RuleTag Grapheme
     -> [(MatchOutput, MultiZipper RuleTag Grapheme)]
 matchRuleAtPoint target (env1,env2) mz = flip runRuleAp mz $ do
-    _ <- RuleAp $ matchMany' Nothing env1
+    env1Out <- RuleAp $ matchMany' Nothing env1
     -- start of target needs to be INSIDE 'MultiZipper'!
     -- otherwise get weird things like /x/#_ resulting in
     -- #abc#→#xabd#x when it should be #abc#→#xabc#
@@ -333,12 +338,12 @@             modify $ tag TargetStart
             matchResult <- RuleAp $ matchMany' Nothing target
             modify $ tag TargetEnd
-            _ <- RuleAp $ matchMany' (listToMaybe $ matchedGraphemes matchResult) env2
+            _ <- RuleAp $ matchMany env1Out (listToMaybe $ matchedGraphemes matchResult) env2
             return matchResult
 
 -- | Given a 'Rule', determine if the rule matches at the current
 -- point; if so, apply the rule, adding appropriate tags.
-applyOnce :: Rule -> StateT (MultiZipper RuleTag Grapheme) [] Bool
+applyOnce :: Rule Expanded -> StateT (MultiZipper RuleTag Grapheme) [] Bool
 applyOnce r@Rule{target, replacement, exception} =
     modify (tag AppStart) >> go (environment r)
   where
@@ -355,7 +360,7 @@                     if maybe True (`elem` exs) p
                     then return False
                     else do
-                        modifyMay $ modifyBetween (TargetStart, TargetEnd) $ const []
+                        modifyMay $ delete (TargetStart, TargetEnd)
                         modifyMay $ seek TargetStart
                         modifyM $ mkReplacement out replacement
                         return True
@@ -363,7 +368,11 @@ 
 -- | Remove tags and advance the current index to the next t'Grapheme'
 -- after the rule application.
-setupForNextApplication :: Bool -> Rule -> MultiZipper RuleTag Grapheme -> Maybe (MultiZipper RuleTag Grapheme)
+setupForNextApplication
+    :: Bool
+    -> Rule Expanded
+    -> MultiZipper RuleTag Grapheme
+    -> Maybe (MultiZipper RuleTag Grapheme)
 setupForNextApplication success r@Rule{flags=Flags{applyDirection}} =
     fmap untag . case applyDirection of
         RTL -> seek AppStart >=> bwd
@@ -379,7 +388,7 @@ -- | Apply a 'Rule' to a 'MultiZipper'. The application will start at
 -- the beginning of the 'MultiZipper', and will be repeated as many
 -- times as possible. Returns all valid results.
-applyRule :: Rule -> MultiZipper RuleTag Grapheme -> [MultiZipper RuleTag Grapheme]
+applyRule :: Rule Expanded -> MultiZipper RuleTag Grapheme -> [MultiZipper RuleTag Grapheme]
 applyRule r = \mz ->    -- use a lambda so mz isn't shadowed in the where block
     let startingPos = case applyDirection $ flags r of
             LTR -> toBeginning mz
@@ -403,23 +412,26 @@ -- | Check that the 'MultiZipper' contains only graphemes listed in
 -- the given 'CategoriesDecl', replacing all unlisted graphemes with
 -- U+FFFD.
-checkGraphemes :: CategoriesDecl -> MultiZipper RuleTag Grapheme -> MultiZipper RuleTag Grapheme
-checkGraphemes (CategoriesDecl gs) = fmap $ \case
+checkGraphemes :: [Grapheme] -> MultiZipper RuleTag Grapheme -> MultiZipper RuleTag Grapheme
+checkGraphemes gs = fmap $ \case
     GBoundary -> GBoundary
     g -> if g `elem` gs then g else GMulti "\xfffd"
 
 -- | Apply a 'Statement' to a 'MultiZipper'. This is a simple wrapper
 -- around 'applyRule' and 'checkGraphemes'.
-applyStatement :: Statement -> MultiZipper RuleTag Grapheme -> [MultiZipper RuleTag Grapheme]
+applyStatement
+    :: Statement Expanded [Grapheme]
+    -> MultiZipper RuleTag Grapheme
+    -> [MultiZipper RuleTag Grapheme]
 applyStatement (RuleS r) mz = applyRule r mz
-applyStatement (CategoriesDeclS gs) mz = [checkGraphemes gs mz]
+applyStatement (DirectiveS gs) mz = [checkGraphemes gs mz]
 
 -- | Apply a single 'Rule' to a word.
 --
 -- Note: duplicate outputs from this function are removed. To keep
 -- duplicates, use the lower-level internal function 'applyRule'
 -- directly.
-applyRuleStr :: Rule -> PWord -> [PWord]
+applyRuleStr :: Rule Expanded -> PWord -> [PWord]
 -- Note: 'fromJust' is safe here as 'apply' should always succeed
 applyRuleStr r s = nubOrd $ fmap toList $ applyRule r $ fromListStart s
 
@@ -428,7 +440,7 @@ -- Note: as with 'applyRuleStr', duplicate outputs from this function
 -- are removed. To keep duplicates, use the lower-level internal
 -- function 'applyStatement' directly.
-applyStatementStr :: Statement -> PWord -> [PWord]
+applyStatementStr :: Statement Expanded [Grapheme] -> PWord -> [PWord]
 applyStatementStr st =
     addBoundaries
     >>> fromListStart
@@ -517,14 +529,20 @@ -- | Apply a single 'Statement' to a word. Returns a 'LogItem' for
 -- each possible result, or @[]@ if the rule does not apply and the
 -- input is returned unmodified.
-applyStatementWithLog :: Statement -> PWord -> [LogItem Statement]
+applyStatementWithLog
+    :: Statement Expanded [Grapheme]
+    -> PWord
+    -> [LogItem (Statement Expanded [Grapheme])]
 applyStatementWithLog st w = case applyStatementStr st w of
     [w'] -> if w' == w then [] else [ActionApplied st w w']
     r -> ActionApplied st w <$> r
 
 -- | Apply 'SoundChanges' to a word. For each possible result, returns
 -- a 'LogItem' for each 'Statement' which altered the input.
-applyChangesWithLog :: SoundChanges -> PWord -> [[LogItem Statement]]
+applyChangesWithLog
+    :: SoundChanges Expanded [Grapheme]
+    -> PWord
+    -> [[LogItem (Statement Expanded [Grapheme])]]
 applyChangesWithLog [] _ = [[]]
 applyChangesWithLog (st:sts) w =
     case applyStatementWithLog st w of
@@ -534,11 +552,14 @@ 
 -- | Apply 'SoundChanges' to a word, returning an 'PWordLog'
 -- for each possible result.
-applyChangesWithLogs :: SoundChanges -> PWord -> [PWordLog Statement]
+applyChangesWithLogs
+    :: SoundChanges Expanded [Grapheme]
+    -> PWord
+    -> [PWordLog (Statement Expanded [Grapheme])]
 applyChangesWithLogs scs w = mapMaybe toPWordLog $ applyChangesWithLog  scs w
 
 -- | Apply a set of 'SoundChanges' to a word.
-applyChanges :: SoundChanges -> PWord -> [PWord]
+applyChanges :: SoundChanges Expanded [Grapheme] -> PWord -> [PWord]
 applyChanges sts w =
     lastOutput <$> applyChangesWithLog sts w
   where
@@ -549,11 +570,11 @@ -- well as a boolean value indicating whether the word should be
 -- highlighted in a UI due to changes from its initial value. (Note
 -- that this accounts for 'highlightChanges' values.)
-applyChangesWithChanges :: SoundChanges -> PWord -> [(PWord, Bool)]
+applyChangesWithChanges :: SoundChanges Expanded [Grapheme] -> PWord -> [(PWord, Bool)]
 applyChangesWithChanges sts w = applyChangesWithLog sts w <&> \case
     [] -> (w, False)
     logs -> (output $ last logs, hasChanged logs)
   where
     hasChanged = any $ \case
         ActionApplied{action=RuleS rule} -> highlightChanges $ flags rule
-        ActionApplied{action=CategoriesDeclS _} -> True
+        ActionApplied{action=DirectiveS _} -> True

@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE TupleSections #-}
 
 {-| __Warning:__ This module is __internal__, and does __not__ follow
   the Package Versioning Policy. It may be useful for extending
@@ -37,13 +38,16 @@        , query
        , untag
        , untagWhen
-       , modifyBetween
+       , delete
        , extend
        , extend'
        ) where
 
 import Control.Applicative (Alternative((<|>)))
 import Data.Foldable (Foldable(foldl'))
+import Data.Vector ((!?), (!))
+import Data.Vector.Mutable (write)
+import qualified Data.Vector as V
 import qualified Data.Map.Strict as M
 
 -- | A 'MultiZipper' is a list zipper (list+current index), with the
@@ -64,25 +68,25 @@ -- 'MultiZipper' and then move to the next element immediately after
 -- the processed portion, allowing another function to be run to
 -- process the next part of the 'MultiZipper'.)
-data MultiZipper t a = MultiZipper [a] Int (M.Map t Int)
+data MultiZipper t a = MultiZipper (V.Vector a) Int (M.Map t Int)
     deriving (Show, Functor, Foldable, Traversable)
 
 -- | Convert a list to a 'MultiZipper' positioned at the start of that
 -- list.
 fromListStart :: [a] -> MultiZipper t a
-fromListStart as = MultiZipper as 0 M.empty
+fromListStart as = MultiZipper (V.fromList as) 0 M.empty
 
 -- | Convert a list to a 'MultiZipper' at a specific position in the
 -- list. Returns 'Nothing' if the index is invalid.
 fromListPos :: [a] -> Int -> Maybe (MultiZipper t a)
 fromListPos as pos =
-    if invalid pos as
+    if invalid pos (length as)
     then Nothing
-    else Just $ MultiZipper as pos M.empty
+    else Just $ MultiZipper (V.fromList as) pos M.empty
 
 -- | Get the list stored in a 'MultiZipper'.
 toList :: MultiZipper t a -> [a]
-toList (MultiZipper as _ _) = as
+toList (MultiZipper as _ _) = V.toList as
 
 -- | The current position of the 'MultiZipper'.
 curPos :: MultiZipper t a -> Int
@@ -108,10 +112,7 @@ -- list’ (recall this actually means that the 'MultiZipper' is
 -- positioned /after/ the last element of its list).
 value :: MultiZipper t a -> Maybe a
-value (MultiZipper as pos _) =
-    if atNonvalue pos as
-    then Nothing
-    else Just $ as !! pos
+value (MultiZipper as pos _) = as !? pos
 
 -- | @valueN n mz@ returns the next @n@ elements of @mz@ starting from
 -- the current position, as well as returning a new 'MultiZipper'
@@ -122,9 +123,9 @@ valueN :: Int -> MultiZipper t a -> Maybe ([a], MultiZipper t a)
 valueN i (MultiZipper as pos ts) =
     let pos' = pos + i in
-        if invalid pos' as || i < 0
+        if invalid pos' (V.length as) || i < 0
         then Nothing
-        else Just (take i $ drop pos as, MultiZipper as pos' ts)
+        else Just (take i $ drop pos $ V.toList as, MultiZipper as pos' ts)
 
 -- | Given a tag, return its position
 locationOf :: Ord t => t -> MultiZipper t a -> Maybe Int
@@ -136,7 +137,7 @@ 
 seekIx :: Int -> MultiZipper t a -> Maybe (MultiZipper t a)
 seekIx i (MultiZipper as _ ts) =
-    if invalid i as
+    if invalid i (V.length as)
     then Nothing
     else Just (MultiZipper as i ts)
 
@@ -159,9 +160,7 @@ -- over
 consume :: MultiZipper t a -> Maybe (a, MultiZipper t a)
 consume (MultiZipper as pos ts) =
-    if invalid (pos+1) as
-    then Nothing
-    else Just (as!!pos, MultiZipper as (pos+1) ts)
+    fmap (,MultiZipper as (pos+1) ts) (as!?pos)
 
 -- | Move the 'MultiZipper' to be at the specified tag. Returns
 -- 'Nothing' if that tag is not present.
@@ -186,8 +185,11 @@ -- | Insert a new element at point and move forward by one position.
 insert :: a -> MultiZipper t a -> MultiZipper t a
 insert a (MultiZipper as pos ts) =
-    case splitAt pos as of
-        (as1, as2) -> MultiZipper (as1 ++ [a] ++ as2) (pos+1) $ correctIxsFrom pos (+1) ts
+    case V.splitAt pos as of
+        (as1, as2) -> MultiZipper
+            (as1 V.++ V.cons a as2)
+            (pos+1)
+            (correctIxsFrom pos (+1) ts)
 
 -- | Insert multiple elements at point and move after them. A simple
 -- wrapper around 'insert'.
@@ -204,11 +206,9 @@     go _ (-1) = Nothing
     go as pos
       | pos == length as = go as (pos-1)
-      | otherwise = case p (as !! pos) of
+      | otherwise = case p (as ! pos) of
         Nothing -> go as (pos-1)
-        Just a' -> case splitAt pos as of
-            (as1, _:as2) -> Just $ as1 ++ (a':as2)
-            _ -> error "error in zap: impossible case reached"
+        Just a' -> Just $ V.modify (\v -> write v pos a') as
 
 -- | Set a tag at the current position.
 tag :: Ord t => t -> MultiZipper t a -> MultiZipper t a
@@ -217,7 +217,7 @@ -- | Set a tag at a given position if possible, otherwise return 'Nothing'.
 tagAt :: Ord t => t -> Int -> MultiZipper t a -> Maybe (MultiZipper t a)
 tagAt t i (MultiZipper as pos ts) =
-    if invalid i as
+    if invalid i (length as)
     then Nothing
     else Just $ MultiZipper as pos $ M.insert t i ts
 
@@ -229,25 +229,23 @@ untag :: MultiZipper t a -> MultiZipper t a
 untag (MultiZipper as pos _) = MultiZipper as pos M.empty
 
--- | Modify a 'MultiZipper' between the selected tags. Returns
--- 'Nothing' if a nonexistent tag is selected, else returns the
--- modified 'MultiZipper'.
-modifyBetween :: Ord t
-              => (t, t)
-              -- ^ Selected tags. Note that the resulting interval
-              -- will be [inclusive, exclusive).
-              -> ([a] -> [a])
-              -- ^ Function to modify designated interval.
-              -> MultiZipper t a
-              -> Maybe (MultiZipper t a)
-modifyBetween (t1, t2) f mz@(MultiZipper as pos ts) = do
+-- | Delete the portion of a 'MultiZipper' between the selected tags.
+-- Returns 'Nothing' if a nonexistent tag is selected, else returns
+-- the modified 'MultiZipper'.
+delete
+    :: Ord t
+    => (t, t)
+    -- ^ Selected tags. Note that the resulting interval
+    -- will be [inclusive, exclusive).
+    -> MultiZipper t a
+    -> Maybe (MultiZipper t a)
+delete (t1, t2) mz@(MultiZipper as pos ts) = do
     (i1, i2) <- fmap correctOrder $ (,) <$> locationOf t1 mz <*> locationOf t2 mz
-    let (before_t1, after_t1) = splitAt i1 as
-        (cut_part, after_t2) = splitAt (i2-i1) after_t1
-        replacement = f cut_part
-        dEnd = length replacement - length cut_part
-        pos' = pos + dEnd
-    return $ MultiZipper (before_t1 ++ replacement ++ after_t2) pos' (correctIxsFrom i2 (+dEnd) ts)
+    let (before_t1, after_t1) = V.splitAt i1 as
+        (cut_part, after_t2) = V.splitAt (i2-i1) after_t1
+        removed = length cut_part
+        pos' = pos - removed
+    return $ MultiZipper (before_t1 V.++ after_t2) pos' (correctIxsFrom i2 (subtract removed) ts)
   where
     correctOrder (m, n) = if m <= n then (m, n) else (n, m)
 
@@ -261,21 +259,18 @@ extend :: (MultiZipper t a -> b) -> MultiZipper t a -> MultiZipper t b
 extend f (MultiZipper as pos ts) = MultiZipper as' pos ts
   where
-    as' = fmap (\i -> f $ MultiZipper as i ts) [0 .. length as - 1]
+    as' = V.map (\i -> f $ MultiZipper as i ts) $ V.enumFromN 0 (length as)
 
 -- | Like 'extend', but includes the end position of the zipper, thus
 -- increasing the 'MultiZipper' length by one when called.
 extend' :: (MultiZipper t a -> b) -> MultiZipper t a -> MultiZipper t b
 extend' f (MultiZipper as pos ts) = MultiZipper as' pos ts
   where
-    as' = fmap (\i -> f $ MultiZipper as i ts) [0 .. length as]
+    as' = V.map (\i -> f $ MultiZipper as i ts) $ V.enumFromN 0 (length as + 1)
 
 -- Utility functions for checking and modifying indices in lists:
-invalid :: Int -> [a] -> Bool
-invalid pos as = (pos < 0) || (pos > length as)
-
-atNonvalue :: Int -> [a] -> Bool
-atNonvalue pos as = (pos < 0) || (pos >= length as)
+invalid :: Int -> Int -> Bool
+invalid pos len = (pos < 0) || (pos > len)
 
 correctIxsFrom :: Int -> (Int -> Int) -> M.Map t Int -> M.Map t Int
 correctIxsFrom i f = M.map $ \pos -> if pos >= i then f pos else pos

@@ -1,110 +1,163 @@-{-# LANGUAGE DataKinds      #-}
-{-# LANGUAGE DeriveFunctor  #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TupleSections #-}
 
 module Brassica.SoundChange.Category
-       (
-       -- * Category construction
-         Category(..)
-       , CategoryState(..)
-       , categorise
-       -- * Category expansion
-       , Categories
+       ( Categories
        , Brassica.SoundChange.Category.lookup
-       , mapCategories
-       , expand
-       -- * Obtaining values
-       , bake
        , values
+       , ExpandError(..)
+       , expand
+       , expandRule
+       , extend
+       , expandSoundChanges
        ) where
 
-import Data.Coerce
-import Data.List (intersect)
-import Data.Maybe (fromMaybe)
-
-import qualified Data.Map.Strict as M
+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)
 
--- | 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
+import qualified Data.Map.Strict as M
 
--- | 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 (Show, Eq, Ord, Functor)
+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 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 = M.lookup
+type Categories = M.Map String (Expanded 'AnyPart)
 
--- | Map a function over all the values in a set of 'Categories'.
-mapCategories :: Ord b => (a -> b) -> Categories a -> Categories b
-mapCategories f = M.map (fmap f) . M.mapKeys f
+-- | Lookup a category name in 'Categories'.
+lookup :: String -> Categories -> Maybe (Expanded a)
+lookup = (fmap generaliseExpanded .) . M.lookup
 
--- | 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 = UnionOf . fmap Node
+-- | Returns a list of every value mentioned in a set of
+-- 'Categories'
+values :: Categories -> [Either Grapheme [Lexeme Expanded 'AnyPart]]
+values = nubOrd . concatMap elements . M.elems
 
--- | 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 _  Empty           = Empty
-expand cs n@(Node a)      = fromMaybe (coerce n) $ M.lookup a cs
-expand cs (UnionOf u)     = UnionOf $ expand cs <$> u
-expand cs (Intersect a b) = Intersect (expand cs a) (expand cs b)
-expand cs (Subtract a b)  = Subtract  (expand cs a) (expand cs b)
+-- 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 (Show, Generic, NFData)
 
--- | Given an 'Expanded' category, return the list of values which it
+-- | Given a category, return the list of values which it
 -- matches.
-bake :: Eq a => Category 'Expanded a -> [a]
-bake Empty           = []
-bake (Node    a)     = [a]
-bake (UnionOf u)     = concatMap bake u
-bake (Intersect a b) = bake a `intersect` bake b
-bake (Subtract  a b) = bake a `difference` bake b
+expand :: Categories -> CategorySpec a -> Either ExpandError (Expanded a)
+expand cs (MustInline g) = maybe (Left $ NotFound g) Right $ lookup g cs
+expand cs (CategorySpec spec) = FromElements <$> foldM go [] spec
   where
-    difference l m = filter (not . (`elem` m)) l
+    go es (modifier, e) = do
+        new <- case e of
+            Left (GMulti g)
+                | Just (FromElements c) <- lookup g cs
+                -> pure c
+                | otherwise -> pure [Left (GMulti g)]
+            Left GBoundary -> pure [Left GBoundary]
+            Right ls -> pure . Right <$> traverse (expandLexeme cs) ls
+        pure $ case modifier of
+            Union -> es ++ new
+            Intersect -> es `intersect` new
+            Subtract -> es `subtractAll` new
 
--- | 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 = nubOrd . concatMap go . M.elems
+    -- NB. normal (\\) only removes the first matching element
+    subtractAll xs ys = filter (`notElem` ys) xs
+
+expandLexeme :: Categories -> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
+expandLexeme cs (Grapheme (GMulti g))
+    | Just (g', '~') <- unsnoc g
+        = Right $ Grapheme $ GMulti g'
+    | otherwise = Right $
+        case lookup g cs of
+            Just c -> Category c
+            Nothing -> Grapheme (GMulti g)
   where
-    go Empty           = []
-    go (Node    a)     = [a]
-    go (UnionOf u)     = concatMap go u
-    go (Intersect a b) = go a ++ go b
-    go (Subtract  a b) = go a ++ go b
+    -- taken from base-4.19
+    unsnoc :: [a] -> Maybe ([a], a)
+    unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing
+    {-# INLINABLE unsnoc #-}
+
+expandLexeme _  (Grapheme GBoundary) = Right $ Grapheme GBoundary
+expandLexeme cs (Category c) = Category <$> expand cs c
+expandLexeme cs (Optional ls) = Optional <$> traverse (expandLexeme cs) ls
+expandLexeme _  Metathesis = Right Metathesis
+expandLexeme _  Geminate = Right Geminate
+expandLexeme cs (Wildcard l) = Wildcard <$> expandLexeme cs l
+expandLexeme cs (Kleene l) = Kleene <$> expandLexeme cs l
+expandLexeme _  Discard = Right Discard
+expandLexeme cs (Backreference i c) = Backreference i <$> expand cs c
+expandLexeme cs (Multiple c) = Multiple <$> expand cs c
+
+expandRule :: Categories -> Rule CategorySpec -> Either ExpandError (Rule Expanded)
+expandRule cs r = Rule
+    <$> traverse (expandLexeme cs) (target r)
+    <*> traverse (expandLexeme cs) (replacement r)
+    <*> traverse expandEnvironment (environment r)
+    <*> traverse expandEnvironment (exception r)
+    <*> pure (flags r)
+    <*> pure (plaintext r)
+  where
+    expandEnvironment (e1, e2) = (,)
+        <$> traverse (expandLexeme cs) e1
+        <*> traverse (expandLexeme cs) e2
+
+extend :: Categories -> Directive -> Either ExpandError Categories
+extend cs' (Categories overwrite defs) =
+    foldM go (if overwrite then M.empty else cs') defs
+  where
+    go :: Categories -> CategoryDefinition -> Either ExpandError Categories
+    go cs (DefineCategory name val) = flip (M.insert name) cs <$> expand cs val
+    go cs (DefineFeature spec) = do
+        baseValues <- expand cs $ featureBaseValues spec
+        derivedCats <- traverse (traverse $ expand cs) $ featureDerived spec
+
+        baseValues' <- for (elements baseValues) $ \case
+            Left (GMulti g) -> Right g
+            _ -> Left InvalidBaseValue
+        let baseLen = length baseValues'
+            derivedValues = elements . snd <$> derivedCats
+        unless (all ((==baseLen) . length) derivedValues) $
+            Left MismatchedLengths
+
+        let features = zipWith
+               (\base ds -> (base, FromElements $ Left (GMulti base) : ds))
+               baseValues'
+               (transpose derivedValues)
+            newCats =
+                maybe [] (pure . (,baseValues)) (featureBaseName spec)
+                ++ derivedCats
+                ++ features
+        Right $ foldl' (flip $ uncurry M.insert) cs newCats
+
+expandSoundChanges
+    :: SoundChanges CategorySpec Directive
+    -> Either ExpandError (SoundChanges Expanded [Grapheme])
+expandSoundChanges = flip evalStateT M.empty . traverse go
+  where
+    go  :: Statement CategorySpec Directive
+        -> StateT Categories (Either ExpandError) (Statement Expanded [Grapheme])
+    go (RuleS r) = do
+        cs <- get
+        lift $ RuleS <$> expandRule cs r
+    go (DirectiveS d) = do
+        cs <- get
+        cs' <- lift $ extend cs d
+        put cs'
+        pure $ DirectiveS $ mapMaybe left $ values cs'
+
+    left (Left l) = Just l
+    left (Right _) = Nothing

@@ -21,12 +21,13 @@ import Brassica.MDF (MDF, parseMDFWithTokenisation, componentiseMDF, componentiseMDFWordsOnly, duplicateEtymologies)
 import Brassica.SoundChange.Apply
 import Brassica.SoundChange.Apply.Internal (applyChangesWithLog, toPWordLog)
+import Brassica.SoundChange.Category
 import Brassica.SoundChange.Tokenise
 import Brassica.SoundChange.Types
 
 -- | Rule application mode of the SCA.
 data ApplicationMode
-    = ApplyRules HighlightMode OutputMode
+    = ApplyRules HighlightMode OutputMode String
     | ReportRulesApplied
     deriving (Show, Eq)
 
@@ -77,7 +78,7 @@     toEnum _ = undefined
 
 tokenisationModeFor :: ApplicationMode -> TokenisationMode
-tokenisationModeFor (ApplyRules _ MDFOutputWithEtymons) = AddEtymons
+tokenisationModeFor (ApplyRules _ MDFOutputWithEtymons _) = AddEtymons
 tokenisationModeFor _ = Normal
 
 -- | Output of a single application of rules to a wordlist: either a
@@ -87,6 +88,7 @@     = HighlightedWords [Component (a, Bool)]
     | AppliedRulesTable [PWordLog r]
     | ParseError (ParseErrorBundle String Void)
+    | ExpandError ExpandError
     deriving (Show, Generic, NFData)
 
 -- | Kind of input: either a raw wordlist, or an MDF file.
@@ -122,7 +124,7 @@ tokeniseAccordingToInputFormat
     :: InputLexiconFormat
     -> TokenisationMode
-    -> SoundChanges
+    -> SoundChanges Expanded [Grapheme]
     -> String
     -> Either (ParseErrorBundle String Void) (ParseOutput PWord)
 tokeniseAccordingToInputFormat Raw _ cs =
@@ -142,37 +144,40 @@ -- wordlist and a list of sound changes, returns the result of running
 -- the changes in the specified mode.
 parseTokeniseAndApplyRules
-    :: SoundChanges -- ^ changes
+    :: SoundChanges CategorySpec Directive -- ^ changes
     -> String       -- ^ words
     -> InputLexiconFormat
     -> ApplicationMode
     -> Maybe [Component PWord]  -- ^ previous results
-    -> ApplicationOutput PWord Statement
+    -> ApplicationOutput PWord (Statement Expanded [Grapheme])
 parseTokeniseAndApplyRules statements ws intype mode prev =
-    let tmode = tokenisationModeFor mode in
-    case tokeniseAccordingToInputFormat intype tmode statements ws of
-        Left e -> ParseError e
-        Right toks
-          | ws' <- getParsedWords toks
-          -> case mode of
-            ReportRulesApplied ->
-                AppliedRulesTable $ mapMaybe toPWordLog $ concat $
-                    getWords $ componentise WordsOnlyOutput [] $
-                        applyChangesWithLog statements <$> toks
-            ApplyRules DifferentToLastRun mdfout ->
-                let result = concatMap (splitMultipleResults " ") $
-                      componentise mdfout (fmap pure ws') $ applyChanges statements <$> toks
-                in HighlightedWords $
-                    zipWithComponents result (fromMaybe [] prev) [] $ \thisWord prevWord ->
-                        (thisWord, thisWord /= prevWord)
-            ApplyRules DifferentToInput mdfout ->
-                HighlightedWords $ concatMap (splitMultipleResults " ") $
-                    componentise mdfout (fmap (pure . (,False)) ws') $
-                        applyChangesWithChanges statements <$> toks
-            ApplyRules NoHighlight mdfout ->
-                HighlightedWords $ (fmap.fmap) (,False) $ concatMap (splitMultipleResults " ") $
-                    componentise mdfout (fmap pure ws') $
-                        applyChanges statements <$> toks
+    case expandSoundChanges statements of
+        Left e -> ExpandError e
+        Right statements' ->
+            let tmode = tokenisationModeFor mode in
+            case tokeniseAccordingToInputFormat intype tmode statements' ws of
+                Left e -> ParseError e
+                Right toks
+                  | ws' <- getParsedWords toks
+                  -> case mode of
+                    ReportRulesApplied ->
+                        AppliedRulesTable $ mapMaybe toPWordLog $ concat $
+                            getWords $ componentise WordsOnlyOutput [] $
+                                applyChangesWithLog statements' <$> toks
+                    ApplyRules DifferentToLastRun mdfout sep ->
+                        let result = concatMap (splitMultipleResults sep) $
+                              componentise mdfout (fmap pure ws') $ applyChanges statements' <$> toks
+                        in HighlightedWords $
+                            zipWithComponents result (fromMaybe [] prev) [] $ \thisWord prevWord ->
+                                (thisWord, thisWord /= prevWord)
+                    ApplyRules DifferentToInput mdfout sep ->
+                        HighlightedWords $ concatMap (splitMultipleResults sep) $
+                            componentise mdfout (fmap (pure . (,False)) ws') $
+                                applyChangesWithChanges statements' <$> toks
+                    ApplyRules NoHighlight mdfout sep ->
+                        HighlightedWords $ (fmap.fmap) (,False) $ concatMap (splitMultipleResults sep) $
+                            componentise mdfout (fmap pure ws') $
+                                applyChanges statements' <$> toks
   where
     -- Zips two tokenised input strings. Compared to normal 'zipWith'
     -- this has two special properties:

@@ -1,14 +1,12 @@ {-# LANGUAGE DataKinds        #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures   #-}-{-# LANGUAGE LambdaCase       #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards  #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}  module Brassica.SoundChange.Parse     ( parseRule-    , parseRuleWithCategories     , parseSoundChanges       -- ** Re-export     , errorBundlePretty@@ -16,28 +14,22 @@  import Data.Char (isSpace) import Data.Foldable (asum)-import Data.List (transpose) import Data.Maybe (isNothing, isJust, fromJust) import Data.Void (Void)  import Control.Applicative.Permutations-import Control.Monad.State-import qualified Data.Map.Strict as M+import Control.Monad (void, guard)  import Text.Megaparsec hiding (State) import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L  import Brassica.SoundChange.Types-import qualified Brassica.SoundChange.Category as C -newtype Config = Config-    { categories :: C.Categories Grapheme-    }-type Parser = ParsecT Void String (State Config)+type Parser = Parsec Void String  class ParseLexeme (a :: LexemeType) where-    parseLexeme :: Parser (Lexeme a)+    parseLexeme :: Parser (Lexeme CategorySpec a)  -- space consumer which does not match newlines sc :: Parser ()@@ -66,171 +58,140 @@     guard $ n>0     pure n -parseGrapheme :: Parser (Grapheme, Bool)-parseGrapheme = lexeme $ parseBoundary <|> parseMulti-  where-    parseBoundary = (GBoundary,False) <$ char '#'--    parseMulti = (,)-        <$> fmap GMulti (takeWhile1P Nothing (not . ((||) <$> isSpace <*> (`elem` keyChars))))-        <*> (isJust <$> optional (char '~'))+parseGrapheme :: Parser Grapheme+parseGrapheme = lexeme $+    GBoundary <$ char '#'+    <|> GMulti <$> parseGrapheme' -parseGrapheme' :: Parser Grapheme-parseGrapheme' = lexeme $ GMulti <$> takeWhile1P Nothing (not . ((||) <$> isSpace <*> (=='=')))+parseGrapheme' :: Parser String+parseGrapheme' = lexeme $ do+    star <- optional (char '*')+    rest <- takeWhile1P Nothing (not . ((||) <$> isSpace <*> (`elem` keyChars)))+    nocat <- optional (char '~')+    pure .+        maybe id (const ('*':)) star .+        maybe id (const (++"~")) nocat+        $ rest -data CategoryModification-    = Union     Grapheme-    | Intersect Grapheme-    | Subtract  Grapheme+parseExplicitCategory :: ParseLexeme a => Parser (Lexeme CategorySpec a)+parseExplicitCategory = Category <$> parseExplicitCategory' -parseGraphemeOrCategory :: ParseLexeme a => Parser (Lexeme a)-parseGraphemeOrCategory = do-    (g, isntCat) <- parseGrapheme-    if isntCat-        then return $ Grapheme g-        else do-            cats <- gets categories-            return $ case C.lookup g cats of-                Nothing -> Grapheme g-                Just c  -> Category $ C.bake c+parseExplicitCategory' :: ParseLexeme a => Parser (CategorySpec a)+parseExplicitCategory' =+    CategorySpec <$> (symbol "[" *> someTill parseCategoryModification (symbol "]")) -parseCategory :: ParseLexeme a => Parser (Lexeme a)-parseCategory = Category <$> parseCategory'+-- This is unused currently, but convenient to keep around just in case+-- parseCategory :: ParseLexeme a => Parser (Lexeme CategorySpec a)+-- parseCategory = Category <$> parseCategory' -parseCategory' :: Parser [Grapheme]-parseCategory' = do-    mods <- symbol "[" *> someTill parseCategoryModification (symbol "]")-    cats <- gets categories-    return $ C.bake $-        C.expand cats (toCategory mods)+parseCategory' :: ParseLexeme a => Parser (CategorySpec a)+parseCategory' = parseExplicitCategory' <|> MustInline <$> parseGrapheme' -parseCategoryStandalone :: Parser (Grapheme, C.Category 'C.Expanded Grapheme)+parseCategoryStandalone+    :: Parser (String, CategorySpec 'AnyPart) parseCategoryStandalone = do     g <- parseGrapheme'     _ <- symbol "="-    -- Use Target here because it only allows graphemes, not boundaries     mods <- some parseCategoryModification-    cats <- gets categories-    return (g, C.expand cats $ toCategory mods)+    return (g, CategorySpec mods) -categoriesDeclParse :: Parser CategoriesDecl-categoriesDeclParse = do-    overwrite <- isJust <$> optional (symbol "new")-    when overwrite $ put $ Config M.empty-    _ <- symbol "categories" <* scn-    -- parse category declarations, adding to the set of known-    -- categories as each is parsed-    _ <- some $ parseFeature <|> parseCategoryDecl-    _ <- symbol "end" <* scn-    Config catsNew <- get-    return $ CategoriesDecl (C.values catsNew)-  where-    parseFeature = do-        _ <- symbol "feature"-        namePlain <- optional $ try $ parseGrapheme' <* symbol "="-        modsPlain <- some parseCategoryModification-        cats <- gets categories-        let plainCat = C.expand cats $ toCategory modsPlain-            plain = C.bake plainCat-        modifiedCats <- some (symbol "/" *> parseCategoryStandalone) <* scn-        let modified = C.bake . snd <$> modifiedCats-            syns = zipWith (\a b -> (a, C.UnionOf [C.Node a, C.categorise b])) plain $ transpose modified-        modify $ \(Config cs) -> Config $ M.unions-                [ M.fromList syns-                , M.fromList modifiedCats-                , case namePlain of-                      Nothing -> M.empty-                      Just n -> M.singleton n plainCat-                , cs-                ]-    parseCategoryDecl = do-        (k, c) <- try parseCategoryStandalone <* scn-        modify $ \(Config cs) -> Config (M.insert k c cs)+parseFeature :: Parser FeatureSpec+parseFeature = do+    _ <- symbol "feature"+    featureBaseName <- optional $ try $ parseGrapheme' <* symbol "="+    featureBaseValues <- CategorySpec <$> some parseCategoryModification+    featureDerived <- some (symbol "/" *> parseCategoryStandalone) <* scn+    pure FeatureSpec { featureBaseName, featureBaseValues, featureDerived } -parseCategoryModification :: Parser CategoryModification-parseCategoryModification = parsePrefix <*> (fst <$> parseGrapheme)+parseCategoryModification+    :: ParseLexeme a+    => Parser (CategoryModification, Either Grapheme [Lexeme CategorySpec a])+parseCategoryModification = (,)+    <$> parsePrefix+    <*> ( (Right <$> (symbol "{" *> manyTill parseLexeme (symbol "}")))+        <|> (Left <$> parseGrapheme))   where     parsePrefix =         (Intersect <$ char '+')         <|> (Subtract <$ char '-')         <|> pure Union -toCategory :: [CategoryModification] -> C.Category 'C.Unexpanded Grapheme-toCategory = go C.Empty-  where-    go c [] = c-    go c (Union e    :es) = go (C.UnionOf  [c, C.Node e]) es-    go c (Intersect e:es) = go (C.Intersect c (C.Node e)) es-    go c (Subtract e :es) = go (C.Subtract  c (C.Node e)) es+parseDirective :: Parser Directive+parseDirective = do+    overwrite <- isJust <$> optional (symbol "new")+    _ <- symbol "categories" <* scn+    cs <- some $+        DefineFeature <$> parseFeature <|>+        uncurry DefineCategory <$> (try parseCategoryStandalone <* scn)+    _ <- symbol "end" <* scn+    pure $ Categories overwrite cs -parseOptional :: ParseLexeme a => Parser (Lexeme a)+parseOptional :: ParseLexeme a => Parser (Lexeme CategorySpec a) parseOptional = Optional <$> between (symbol "(") (symbol ")") (some parseLexeme) -parseGeminate :: Parser (Lexeme a)+parseGeminate :: Parser (Lexeme CategorySpec a) parseGeminate = Geminate <$ symbol ">" -parseMetathesis :: Parser (Lexeme 'Replacement)+parseMetathesis :: Parser (Lexeme CategorySpec 'Replacement) parseMetathesis = Metathesis <$ symbol "\\" -parseWildcard :: (ParseLexeme a, OneOf a 'Target 'Env) => Parser (Lexeme a)+parseWildcard :: (ParseLexeme a, OneOf a 'Target 'Env) => Parser (Lexeme CategorySpec a) parseWildcard = Wildcard <$> (symbol "^" *> parseLexeme) -parseDiscard :: Parser (Lexeme 'Replacement)+parseDiscard :: Parser (Lexeme CategorySpec 'Replacement) parseDiscard = Discard <$ symbol "~" -parseKleene :: OneOf a 'Target 'Env => Lexeme a -> Parser (Lexeme a)-parseKleene l = (Kleene l <$ symbol "*") <|> pure l+parseKleene :: OneOf a 'Target 'Env => Lexeme CategorySpec a -> Parser (Lexeme CategorySpec a)+parseKleene l =+    try (lexeme $ Kleene l <$ char '*' <* notFollowedBy parseGrapheme')+    <|> pure l -parseMultiple :: Parser (Lexeme 'Replacement)+parseMultiple :: Parser (Lexeme CategorySpec 'Replacement) parseMultiple = Multiple <$> (symbol "@?" *> parseCategory') -parseBackreference-    :: forall a.-       (OneOf a 'Target 'Replacement, ParseLexeme a)-    => Parser (Lexeme a)-parseBackreference =-    Backreference-    <$> (symbol "@" *> nonzero)-    <*> (parseCategory' <|> parseGraphemeCategory)-  where-    parseGraphemeCategory :: Parser [Grapheme]-    parseGraphemeCategory = label "category" $ try $-        (parseGraphemeOrCategory @a) >>= \case-            Category gs -> pure gs-            _ -> empty+parseBackreference :: forall a. ParseLexeme a => Parser (Lexeme CategorySpec a)+parseBackreference = Backreference <$> (symbol "@" *> nonzero) <*> parseCategory'  instance ParseLexeme 'Target where     parseLexeme = asum-        [ parseCategory+        [ parseExplicitCategory         , parseOptional         , parseGeminate         , parseWildcard         , parseBackreference-        , parseGraphemeOrCategory+        , Grapheme <$> parseGrapheme         ] >>= parseKleene  instance ParseLexeme 'Replacement where     parseLexeme = asum-        [ parseCategory+        [ parseExplicitCategory         , parseOptional         , parseMetathesis         , parseDiscard         , parseGeminate         , parseMultiple         , parseBackreference-        , parseGraphemeOrCategory+        , Grapheme <$> parseGrapheme         ]  instance ParseLexeme 'Env where     parseLexeme = asum-        [ parseCategory+        [ parseExplicitCategory         , parseOptional         , parseGeminate         , parseWildcard-        , parseGraphemeOrCategory+        , parseBackreference+        , Grapheme <$> parseGrapheme         ] >>= parseKleene -parseLexemes :: ParseLexeme a => Parser [Lexeme a]+instance ParseLexeme 'AnyPart where+    parseLexeme = asum+        [ parseExplicitCategory+        , parseOptional+        , Grapheme <$> parseGrapheme+        ]++parseLexemes :: ParseLexeme a => Parser [Lexeme CategorySpec a] parseLexemes = many parseLexeme  parseFlags :: Parser Flags@@ -240,7 +201,7 @@     <*> toPermutation (isJust <$> optional (symbol "-1"))     <*> toPermutation (isJust <$> optional (symbol "-?")) -ruleParser :: Parser Rule+ruleParser :: Parser (Rule CategorySpec) ruleParser = do     -- This is an inlined version of 'match' from @megaparsec@;     -- 'match' itself would be tricky to use here, since it would need@@ -275,19 +236,14 @@ -- | Parse a 'String' in Brassica sound change syntax into a -- 'Rule'. Returns 'Left' if the input string is malformed. ----- For details on the syntax, refer to <https://github.com/bradrn/brassica/blob/v0.1.1/Documentation.md#basic-rule-syntax>.-parseRule :: String -> Either (ParseErrorBundle String Void) Rule-parseRule = parseRuleWithCategories M.empty---- | Same as 'parseRule', but also allows passing in some predefined--- categories to substitute.-parseRuleWithCategories :: C.Categories Grapheme -> String -> Either (ParseErrorBundle String Void) Rule-parseRuleWithCategories cs s = flip evalState (Config cs) $ runParserT (scn *> ruleParser <* eof) "" s+-- For details on the syntax, refer to <https://github.com/bradrn/brassica/blob/v0.2.0/Documentation.md#basic-rule-syntax>.+parseRule :: String -> Either (ParseErrorBundle String Void) (Rule CategorySpec)+parseRule = runParser (scn *> ruleParser <* eof) ""  -- | Parse a list of 'SoundChanges'.-parseSoundChanges :: String -> Either (ParseErrorBundle String Void) SoundChanges-parseSoundChanges s = flip evalState (Config M.empty) $ runParserT (scn *> parser <* eof) "" s+parseSoundChanges :: String -> Either (ParseErrorBundle String Void) (SoundChanges CategorySpec Directive)+parseSoundChanges = runParser (scn *> parser <* eof) ""   where     parser = many $-        CategoriesDeclS <$> categoriesDeclParse+        DirectiveS <$> parseDirective         <|> RuleS <$> ruleParser

@@ -154,8 +154,8 @@  -- | Given a list of sound changes, extract the list of multigraphs -- defined in the first categories declaration of the 'SoundChange's.-findFirstCategoriesDecl :: SoundChanges -> [String]-findFirstCategoriesDecl (CategoriesDeclS (CategoriesDecl gs):_) =+findFirstCategoriesDecl :: SoundChanges c [Grapheme] -> [String]+findFirstCategoriesDecl (DirectiveS gs:_) =     mapMaybe         (\case GBoundary -> Nothing; GMulti m -> Just m)         gs@@ -166,5 +166,5 @@ -- like @'withFirstCategoriesDecl' 'tokeniseWords' changes words@ (to -- tokenise using the graphemes from the first categories declaration) -- and so on.-withFirstCategoriesDecl :: ([String] -> t) -> SoundChanges -> t+withFirstCategoriesDecl :: ([String] -> t) -> SoundChanges c [Grapheme] -> t withFirstCategoriesDecl tok ss = tok (findFirstCategoriesDecl ss)

@@ -10,6 +10,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds             #-} {-# LANGUAGE PatternSynonyms       #-}+{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes            #-} {-# LANGUAGE StandaloneDeriving    #-} {-# LANGUAGE TypeFamilies          #-}@@ -28,23 +29,35 @@        , Lexeme(..)        , pattern Boundary        , LexemeType(..)+       , generalise+       -- * Categories+       , mapCategory+       , mapCategoryA+       , Expanded(..)+       , generaliseExpanded        -- * Rules        , Rule(..)        , Environment        , Direction(..)        , Flags(..)        , defFlags-       -- * Categories and statements-       , CategoriesDecl(..)+       -- * Statements        , Statement(..)        , plaintext'        , SoundChanges+       -- * Directives+       , CategoryModification(..)+       , CategorySpec(..)+       , FeatureSpec(..)+       , CategoryDefinition(..)+       , Directive(..)        -- * Utility        , OneOf        ) where  import Control.DeepSeq (NFData(..)) import Data.Kind (Constraint)+import Data.String (IsString(..)) import GHC.Generics (Generic) import GHC.OldList (dropWhileEnd) import GHC.TypeLits@@ -72,6 +85,9 @@     | GBoundary      -- ^ A non-letter element representing a word boundary which sound changes can manipulate     deriving (Eq, Ord, Show, Generic, NFData) +instance IsString Grapheme where+    fromString = GMulti+ -- | A word (or a subsequence of one) can be viewed as a list of -- @Grapheme@s: e.g. Portuguese "filha" becomes -- @["f", "i", "lh", "a"] :: 'PWord'@.@@ -100,43 +116,94 @@         GBoundary -> "#"  -- | The part of a 'Rule' in which a 'Lexeme' may occur: either the--- target, the replacement or the environment.-data LexemeType = Target | Replacement | Env+-- target, the replacement or the environment, or in any of those.+data LexemeType = Target | Replacement | Env | AnyPart  -- | A 'Lexeme' is the smallest part of a sound change. Both matches -- and replacements are made up of 'Lexeme's: the phantom type--- variable specifies where each different variety of 'Lexeme' may--- occur.-data Lexeme (a :: LexemeType) where+-- variable @a@ specifies where each different variety of 'Lexeme' may+-- occur. 'Lexeme's are also parameterised by their category type,+-- which may be 'Expanded' or something else.+data Lexeme category (a :: LexemeType) where     -- | In Brassica sound-change syntax, one or more letters without intervening whitespace,     -- or a word boundary specified as @#@-    Grapheme :: Grapheme -> Lexeme a+    Grapheme :: Grapheme -> Lexeme category a     -- | In Brassica sound-change syntax, delimited by square brackets-    Category :: [Grapheme] -> Lexeme a+    Category :: category a -> Lexeme category a     -- | In Brassica sound-change syntax, delimited by parentheses-    Optional :: [Lexeme a] -> Lexeme a+    Optional :: [Lexeme category a] -> Lexeme category a     -- | In Brassica sound-change syntax, specified as @\@-    Metathesis :: Lexeme 'Replacement+    Metathesis :: Lexeme category 'Replacement     -- | In Brassica sound-change syntax, specified as @>@-    Geminate :: Lexeme a+    Geminate :: Lexeme category a     -- | In Brassica sound-change syntax, specified as @^@ before another 'Lexeme'-    Wildcard :: OneOf a 'Target 'Env => Lexeme a -> Lexeme a+    Wildcard :: OneOf a 'Target 'Env => Lexeme category a -> Lexeme category a     -- | In Brassica sound-change syntax, specified as @*@ after another 'Lexeme'-    Kleene   :: OneOf a 'Target 'Env => Lexeme a -> Lexeme a+    Kleene   :: OneOf a 'Target 'Env => Lexeme category a -> Lexeme category a     -- | In Brassica sound-change syntax, specified as @~@-    Discard  :: Lexeme 'Replacement+    Discard  :: Lexeme category 'Replacement     -- | In Brassica sound-change syntax, specified as \@i before a category-    Backreference :: OneOf a 'Target 'Replacement => Int -> [Grapheme] -> Lexeme a+    Backreference :: Int -> category a -> Lexeme category a     -- | In Brassica sound-change syntax, specified as \@? before a category-    Multiple :: [Grapheme] -> Lexeme 'Replacement+    Multiple :: category 'Replacement -> Lexeme category 'Replacement +mapCategory :: (forall x. c x -> c' x) -> Lexeme c a -> Lexeme c' a+mapCategory _ (Grapheme g) = Grapheme g+mapCategory f (Category c) = Category (f c)+mapCategory f (Optional ls) = Optional (mapCategory f <$> ls)+mapCategory _ Metathesis = Metathesis+mapCategory _ Geminate = Geminate+mapCategory f (Wildcard l) = Wildcard (mapCategory f l)+mapCategory f (Kleene l) = Kleene (mapCategory f l)+mapCategory _ Discard = Discard+mapCategory f (Backreference i c) = Backreference i (f c)+mapCategory f (Multiple c) = Multiple (f c)++mapCategoryA+    :: Applicative t+    => (forall x. c x -> t (c' x))+    -> Lexeme c a+    -> t (Lexeme c' a)+mapCategoryA _ (Grapheme g) = pure $ Grapheme g+mapCategoryA f (Category c) = Category <$> f c+mapCategoryA f (Optional ls) = Optional <$> traverse (mapCategoryA f) ls+mapCategoryA _ Metathesis = pure Metathesis+mapCategoryA _ Geminate = pure Geminate+mapCategoryA f (Wildcard l) = Wildcard <$> mapCategoryA f l+mapCategoryA f (Kleene l) = Kleene <$> mapCategoryA f l+mapCategoryA _ Discard = pure Discard+mapCategoryA f (Backreference i c) = Backreference i <$> f c+mapCategoryA f (Multiple c) = Multiple <$> f c++-- | The type of a category after expansion.+newtype Expanded a = FromElements { elements :: [Either Grapheme [Lexeme Expanded a]] }+    deriving (Eq, Ord, Show, Generic, NFData)++instance Semigroup (Expanded a) where+    (FromElements es) <> (FromElements es') = FromElements (es <> es')++instance Monoid (Expanded a) where+    mempty = FromElements []++generalise :: (c 'AnyPart -> c a) -> Lexeme c 'AnyPart -> Lexeme c a+generalise _ (Grapheme g) = Grapheme g+generalise f (Category es) = Category $ f es+generalise f (Optional ls) = Optional $ generalise f <$> ls+generalise _ Geminate = Geminate+generalise f (Backreference i es) = Backreference i $ f es++generaliseExpanded :: Expanded 'AnyPart -> Expanded a+generaliseExpanded = FromElements . (fmap.fmap.fmap) (generalise generaliseExpanded) . elements+ -- | A 'Lexeme' matching a single word boundary, specified as @#@ in Brassica syntax.-pattern Boundary :: Lexeme a+pattern Boundary :: Lexeme c a pattern Boundary = Grapheme GBoundary -deriving instance Show (Lexeme a)+deriving instance (forall x. Show (c x)) => Show (Lexeme c a)+deriving instance (forall x. Eq (c x)) => Eq (Lexeme c a)+deriving instance (forall x. Ord (c x)) => Ord (Lexeme c a) -instance NFData (Lexeme a) where+instance (forall x. NFData (c x)) => NFData (Lexeme c a) where     rnf (Grapheme g) = rnf g     rnf (Category cs) = rnf cs     rnf (Optional ls) = rnf ls@@ -152,7 +219,7 @@ -- corresponding to a ‘/ before _ after’ component of a sound change. -- -- Note that an empty environment is just @([], [])@.-type Environment = ([Lexeme 'Env], [Lexeme 'Env])+type Environment c = ([Lexeme c 'Env], [Lexeme c 'Env])  -- | Specifies application direction of rule — either left-to-right or right-to-left. data Direction = LTR | RTL@@ -192,33 +259,62 @@ -- | A single sound change rule: in Brassica sound-change syntax with all elements specified, -- @-flags target / replacement \/ environment1 | environment2 | … \/ exception@. -- (And usually the 'plaintext' of the rule will contain a 'String' resembling that pattern.)-data Rule = Rule-  { target      :: [Lexeme 'Target]-  , replacement :: [Lexeme 'Replacement]-  , environment :: [Environment]-  , exception   :: Maybe Environment+data Rule c = Rule+  { target      :: [Lexeme c 'Target]+  , replacement :: [Lexeme c 'Replacement]+  , environment :: [Environment c]+  , exception   :: Maybe (Environment c)   , flags       :: Flags   , plaintext   :: String-  } deriving (Show, Generic, NFData)+  } deriving (Generic) --- | Corresponds to a category declaration in a set of sound--- changes. Category declarations are mostly desugared away by the--- parser, but for rule application we still need to be able to filter--- out all unknown t'Grapheme's; thus, a 'CategoriesDecl' lists the--- t'Grapheme's which are available at a given point.-newtype CategoriesDecl = CategoriesDecl { graphemes :: [Grapheme] }-  deriving (Show, Generic, NFData)+deriving instance (forall a. Show (c a)) => Show (Rule c)+deriving instance (forall a. NFData (c a)) => NFData (Rule c)  -- | A 'Statement' can be either a single sound change rule, or a--- category declaration.-data Statement = RuleS Rule | CategoriesDeclS CategoriesDecl-    deriving (Show, Generic, NFData)+-- directive (e.g. category definition).+data Statement c decl = RuleS (Rule c) | DirectiveS decl+    deriving (Generic) +deriving instance (forall a. Show (c a), Show decl) => Show (Statement c decl)+deriving instance (forall a. NFData (c a), NFData decl) => NFData (Statement c decl)+ -- | A simple wrapper around 'plaintext' for 'Statement's. Returns--- @"categories … end"@ for all 'CategoriesDecl' inputs.-plaintext' :: Statement -> String+-- @"<directive>"@ for all 'DirectiveS' inputs.+plaintext' :: Statement c decl -> String plaintext' (RuleS r) = plaintext r-plaintext' (CategoriesDeclS _) = "categories … end"+plaintext' (DirectiveS _) = "<directive>"  -- | A set of 'SoundChanges' is simply a list of 'Statement's.-type SoundChanges = [Statement]+type SoundChanges c decl = [Statement c decl]++-- | The individual operations used to construct a category in+-- Brassica sound-change syntax.+data CategoryModification = Union | Intersect | Subtract+    deriving (Show, Eq, Ord, Generic, NFData)++-- | The specification of a category in Brassica sound-change syntax.+data CategorySpec a+    = CategorySpec [(CategoryModification, Either Grapheme [Lexeme CategorySpec a])]+    | MustInline String  -- ^ A single grapheme assumed to have been specified earlier as a category+    deriving (Show, Eq, Ord, Generic, NFData)++-- | The specification of a suprasegmental feature in Brassica+-- sound-change syntax.+data FeatureSpec = FeatureSpec+    { featureBaseName :: Maybe String+    , featureBaseValues :: CategorySpec 'AnyPart+    , featureDerived :: [(String, CategorySpec 'AnyPart)]+    }+    deriving (Show, Eq, Ord, Generic, NFData)++-- | A definition of a new category, either directly or via features.+data CategoryDefinition+    = DefineCategory String (CategorySpec 'AnyPart)+    | DefineFeature FeatureSpec+    deriving (Show, Eq, Ord, Generic, NFData)++-- | A directive used in Brassica sound-change syntax: currently only+-- @categories … end@ or @new categories … end@+data Directive = Categories Bool [CategoryDefinition]+    deriving (Show, Eq, Ord, Generic, NFData)

@@ -14,9 +14,10 @@ import qualified Data.Text as T  import Brassica.SoundChange (applyChanges, splitMultipleResults, applyChangesWithLogs, reportAsText)+import Brassica.SoundChange.Category (expandSoundChanges) import Brassica.SoundChange.Parse (parseSoundChanges, errorBundlePretty) import Brassica.SoundChange.Tokenise (tokeniseWords, detokeniseWords, withFirstCategoriesDecl, Component, getWords)-import Brassica.SoundChange.Types (SoundChanges, PWord, plaintext')+import Brassica.SoundChange.Types (SoundChanges, PWord, plaintext', Expanded, Grapheme)  main :: IO () main = defaultMain $ testGroup "brassica-tests"@@ -29,7 +30,7 @@     showLogs logs = unlines $ fmap (reportAsText plaintext') $ concat $ getWords logs  proto21eTest-    :: (SoundChanges -> PWord -> [a])+    :: (SoundChanges Expanded [Grapheme] -> PWord -> [a])     -> ([Component [a]] -> String)     -> String     -> FilePath@@ -41,10 +42,15 @@     in goldenVsFile testName goldenName' outName' $         withFile outName' WriteMode $ \outFile -> fmap (either id id) . runExceptT $ do             soundChangesData <- B8.toString <$> liftIO (B.readFile "test/proto21e.bsc")-            soundChanges <- catchEither (parseSoundChanges soundChangesData) $ \err -> do+            soundChanges' <- catchEither (parseSoundChanges soundChangesData) $ \err -> do                 liftIO $ putStrLn $                     "Cannot parse the SCA file because:\n" ++                     errorBundlePretty err+                throwE ()+            soundChanges <- catchEither (expandSoundChanges soundChanges') $ \err -> do+                liftIO $ putStrLn $+                    "Cannot expand the SCA file because:\n" +++                    show err                 throwE ()             let output pre = B8.fromString . (++"\n") . (pre ++)                 prettyError  = output "SCA Error:" . errorBundlePretty