brassica (empty) → 0.0.3

raw patch · 23 files changed

+2682/−0 lines, 23 filesdep +basedep +brassicadep +bytestringsetup-changed

Dependencies added: base, brassica, bytestring, conduit, containers, criterion, deepseq, file-embed, megaparsec, mtl, optparse-applicative, parser-combinators, split, tasty, tasty-golden, text, transformers, utf8-string

Files

• ChangeLog.md +1/−0
• LICENSE +30/−0
• README.md +25/−0
• Setup.hs +2/−0
• bench/Changes.hs +80/−0
• bench/Paradigm.hs +86/−0
• brassica.cabal +111/−0
• cli/Main.hs +103/−0
• src/Brassica/MDF.hs +220/−0
• src/Brassica/Paradigm.hs +24/−0
• src/Brassica/Paradigm/Apply.hs +81/−0
• src/Brassica/Paradigm/Parse.hs +91/−0
• src/Brassica/Paradigm/Types.hs +72/−0
• src/Brassica/SoundChange.hs +7/−0
• src/Brassica/SoundChange/Apply.hs +15/−0
• src/Brassica/SoundChange/Apply/Internal.hs +471/−0
• src/Brassica/SoundChange/Apply/Internal/MultiZipper.hs +281/−0
• src/Brassica/SoundChange/Category.hs +110/−0
• src/Brassica/SoundChange/Frontend/Internal.hs +174/−0
• src/Brassica/SoundChange/Parse.hs +268/−0
• src/Brassica/SoundChange/Tokenise.hs +162/−0
• src/Brassica/SoundChange/Types.hs +204/−0
• test/Spec.hs +64/−0

@@ -0,0 +1,1 @@+# Changelog for brassica

@@ -0,0 +1,30 @@+Copyright Brad Neimann (c) 2020-2022++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Brad Neimann nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,25 @@+# Brassica++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+- 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, and in many more ways+- Live preview and control over output highlighting allows fast iteration through rules+- 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+- Rich syntax for specifying phonetic rules, including wildcards, optional elements and more++And many more!++See the [documentation](./Documentation.md) for details on Brassica usage.++Download Brassica from the [releases page](https://github.com/bradrn/brassica/releases/latest).+Alternately, try it online at http://bradrn.com/brassica.+As of the time of writing prebuilt binaries exist only for Windows.+Instructions for building from source are available at [`BUILDING.md`](./BUILDING.md).++![Image of Brassica with some example sound changes](https://raw.githubusercontent.com/bradrn/brassica/v0.0.3/gui-interface-example.png)

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,80 @@+{-# LANGUAGE TemplateHaskell #-}
+
+module Main where
+
+import Criterion.Main (defaultMain, bench, nf, bgroup)
+import Data.FileEmbed (embedFile)
+import Data.Text (unpack)
+import Data.Text.Encoding (decodeUtf8)
+
+import Brassica.SoundChange
+
+main :: IO ()
+main = defaultMain
+    [ bgroup "single"
+      [ bgroup "basic"
+        [ bgroup "0" $ benchChanges basic ["b"]
+        , bgroup "1" $ benchChanges basic ["a"]
+        , bgroup "2" $ benchChanges basic ["a","b"]
+        , bgroup "4" $ benchChanges basic ["a","b","x","a"]
+        , bgroup "8" $ benchChanges basic ["a","b","x","a","x","b","a","b"]
+        , bgroup "8a" $ benchChanges basic ["b","b","x","b","x","b","b","b"]
+        ]
+      , bgroup "complex"
+        [ bgroup "1" $ benchChanges complex ["t"]
+        , bgroup "2" $ benchChanges complex ["ti"]
+        , bgroup "4" $ benchChanges complex ["a", "t", "i", "e"]
+        , bgroup "8" $ benchChanges complex ["n", "y", "i", "u", "t", "i", "e", "a"]
+        , bgroup "16" $ benchChanges complex ["a", "n", "y", "i", "u", "t", "i", "e", "d", "y", "i", "e", "t", "a", "d", "a"]
+        , bgroup "16a" $ benchChanges complex ["u", "n", "y", "i", "u", "t", "i", "e", "d", "y", "a", "e", "t", "a", "d", "a"]
+        ]
+      ]
+    , bgroup "many"
+      [ 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
+      ]
+    ]
+  where
+    basic = Rule
+        { target = [Grapheme "a"]
+        , replacement = [Grapheme "b"]
+        , environment = ([], [])
+        , exception = Nothing
+        , flags = defFlags
+        , plaintext = "a/b"
+        }
+
+    complex = Rule
+        { target =
+            [ Category [GraphemeEl "t", GraphemeEl "d", GraphemeEl "n"]
+            , Optional [Grapheme "y"]
+            , Category [GraphemeEl "i", GraphemeEl "e"]
+            ]
+        , replacement =
+            [ Category [GraphemeEl "c", GraphemeEl "j", GraphemeEl "nh"]
+            , Optional [Geminate]
+            ]
+        , environment =
+            ( [Category [BoundaryEl, GraphemeEl "a", GraphemeEl "e", GraphemeEl "i"]]
+            , [Category [GraphemeEl "a", GraphemeEl "e", GraphemeEl "i", GraphemeEl "o", GraphemeEl "u"]]
+            )
+        , exception = Nothing
+        , flags = defFlags
+        , plaintext = "[t d n] (y) [i e] / [č j ñ] (>) / [# a e i] _ [a e i o u]"
+        }
+
+    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
+        [ bench "nolog" $ nf (applyChanges [RuleS cs]) l
+        ]
+
+manyChanges :: String
+manyChanges = unpack $ decodeUtf8 $(embedFile "bench/sample-changes.bsc")
+
+manyWords :: String
+manyWords = unpack $ decodeUtf8 $(embedFile "bench/sample-words.lex")

@@ -0,0 +1,86 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Criterion.Main (bench, nf, defaultMain)++import Brassica.Paradigm++main :: IO ()+main = defaultMain+    [ bench "small" $ nf (build smallParadigm) smallWords+    , bench "mid"   $ nf (build smallParadigm) largeWords+    , bench "mid2"  $ nf (build largeParadigm) smallWords+    , bench "large" $ nf (build largeParadigm) largeWords+    ]+  where+    build = concatMap . applyParadigm++smallParadigm :: Paradigm+smallParadigm =+    [ NewFeature $ Feature Always Nothing+      [ Concrete [Prefix 1 "a"]+      , Concrete [Prefix 1 "b"]+      , Concrete [Prefix 1 "c"]+      ]+    , NewFeature $ Feature Always Nothing+      [ Concrete [Suffix 1 "x"]+      , Concrete [Suffix 1 "y"]+      , Concrete []+      ]+    , NewFeature $ Feature Always Nothing+      [ Concrete [Prefix 2 "n", Suffix 2 "v"]+      , Concrete [Prefix 2 "n", Suffix 2 "w"]+      , Concrete [Prefix 2 "m", Suffix 2 "w"]+      ]+    ]++largeParadigm :: Paradigm+largeParadigm =+    [ NewFeature $ Feature Always Nothing+      [ Concrete [Prefix 1 "a"]+      , Concrete [Prefix 1 "b"]+      , Concrete [Prefix 1 "c"]+      , Concrete [Prefix 1 "d"]+      , Concrete [Prefix 1 "e"]+      , Concrete [Prefix 1 "f"]+      , Concrete [Prefix 1 "g"]+      , Concrete [Prefix 1 "h"]+      , Concrete [Prefix 1 "i"]+      ]+    , NewFeature $ Feature Always Nothing+      [ Abstract "abstract1a"+      , Abstract "abstract1b"+      ]+    , NewFeature $ Feature Always Nothing+      [ Concrete [Prefix 2 "n", Suffix 2 "v"]+      , Concrete [Prefix 2 "n", Suffix 2 "w"]+      , Concrete [Prefix 2 "m", Suffix 2 "v"]+      , Concrete [Prefix 2 "m", Suffix 2 "w"]+      ]+    , NewFeature $ Feature Always Nothing+      [ Abstract "abstract2a"+      , Abstract "abstract2b"+      ]+    , NewFeature $ Feature Always Nothing+      [ Concrete [Suffix 4 "a"]+      , Concrete [Suffix 4 "b"]+      , Concrete [Suffix 4 "c"]+      , Concrete [Suffix 4 "d"]+      , Concrete [Suffix 4 "e"]+      , Concrete [Suffix 4 "f"]+      , Concrete [Suffix 4 "g"]+      , Concrete [Suffix 4 "h"]+      , Concrete [Suffix 4 "i"]+      ]+    , NewMapping ["abstract1a","abstract2a"] [Suffix 3 "q"]+    , NewMapping ["abstract1a","abstract2b"] [Suffix 3 "w"]+    , NewMapping ["abstract1b","abstract2a"] [Suffix 3 "e"]+    , NewMapping ["abstract1b","abstract2b"] [Suffix 3 "r"]+    ]++smallWords :: [String]+smallWords = ["word", "wurd", "ward", "werd", "wird"]++largeWords :: [String]+largeWords = ["word", "wurd", "ward", "werd", "wird", "xyz", "yzx", "zxy", "zyx", "yxz", "xzy", "qw", "we", "er", "rt", "ty"]

@@ -0,0 +1,111 @@+cabal-version:      2.0+name:               brassica+version:            0.0.3+synopsis:           Featureful sound change applier+description:+  The Brassica library for the simulation of sound changes in historical linguistics and language construction.+  For further details, please refer to the README below or at <https://github.com/bradrn/brassica#readme>.++category:           Linguistics+homepage:           https://github.com/bradrn/brassica#readme+bug-reports:        https://github.com/bradrn/brassica/issues+author:             Brad Neimann+maintainer:         Brad Neimann+copyright:          2020-2022 Brad Neimann+license:            BSD3+license-file:       LICENSE+build-type:         Simple+extra-source-files:+  README.md+  ChangeLog.md++source-repository head+  type:     git+  location: https://github.com/bradrn/brassica++library+  exposed-modules: Brassica.SoundChange+                 , Brassica.SoundChange.Apply+                 , Brassica.SoundChange.Apply.Internal+                 , Brassica.SoundChange.Apply.Internal.MultiZipper+                 , Brassica.SoundChange.Category+                 , Brassica.SoundChange.Frontend.Internal+                 , Brassica.SoundChange.Parse+                 , Brassica.SoundChange.Tokenise+                 , Brassica.SoundChange.Types+                 , Brassica.MDF+                 , Brassica.Paradigm+  other-modules:   Brassica.Paradigm.Apply+                 , Brassica.Paradigm.Parse+                 , Brassica.Paradigm.Types+  hs-source-dirs:   src+  ghc-options:      -Wall+  build-depends:+                   base >=4.7 && <5+                 , containers >=0.6 && <0.7+                 , deepseq >=1.4 && <1.5+                 , megaparsec >=8.0 && <8.1+                 , mtl >=2.2 && <2.3+                 , parser-combinators >=1.2 && <1.3+                 , split >=0.2 && <0.3+                 , transformers >=0.5 && <0.6++  default-language: Haskell2010++executable brassica+  main-is:          Main.hs+  hs-source-dirs:   cli+  ghc-options:      -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:+                    base >=4.7 && <5+                  , brassica+                  , bytestring ^>=0.10+                  , conduit ^>=1.3+                  , optparse-applicative ^>=0.17+                  , text ^>=1.2++  default-language: Haskell2010++benchmark changes-bench+  type:             exitcode-stdio-1.0+  main-is:          Changes.hs+  hs-source-dirs:   bench+  ghc-options:      -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:+                    base >=4.7 && <5+                  , brassica+                  , criterion >=1.5 && <1.6+                  , file-embed >=0.0.15 && <0.0.16+                  , text >=1.2 && <1.3++  default-language: Haskell2010++benchmark paradigm-bench+  type:             exitcode-stdio-1.0+  main-is:          Paradigm.hs+  hs-source-dirs:   bench+  ghc-options:      -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:+                    base >=4.7 && <5+                  , brassica+                  , criterion >=1.5 && <1.6++  default-language: Haskell2010++test-suite changes-test+  type:             exitcode-stdio-1.0+  main-is:          Spec.hs+  hs-source-dirs:   test+  ghc-options:      -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:+                    base >=4.7 && <5+                  , brassica+                  , tasty ^>=1.4+                  , tasty-golden ^>=2.3+                  , bytestring ^>=0.10+                  , text ^>=1.2+                  , transformers ^>=0.5+                  , conduit ^>=1.3+                  , utf8-string ^>=1.0++  default-language: Haskell2010

@@ -0,0 +1,103 @@+{-# LANGUAGE LambdaCase   #-}+{-# LANGUAGE RecordWildCards #-}++module Main where++import Control.Exception (Exception)++import Conduit+import qualified Data.ByteString as B+import Data.Text (pack, unpack, Text)+import Data.Text.Encoding (decodeUtf8)+import Options.Applicative++import Brassica.SoundChange+import Brassica.SoundChange.Frontend.Internal+++main :: IO ()+main = do+    Options{..} <- execParser opts+    changesText <- unpack . decodeUtf8 <$> B.readFile rulesFile++    case parseSoundChanges changesText of+        Left err ->+            putStrLn $ errorBundlePretty err+        Right rules ->+            withSourceFileIf inWordsFile $ \inC ->+            withSinkFileIf outWordsFile $ \outC ->+            runConduit $+                inC+                .| processWords (incrFor wordsFormat) rules wordsFormat tokMode outMode+                .| outC++  where+    opts = info (args <**> helper) fullDesc++    args = Options+        <$> strArgument+            (metavar "RULES" <> help "File containing sound changes")+        <*> flag Raw MDF+            (long "mdf" <> help "Parse input words in MDF format")+        <*> flag Normal AddEtymons+            (long "etymons" <> help "With --mdf, add etymologies to output")+        <*> (flag' ReportRulesApplied+                (long "report" <> help "Report rules applied rather than outputting words")+            <|>+            flag (ApplyRules NoHighlight MDFOutput) (ApplyRules NoHighlight WordsOnlyOutput)+                (long "wordlist" <> help "With --mdf, output only a list of the derived words"))+        <*> optional (strOption+            (long "in" <> short 'i' <> help "File containing input words (if not specified will read from stdin)"))+        <*> optional (strOption+            (long "out" <> short 'o' <> help "File to which output words should be written (if not specified will write to stdout)"))++    incrFor Raw = True+    incrFor MDF = False++    withSourceFileIf :: Maybe FilePath -> (ConduitM i B.ByteString IO () -> IO a) -> IO a+    withSourceFileIf = maybe ($ stdinC) withSourceFile++    withSinkFileIf :: Maybe FilePath -> (ConduitM B.ByteString o IO () -> IO a) -> IO a+    withSinkFileIf = maybe ($ stdoutC) withSinkFile++data Options = Options+    { rulesFile :: String+    , wordsFormat :: InputLexiconFormat+    , tokMode :: TokenisationMode+    , outMode :: ApplicationMode+    , inWordsFile :: Maybe String+    , outWordsFile :: Maybe String+    } deriving (Show)++processWords+    :: (MonadIO m, MonadThrow m)+    => Bool  -- split into lines?+    -> SoundChanges+    -> InputLexiconFormat+    -> TokenisationMode+    -> ApplicationMode+    -> ConduitT B.ByteString B.ByteString m ()+processWords incr rules wordsFormat tokMode outMode =+    decodeUtf8C+    .| (if incr then linesUnboundedC else mapC id)+    .| mapC (processApplicationOutput . evolve . unpack)+    .| throwOnLeft+    .| (if incr then unlinesC else mapC id)+    .| encodeUtf8C+  where+    evolve ws = parseTokeniseAndApplyRules rules ws wordsFormat tokMode outMode Nothing++    throwOnLeft :: (MonadThrow m, Exception e) => ConduitT (Either e r) r m ()+    throwOnLeft = awaitForever $ \case+        Left e -> throwM e+        Right r -> yield r++    processApplicationOutput :: ApplicationOutput PWord Statement -> 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++newtype ParseException = ParseException String+    deriving Show++instance Exception ParseException

@@ -0,0 +1,220 @@+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ViewPatterns #-}
+
+{-| This module contains types and functions for working with the MDF
+  dictionary format, used by programs such as [SIL Toolbox](https://software.sil.org/toolbox/).
+  For more on the MDF format, refer to e.g.
+  [Coward & Grimes (2000), /Making Dictionaries: A guide to lexicography and the Multi-Dictionary Formatter/](http://downloads.sil.org/legacy/shoebox/MDF_2000.pdf).
+-}
+module Brassica.MDF
+       (
+       -- * MDF files
+         MDF(..)
+       , MDFLanguage(..)
+       , fieldLangs
+       -- * Parsing
+       , parseMDFRaw
+       , parseMDFWithTokenisation
+       -- ** Re-export
+       , errorBundlePretty
+       -- * Conversion
+       , componentiseMDF
+       , componentiseMDFWordsOnly
+       , duplicateEtymologies
+       ) where
+
+import Control.Category ((>>>))
+import Data.Char (isSpace)
+import Data.Void (Void)
+
+import qualified Data.Map as M
+import Text.Megaparsec
+import Text.Megaparsec.Char
+
+import Brassica.SoundChange.Tokenise
+import Brassica.SoundChange.Types (Grapheme, PWord)
+import Data.Maybe (fromMaybe)
+
+-- | An MDF (Multi-Dictionary Formatter) file, represented as a list
+-- of (field marker, whitespace, field value) tuples. The field marker
+-- is represented excluding its initial slash; whitespace after the
+-- field marker is also stored, allowing the original MDF file to be
+-- precisely recovered. Field values should includes all whitespace to
+-- the next marker. All field values are stored as 'String's, with the
+-- exception of 'Vernacular' fields, which have type @v@.
+--
+-- For instance, the following MDF file:
+--
+-- > \lx kapa
+-- > \ps n
+-- > \ge parent
+-- > \se sakapa
+-- > \ge father
+--
+-- Could be stored as:
+--
+-- > MDF [ ("lx", " ", Right "kapa\n")
+-- >     , ("ps", " ", Left "n\n")
+-- >     , ("ge", " ", Left "parent\n")
+-- >     , ("se", " ", Right "sakapa\n")
+-- >     , ("ge", " ", Left "father")
+-- >     ]
+newtype MDF v = MDF { unMDF :: [(String, String, Either String v)] }
+    deriving (Show, Functor)
+
+type Parser = Parsec Void String
+
+sc :: Parser String
+sc = fmap (fromMaybe "") $ optional $ takeWhile1P (Just "white space") isSpace
+
+parseToSlash :: Parser String
+parseToSlash = takeWhileP (Just "field value") (/= '\\')
+
+entry :: Parser v -> Parser (String, String, Either String v)
+entry pv = do
+    _ <- char '\\'
+    marker <- takeWhile1P (Just "field name") (not . isSpace)
+    s <- sc
+    value <- case M.lookup marker fieldLangs of
+        Just Vernacular -> Right <$> pv
+        _ -> Left <$> parseToSlash
+    pure (marker, s, value)
+
+-- | Parse an MDF file to an 'MDF', storing the 'Vernacular' fields as 'String's.
+parseMDFRaw :: String -> Either (ParseErrorBundle String Void) (MDF String)
+parseMDFRaw = runParser (fmap MDF $ sc *> many (entry parseToSlash) <* eof) ""
+
+-- | Parse an MDF file to an 'MDF', parsing the 'Vernacular' fields
+-- into 'Component's in the process.
+parseMDFWithTokenisation
+    :: [Grapheme]
+    -> String
+    -> Either (ParseErrorBundle String Void) (MDF [Component PWord])
+parseMDFWithTokenisation (sortByDescendingLength -> gs) =
+    runParser (fmap MDF $ sc *> p <* eof) ""
+  where
+    p = many $ entry $ componentsParser $ wordParser "\\" gs
+
+-- | Convert an 'MDF' to a list of 'Component's representing the same
+-- textual content. Vernacular field values are left as is; everything
+-- else is treated as a 'Separator', so that it is not disturbed by
+-- operations such as rule application or rendering to text.
+componentiseMDF :: MDF [Component a] -> [Component a]
+componentiseMDF = unMDF >>> concatMap \case
+    (m, s, Left v) -> [Separator ('\\':m ++ s ++ v)]
+    (m, s, Right v) -> Separator ('\\':m ++ s) : v
+
+-- | As with 'componentiseMDF', but the resulting 'Component's contain
+-- the contents of 'Vernacular' fields only; all else is
+-- discarded. The first parameter specifies the 'Separator' to insert
+-- after each vernacular field.
+componentiseMDFWordsOnly :: MDF [Component a] -> [Component a]
+componentiseMDFWordsOnly = unMDF >>> concatMap \case
+    (_, _, Right v) -> v
+    _ -> []
+
+-- | Add etymological fields to an 'MDF' by duplicating the values in
+-- @\lx@, @\se@ and @\ge@ fields. e.g.:
+--
+-- > \lx kapa
+-- > \ps n
+-- > \ge parent
+-- > \se sakapa
+-- > \ge father
+--
+-- Would become:
+--
+-- > \lx kapa
+-- > \ps n
+-- > \ge parent
+-- > \et kapa
+-- > \eg parent
+-- > \se sakapa
+-- > \ge father
+-- > \et sakapa
+-- > \eg father
+--
+-- This can be helpful when applying sound changes to an MDF file: the
+-- vernacular words can be copied as etymologies, and then the sound
+-- changes can be applied leaving the etymologies as is.
+duplicateEtymologies
+    :: (v -> String)
+    -- ^ Function to convert from vernacular field values to
+    -- strings. Can also be used to preprocess the value of the
+    -- resulting @\et@ fields, e.g. by prepending @*@ or similar.
+    -> MDF v -> MDF v
+duplicateEtymologies typeset = MDF . go Nothing Nothing . unMDF
+  where
+    mkEt word gloss = word' gloss'
+      where
+        word' = case word of
+            Just et -> (("et", " ", Left $ typeset et) :)
+            Nothing -> id
+        gloss' = case gloss of
+            Just eg -> [("eg", " ", Left eg)]
+            Nothing -> []
+
+    go word gloss [] = mkEt word gloss
+    go word _ (f@("ge", _, Left gloss'):fs)                  -- store gloss field for future etymology
+        = f : go word (Just gloss') fs
+    go word gloss (f@(m, _, Right word'):fs)                 -- add etymology & store word if word or subentry field reached
+        | m == "lx" || m == "se"
+        = mkEt word gloss ++ f : go (Just word') Nothing fs
+    go word gloss (f@("dt", _, _):fs)                        -- add etymology if date (usually final field in entry) reached
+        = mkEt word gloss ++ f : go Nothing Nothing fs
+    go word gloss (f:fs) = f : go word gloss fs
+    
+
+-- | The designated language of an MDF field.
+data MDFLanguage = English | National | Regional | Vernacular | Other
+    deriving (Eq, Show)
+
+-- | A 'M.Map' from the most common field markers to the language of
+-- their values.
+--
+-- (Note: This is currently hardcoded in the source code, based on the
+-- values in the MDF definitions from SIL Toolbox. There’s probably a
+-- more principled way of defining this, but hardcoding should suffice
+-- for now.)
+fieldLangs :: M.Map String MDFLanguage
+fieldLangs = M.fromList
+    [ ("1d" , Vernacular) , ("1e" , Vernacular) , ("1i" , Vernacular)
+    , ("1p" , Vernacular) , ("1s" , Vernacular) , ("2d" , Vernacular)
+    , ("2p" , Vernacular) , ("2s" , Vernacular) , ("3d" , Vernacular)
+    , ("3p" , Vernacular) , ("3s" , Vernacular) , ("4d" , Vernacular)
+    , ("4p" , Vernacular) , ("4s" , Vernacular) , ("a"  , Vernacular)
+    , ("an" , Vernacular) , ("bb" , English)    , ("bw" , English)
+    , ("ce" , English)    , ("cf" , Vernacular) , ("cn" , National)
+    , ("cr" , National)   , ("de" , English)    , ("dn" , National)
+    , ("dr" , Regional)   , ("dt" , Other)      , ("dv" , Vernacular)
+    , ("ec" , English)    , ("ee" , English)    , ("eg" , English)
+    , ("en" , National)   , ("er" , Regional)   , ("es" , English)
+    , ("et" , Other)  {- defined as vernacular in SIL Toolbox, but by
+                         definition it's really a different language -}
+    , ("ev" , Vernacular) , ("ge" , English)
+    , ("gn" , National)   , ("gr" , Regional)   , ("gv" , Vernacular)
+    , ("hm" , English)    , ("is" , English)    , ("lc" , Vernacular)
+    , ("le" , English)    , ("lf" , English)    , ("ln" , National)
+    , ("lr" , Regional)   , ("lt" , English)    , ("lv" , Vernacular)
+    , ("lx" , Vernacular) , ("mn" , Vernacular) , ("mr" , Vernacular)
+    , ("na" , English)    , ("nd" , English)    , ("ng" , English)
+    , ("np" , English)    , ("nq" , English)    , ("ns" , English)
+    , ("nt" , English)    , ("oe" , English)    , ("on" , National)
+    , ("or" , Regional)   , ("ov" , Vernacular) , ("pc" , English)
+    , ("pd" , English)    , ("pde", English)    , ("pdl", English)
+    , ("pdn", National)   , ("pdr", Regional)   , ("pdv", Vernacular)
+    , ("ph" , Other)      , ("pl" , Vernacular) , ("pn" , National)
+    , ("ps" , English)    , ("rd" , Vernacular) , ("re" , English)
+    , ("rf" , English)    , ("rn" , National)   , ("rr" , Regional)
+    , ("sc" , English)    , ("sd" , English)    , ("se" , Vernacular)
+    , ("sg" , Vernacular) , ("sn" , English)    , ("so" , English)
+    , ("st" , English)    , ("sy" , Vernacular) , ("tb" , English)
+    , ("th" , Vernacular) , ("u"  , Vernacular) , ("ue" , English)
+    , ("un" , National)   , ("ur" , Regional)   , ("uv" , Vernacular)
+    , ("va" , Vernacular) , ("ve" , English)    , ("vn" , National)
+    , ("vr" , Regional)   , ("we" , English)    , ("wn" , National)
+    , ("wr" , Regional)   , ("xe" , English)    , ("xn" , National)
+    , ("xr" , Regional)   , ("xv" , Vernacular)
+    ]

@@ -0,0 +1,24 @@+module Brassica.Paradigm+       (+       -- * Types+         Process(..)+       , Affix+       , Grammeme(..)+       , AbstractGrammeme(..)+       , Condition(..)+       , Feature(..)+       , FeatureName(..)+       , Statement(..)+       , Paradigm+       -- * Application+       , applyParadigm+       -- * Parsing+       , parseParadigm+       -- ** Re-export+       , errorBundlePretty+       ) where++import Brassica.Paradigm.Apply+import Brassica.Paradigm.Parse+import Brassica.Paradigm.Types+import Text.Megaparsec (errorBundlePretty)

@@ -0,0 +1,81 @@+{-# LANGUAGE LambdaCase    #-}++module Brassica.Paradigm.Apply (applyParadigm) where++import Brassica.Paradigm.Types++import Data.List (sortOn)+import Data.Maybe (mapMaybe)+import Data.Ord (Down(Down))++-- | Apply the given 'Paradigm' to a root, to produce all possible+-- derived forms.+applyParadigm :: Paradigm -> String -> [String]+applyParadigm p w =+    let fs = mapMaybe getFeature p+        ms = mapMaybe getMapping p+    in applyTo w . expand ms <$> combinations fs+  where+    getFeature (NewFeature f) = Just f+    getFeature _ = Nothing++    getMapping (NewMapping k v) = Just (k,v)+    getMapping _ = Nothing+      +combinations :: [Feature] -> [[Grammeme]]+combinations = go []+  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++    satisfied+        :: (FeatureName -> Maybe Grammeme)+        -> Condition+        -> Bool+    satisfied _ Always = True+    satisfied l (Is n g) = case l n of+        Just g' -> g == g'+        Nothing -> False+    satisfied l (Not n g) = case l n of+        Just g' -> g /= g'+        Nothing -> True++expand :: [([AbstractGrammeme], Affix)] -> [Grammeme] -> [Process]+expand ms = concat . ((++) <$> concretes <*> (replace . filterAbstract))+  where+    concretes :: [Grammeme] -> [Affix]+    concretes = mapMaybe $ \case+        Concrete affix -> Just affix+        Abstract _ -> Nothing++    filterAbstract :: [Grammeme] -> [AbstractGrammeme]+    filterAbstract = mapMaybe $ \case+        Concrete _ -> Nothing+        Abstract g -> Just g++    replace :: [AbstractGrammeme] -> [Affix]+    replace gs = do+        (condition, replacement) <- ms+        if condition `subsetOf` gs+           then return replacement+           else []++    xs `subsetOf` ys = all (`elem` ys) xs++applyTo :: String -> [Process] -> String+applyTo w is =+    let ps = concatMap snd $ sortOn (Down . fst) $ mapMaybe getPrefix is+        ss = concatMap snd $ sortOn         fst  $ mapMaybe getSuffix is+    in ps ++ w ++ ss+  where+    getPrefix (Prefix s i) = Just (s,i)+    getPrefix _ = Nothing++    getSuffix (Suffix s i) = Just (s,i)+    getSuffix _ = Nothing

@@ -0,0 +1,91 @@+module Brassica.Paradigm.Parse (parseParadigm) where
+
+import Control.Monad (void)
+import Data.Char (isSpace)
+import Data.Void (Void)
+
+import Text.Megaparsec
+import Text.Megaparsec.Char
+import qualified Text.Megaparsec.Char.Lexer as L
+
+import Brassica.Paradigm.Types
+import Data.Maybe (fromMaybe)
+
+type Parser = Parsec Void String
+
+-- adapted from megaparsec source: like 'space1', but does not
+-- consume newlines (which are important for rule separation)
+space1' :: Parser ()
+space1' = void $ takeWhile1P (Just "whitespace") ((&&) <$> isSpace <*> (/='\n'))
+
+sc :: Parser ()
+sc = L.space space1' (L.skipLineComment "*") empty
+
+lexeme :: Parser a -> Parser a
+lexeme = L.lexeme sc
+
+symbol :: String -> Parser String
+symbol = L.symbol sc
+
+name :: Parser String
+name = lexeme $ some alphaNumChar
+
+slot :: Parser (String -> Process)
+slot = do
+    n <- L.signed (pure ()) L.decimal
+    pure $ if n > 0 then Suffix n else Prefix (-n)
+
+morphValue :: Parser String
+morphValue = lexeme (takeWhile1P (Just "letter") $ (&&) <$> (not.isSpace) <*> (/=')'))
+
+process :: Parser Process
+process = slot <* char '.' <*> morphValue
+
+oneOrMany :: Parser p -> Parser [p]
+oneOrMany p = between (symbol "(") (symbol ")") (many p) <|> fmap pure p
+
+affix :: Parser Affix
+affix = oneOrMany process
+
+grammeme :: Parser Grammeme
+grammeme =
+    Concrete <$> affix
+    <|> Abstract . AbstractGrammeme <$> name
+
+condition :: Parser Condition
+condition = do
+    _ <- symbol "when"
+    between (symbol "(") (symbol ")") $
+        try (Is . FeatureName <$> name <* symbol "is" <*> grammeme)
+        <|> Not . FeatureName <$> name <* symbol "not" <*> grammeme
+
+feature :: Parser Feature
+feature = do
+    c <- fromMaybe Always <$> optional condition
+    globalSlot <- optional $ try $ slot <* space1'
+    case globalSlot of
+        Nothing -> do
+            n <- optional $ try $ name <* symbol "="
+            gs <- some grammeme
+            _ <- optional eol
+            return $ Feature c (FeatureName <$> n) gs
+        Just globalSlot' -> do
+            n <- optional $ try $ name <* symbol "="
+            gs <- some $ oneOrMany $ process <|> (globalSlot' <$> morphValue)
+            _ <- optional eol
+            return $ Feature c (FeatureName <$> n) (Concrete <$> gs)
+
+mapping :: Parser ([AbstractGrammeme], Affix)
+mapping = (,) <$> manyTill (AbstractGrammeme <$> name) (symbol ">") <*> affix <* optional eol
+
+statement :: Parser Statement
+statement = sc *>
+    (uncurry NewMapping <$> try mapping
+    <|> NewFeature <$> feature)
+
+-- | 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.0.3/Documentation.md#paradigm-builder>.
+parseParadigm :: String -> Either (ParseErrorBundle String Void) Paradigm
+parseParadigm = runParser (many statement) ""

@@ -0,0 +1,72 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Brassica.Paradigm.Types where++import Data.String (IsString)++-- | Represents a single morphophonological process: currently, either+-- prefixation or suffixation of a 'String'. The 'Int' gives the+-- distance of the affix from the root.+data Process+    = Prefix Int String+    | Suffix Int String+    deriving (Show, Eq)++-- | A single affix (using the term in a wide sense) can be thought of+-- as a list of morphophonological processes. For instance, the Berber+-- feminine circumfix /t-/…/-t/ might be represented as+-- @['Prefix' 1 "t", 'Suffix' 1 "t"] :: 'Affix'@.+type Affix = [Process]++-- | A 'Grammeme' represents one value of a grammatical feature: for+-- instance past, or dual. This can be realised as a 'Concrete' affix,+-- or can be left 'Abstract' so that it can be encoded in a cumulative+-- morph or similar.+--+-- (The name is from Wikipedia; it doesn’t seem widely-used, but I can+-- find no better for this concept.)+data Grammeme = Concrete Affix | Abstract AbstractGrammeme+    deriving (Show, Eq)++-- | An abstract identifier for a 'Grammeme'.+newtype AbstractGrammeme = AbstractGrammeme String+    deriving stock (Show, Eq)+    deriving newtype (IsString)++-- | A condition which must be satisfied before including a 'Feature'+-- in a word. +data Condition+    = Always+    -- ^ Condition which is always satisfied+    | Is FeatureName Grammeme+    -- ^ Satisfied when the specified feature (identified by its name)+    -- has been assigned to the specified 'Grammeme'+    | Not FeatureName Grammeme+    -- ^ Satisfied when the specified feature has /not/ been assigned+    -- to the specified 'Grammeme'+    deriving (Show, Eq)++-- | A grammatical feature, which may be realised by one of a+-- selection of 'Grammeme's. A feature may be given a descriptive+-- name, as well as a condition which must be satisfied for the+-- 'Feature' to be included in a word.+data Feature = Feature Condition (Maybe FeatureName) [Grammeme]+    deriving (Show, Eq)++newtype FeatureName = FeatureName String+    deriving stock (Show, Eq)+    deriving newtype (IsString)++-- | Each statement in a paradigm description specifies either a new+-- 'Feature', or a new mapping from a set of abstract grammemes to+-- their realisation.+data Statement = NewFeature Feature | NewMapping [AbstractGrammeme] Affix+    deriving (Show, Eq)++-- | A paradigm is specified as a list of 'Statement's. The list is+-- basically big-endian, in that the slowest-varying feature should be+-- listed first. (So if e.g. tense is listed first, then first all+-- words of tense 1 are listed, next all words of tense 2 are listed,+-- and so on.)+type Paradigm = [Statement]

@@ -0,0 +1,7 @@+module Brassica.SoundChange (module X) where
+
+import Brassica.SoundChange.Apply     as X
+import Brassica.SoundChange.Category  as X
+import Brassica.SoundChange.Parse     as X
+import Brassica.SoundChange.Tokenise  as X
+import Brassica.SoundChange.Types     as X

@@ -0,0 +1,15 @@+module Brassica.SoundChange.Apply+       (+       -- * Sound change application+         applyRuleStr+       , applyStatementStr+       , applyChanges+       -- * Logging+       , applyChangesWithLogs+       , applyChangesWithChanges+       , PWordLog(..)+       , reportAsText+       , reportAsHtmlRows+       ) where++import Brassica.SoundChange.Apply.Internal

@@ -0,0 +1,471 @@+{-# LANGUAGE CPP                  #-}
+{-# LANGUAGE ConstraintKinds       #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveAnyClass        #-}
+{-# LANGUAGE DeriveFunctor         #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE DerivingVia           #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE GADTs                 #-}
+{-# LANGUAGE LambdaCase            #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns        #-}
+{-# LANGUAGE PolyKinds             #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE RecordWildCards       #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TupleSections         #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE UndecidableInstances  #-}
+{-# LANGUAGE ViewPatterns          #-}
+
+{-| __Warning:__ This module is __internal__, and does __not__ follow
+  the Package Versioning Policy. It may be useful for extending
+  Brassica, but be prepared to track development closely if you import
+  this module.
+-}
+module Brassica.SoundChange.Apply.Internal
+       ( -- * Types
+         RuleTag(..)
+       -- * Lexeme matching
+       , match
+       , matchMany
+       , mkReplacement
+       , exceptionAppliesAtPoint
+       , matchRuleAtPoint
+       -- * Sound change application
+       , applyOnce
+       , applyRule
+       , checkGraphemes
+       , applyStatement
+       , applyRuleStr
+       , applyStatementStr
+       , applyChanges
+       -- * Logging
+       , LogItem(..)
+       , PWordLog(..)
+       , toPWordLog
+       , reportAsHtmlRows
+       , reportAsText
+       , applyStatementWithLog
+       , applyChangesWithLog
+       , applyChangesWithLogs
+       , applyChangesWithChanges
+       ) where
+
+import Control.Applicative ((<|>))
+import Data.Containers.ListUtils (nubOrd)
+import Data.Function ((&))
+import Data.Functor ((<&>))
+import Data.Maybe (maybeToList, fromMaybe, listToMaybe, mapMaybe)
+import GHC.Generics (Generic)
+
+import Control.DeepSeq (NFData)
+import Control.Monad.State
+
+import Brassica.SoundChange.Apply.Internal.MultiZipper
+import Brassica.SoundChange.Types
+import Data.Bifunctor (Bifunctor(first))
+
+-- | Defines the tags used when applying a 'Rule'.
+data RuleTag
+    = AppStart     -- ^ The start of a rule application
+    | TargetStart  -- ^ The start of the target
+    | TargetEnd    -- ^ The end of the target
+    deriving (Eq, Ord, Show)
+
+-- | A monad in which to process a 'MultiZipper' over
+-- 'Char's. Essentially a @StateT (MultiZipper RuleTag Grapheme) []@:
+-- it stores the 'MultiZipper' as state, and allows failure,
+-- backtracking and multiple answers (backtracking over the state
+-- too).
+newtype RuleAp a = RuleAp { runRuleAp :: MultiZipper RuleTag Grapheme -> [(a, MultiZipper RuleTag Grapheme)] }
+    deriving (Functor, Applicative, Monad, MonadState (MultiZipper RuleTag Grapheme)
+#if __GLASGOW_HASKELL__ > 806
+    , MonadFail
+#endif
+    )
+      via (StateT (MultiZipper RuleTag Grapheme) [])
+
+-- | Lift a partial modification function into a 'State'. Update state
+-- if it succeeds, otherwise rollback.
+modifyMay :: Monad m => (s -> Maybe s) -> StateT s m ()
+modifyMay f = modify $ \s -> fromMaybe s (f s)
+
+-- | Monadic version of 'modify'.
+modifyM :: Monad m => (s -> m s) -> StateT s m ()
+modifyM f = StateT (fmap ((),) . f)
+
+-- | Given a nondeterministic stateful function, lift it into a
+-- 'StateT' computation which returns 'Nothing' when the original
+-- action would have failed with no results.
+try :: (s -> [(a, s)]) -> StateT s [] (Maybe a)
+try p = StateT $ \s ->
+    case p s of
+        [] -> [(Nothing, s)]
+        r -> first Just <$> r
+
+-- | Describes the output of a 'match' operation.
+data MatchOutput = MatchOutput
+    { -- | For each category matched, the index of the matched
+      -- grapheme in that category.
+      matchedCatIxs    :: [Int]
+      -- | For each optional group whether it matched or not
+    , matchedOptionals :: [Bool]
+      -- | The graphemes which were matched
+    , matchedGraphemes :: [Grapheme]
+    } deriving (Show)
+
+modifyMatchedGraphemes :: ([Grapheme] -> [Grapheme]) -> MatchOutput -> MatchOutput
+modifyMatchedGraphemes f MatchOutput{..} = MatchOutput{matchedGraphemes=f matchedGraphemes, ..}
+
+prependGrapheme :: Grapheme -> MatchOutput -> MatchOutput
+prependGrapheme g = modifyMatchedGraphemes (g:)
+
+instance Semigroup MatchOutput where
+    (MatchOutput a1 b1 c1) <> (MatchOutput a2 b2 c2) = MatchOutput (a1++a2) (b1++b2) (c1++c2)
+
+-- | 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
+      => Maybe Grapheme       -- ^ The previously-matched grapheme, if any. (Used to match a 'Geminate'.)
+      -> Lexeme a             -- ^ The lexeme to match.
+      -> MultiZipper t Grapheme   -- ^ The 'MultiZipper' to match against.
+      -> [(MatchOutput, MultiZipper t Grapheme)]
+      -- ^ The output: a tuple @((i, g), mz)@ as described below.
+match prev (Optional l) mz =
+    (MatchOutput [] [False] [], mz) :
+    (first (MatchOutput [] [True] [] <>) <$> matchMany prev l mz )
+match prev w@(Wildcard l) mz = case match prev l mz of
+    [] -> maybeToList (consume mz) >>= \(g, mz') ->
+        first (prependGrapheme g) <$> match prev w mz'
+    r -> r
+match prev k@(Kleene l) mz = case match prev l mz of
+    [] -> [(MatchOutput [] [] [], mz)]
+    r -> r >>= \(out, mz') -> case match prev k mz' of
+        [] -> error "match: Kleene should never fail"
+        r' -> first (out <>) <$> r'
+match _ (Grapheme g) mz = (MatchOutput [] [] [g],) <$> maybeToList (matchGrapheme g mz)
+match _ (Category gs) mz =
+    gs
+    -- Attempt to match each option in category...
+    & fmap (\case
+               BoundaryEl -> if atBoundary mz then Just ([], mz) else Nothing
+               GraphemeEl g -> ([g],) <$> matchGrapheme g mz)
+    -- ...get the index of each match...
+    & zipWith (\i m -> fmap (i,) m) [0..]
+    -- ...and take all matches
+    & (>>= maybeToList)
+    & fmap (\(i, (g, mz')) -> (MatchOutput [i] [] g, mz'))
+match _ Boundary mz = if atBoundary mz then [(MatchOutput [] [] [], mz)] else []
+match prev Geminate mz = case prev of
+    Nothing -> []
+    Just prev' -> (MatchOutput [] [] [prev'],) <$> maybeToList (matchGrapheme prev' mz)
+
+matchGrapheme :: Grapheme -> MultiZipper t Grapheme -> Maybe (MultiZipper t Grapheme)
+matchGrapheme g = matchGraphemeP (==g)
+
+matchGraphemeP :: (Grapheme -> Bool) -> MultiZipper t Grapheme -> Maybe (MultiZipper t Grapheme)
+matchGraphemeP p mz = value mz >>= \cs -> if p cs then fwd mz else Nothing
+
+-- | Match a list of several 'Lexeme's against a
+-- 'MultiZipper'. Arguments and output are the same as with 'match',
+-- though the outputs are given as a list of indices and graphemes
+-- rather than as a single index and grapheme.
+matchMany :: OneOf a 'Target 'Env
+          => Maybe Grapheme
+          -> [Lexeme a]
+          -> MultiZipper t Grapheme
+          -> [(MatchOutput, MultiZipper t Grapheme)]
+matchMany = go (MatchOutput [] [] [])
+  where
+    go out _ [] mz = [(out, mz)]
+    go out prev (l:ls) mz = match prev l mz >>= \(out', mz') ->
+        go (out <> out') (lastMay (matchedGraphemes out') <|> prev) ls mz'
+
+-- Small utility function, not exported
+lastMay :: [a] -> Maybe a
+lastMay l = if null l then Nothing else Just (last l)
+
+-- | Given a list of 'Lexeme's specifying a replacement, generate all
+-- 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.
+    -> MultiZipper t Grapheme
+    -> [MultiZipper t Grapheme]
+mkReplacement = \out ls -> fmap (fst . snd) . go out ls . (,Nothing)
+  where
+    go out []     (mz, prev) = [(out, (mz, prev))]
+    go out (l:ls) (mz, prev) = do
+        (out', (mz', prev')) <- replaceLex out l mz prev
+        go out' ls (mz', prev')
+
+    replaceLex
+        :: MatchOutput
+        -> Lexeme 'Replacement
+        -> MultiZipper t Grapheme
+        -> Maybe Grapheme
+        -> [(MatchOutput, (MultiZipper t Grapheme, Maybe Grapheme))]
+    replaceLex out (Grapheme g) mz _prev = [(out, (insert g mz, Just g))]
+    replaceLex out@MatchOutput{matchedCatIxs=(i:is)} (Category gs) mz _prev =
+        fmap (out{matchedCatIxs=is},) $
+            if i < length gs
+            then case gs !! i of GraphemeEl g -> [(insert g mz, Just g)]
+            else [(insert "\xfffd" mz, Nothing)]  -- Unicode replacement character
+    replaceLex out (Category gs) mz _prev =
+        gs <&> \(GraphemeEl g) -> (out, (insert g mz, Just g))
+    replaceLex MatchOutput{matchedOptionals=(o:os), ..} (Optional ls) mz prev =
+        let out' = MatchOutput{matchedOptionals=os, ..}
+        in if o
+           then go out' ls (mz, prev)
+           else [(out', (mz, Nothing))]
+    replaceLex out (Optional ls) mz prev = (out, (mz, Nothing)) : go out ls (mz, prev)
+    replaceLex out@MatchOutput{matchedGraphemes}     Metathesis  mz _prev =
+        [(out, (flip insertMany mz $ reverse matchedGraphemes, listToMaybe matchedGraphemes))]
+    replaceLex out                                   Geminate    mz prev =
+        [(out, (flip insertMany mz $ maybeToList prev, prev))]
+    replaceLex out@MatchOutput{matchedCatIxs=(_:is)} Discard mz prev = [(out{matchedCatIxs=is}, (mz, prev))]
+    replaceLex out@MatchOutput{matchedCatIxs=[]} Discard mz prev = [(out, (mz, prev))]
+
+-- | Given a 'Rule' and a 'MultiZipper', determines whether the
+-- '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 target (ex1, ex2) mz = fmap fst $ flip runRuleAp mz $ do
+    _ <- RuleAp $ matchMany Nothing ex1
+    pos <- gets curPos
+    MatchOutput{matchedGraphemes} <- RuleAp $ matchMany Nothing target
+    _ <- RuleAp $ matchMany (listToMaybe matchedGraphemes) ex2
+    return pos
+
+-- | Given a 'Rule', determine if that rule matches. If so, for each
+-- match, set the appropriate 'RuleTag's and return a tuple of @(is,
+-- gs)@, where @gs@ is a list of matched t'Grapheme's, and @is@ is a
+-- list of indices, one for each 'Category' lexeme matched.
+matchRuleAtPoint
+    :: Rule
+    -> MultiZipper RuleTag Grapheme
+    -> [(MatchOutput, MultiZipper RuleTag Grapheme)]
+matchRuleAtPoint Rule{environment = (env1, env2), ..} mz = flip runRuleAp mz $ do
+    _ <- RuleAp $ matchMany Nothing env1
+    modify $ tag TargetStart
+    matchResult <- RuleAp $ matchMany Nothing target
+    modify $ tag TargetEnd
+    _ <- RuleAp $ matchMany (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 r@Rule{target, replacement, exception} = do
+    modify $ tag AppStart
+    result <- try (matchRuleAtPoint r)
+    case result of
+        Just out -> do
+            exs <- case exception of
+                Nothing -> pure []
+                Just ex -> gets $ join . toList .
+                    extend' (exceptionAppliesAtPoint target ex)
+            gets (locationOf TargetStart) >>= \p ->
+                if maybe True (`elem` exs) p
+                then return False
+                else do
+                    modifyMay $ modifyBetween (TargetStart, TargetEnd) $ const []
+                    modifyMay $ seek TargetStart
+                    modifyM $ mkReplacement out replacement
+                    return True
+        Nothing -> return False
+
+-- | 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 success r@Rule{flags=Flags{applyDirection}} = fmap untag .
+    case applyDirection of
+        RTL -> seek AppStart >=> bwd
+        LTR ->
+            if success
+            then
+                if null (target r)
+                then -- need to move forward if applying an epenthesis rule to avoid an infinite loop
+                    seek TargetEnd >=> fwd
+                else seek TargetEnd
+            else seek AppStart >=> fwd
+
+-- | 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 r = \mz ->    -- use a lambda so mz isn't shadowed in the where block
+    let startingPos = case applyDirection $ flags r of
+            LTR -> toBeginning mz
+            RTL -> toEnd mz
+        result = repeatRule (applyOnce r) startingPos
+    in if sporadic $ flags r
+          then mz : result
+          else result
+  where
+    repeatRule
+        :: StateT (MultiZipper RuleTag Grapheme) [] Bool
+        -> MultiZipper RuleTag Grapheme
+        -> [MultiZipper RuleTag Grapheme]
+    repeatRule m mz = runStateT m mz >>= \(success, mz') ->
+        if success && applyOnceOnly (flags r)
+        then [mz']
+        else case setupForNextApplication success r mz' of
+            Just mz'' -> repeatRule m mz''
+            Nothing -> [mz']
+
+-- | 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 $ \g -> if g `elem` gs then g else "\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 (RuleS r) mz = applyRule r mz
+applyStatement (CategoriesDeclS 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]
+-- Note: 'fromJust' is safe here as 'apply' should always succeed
+applyRuleStr r s = nubOrd $ fmap toList $ applyRule r $ fromListStart s
+
+-- | Apply a single 'Statement' to a word.
+--
+-- 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 st s = nubOrd $ fmap toList $ applyStatement st $ fromListStart s
+
+-- | A log item representing a single application of an action. (In
+-- practise this will usually be a 'Statement'.) Specifies the action
+-- which was applied, as well as the ‘before’ and ‘after’ states.
+data LogItem r = ActionApplied
+    { action :: r
+    , input :: PWord
+    , output :: PWord
+    } deriving (Show, Functor, Generic, NFData)
+
+-- | Logs the evolution of a 'PWord' as various actions are applied to
+-- it. The actions (usually 'Statement's) are of type @r@.
+data PWordLog r = PWordLog
+    { initialWord :: PWord
+    -- ^ The initial word, before any actions have been applied
+    , derivations :: [(PWord, r)]
+    -- ^ The state of the word after each action @r@, stored alongside
+    -- the action which was applied at each point
+    } deriving (Show, Functor, Generic, NFData)
+
+toPWordLog :: [LogItem r] -> Maybe (PWordLog r)
+toPWordLog [] = Nothing
+toPWordLog ls@(l : _) = Just $ PWordLog
+    { initialWord = input l
+    , derivations = (\ActionApplied{..} -> (output, action)) <$> ls
+    }
+
+-- | Render a single 'PWordLog' to rows of an HTML table. For
+-- instance, the example log given in the documentation for
+-- 'reportAsText' would be converted to the following HTML:
+--
+-- > "<tr><td>tara</td><td>&rarr;</td><td>tazha</td><td>(r / zh)</td></tr><tr><td></td><td>&rarr;</td><td>tazh</td><td>(V / / _ #)</td></tr>"
+--
+-- Which might be displayed in an HTML table as something like the
+-- following:
+--
+-- +------+---+-------+-------------+ 
+-- | tara | → | tazha | (r / zh)    |
+-- +------+---+-------+-------------+ 
+-- |      | → | tazh  | (V / / _ #) |
+-- +------+---+-------+-------------+ 
+
+reportAsHtmlRows :: (r -> String) -> PWordLog r -> String
+reportAsHtmlRows render item = go (concat $ initialWord item) (derivations item)
+  where
+    go _ [] = ""
+    go cell1 ((output, action) : ds) =
+        ("<tr><td>" ++ cell1 ++ "</td><td>&rarr;</td><td>"
+         ++ concat output
+         ++ "</td><td>(" ++ render action ++ ")</td></tr>")
+        ++ go "" ds
+
+-- | Render a single 'PWordLog' to plain text. For instance, this log:
+--
+-- > PWordLog
+-- >   { initialWord = ["t", "a", "r", "a"]
+-- >   , derivations =
+-- >     [ (["t", "a", "zh", "a"], "r / zh")
+-- >     , (["t", "a", "zh"], "V / / _ #")
+-- >     ]
+-- >   }
+--
+-- Would render as:
+--
+-- > tara
+-- >   -> tazha  (r / zh)
+-- >   -> tazh   (V / / _ #)
+reportAsText :: (r -> String) -> PWordLog r -> String
+reportAsText render item = unlines $
+    concat (initialWord item) : fmap toLine (alignWithPadding $ derivations item)
+  where
+    alignWithPadding ds =
+        let (fmap concat -> outputs, actions) = unzip ds
+            maxlen = maximum $ length <$> outputs
+            padded = outputs <&> \o -> o ++ replicate (maxlen - length o) ' '
+        in zip padded actions
+
+    toLine (output, action) = "  -> " ++ output ++ "  (" ++ render action ++ ")"
+
+-- | 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 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 [] _ = [[]]
+applyChangesWithLog (st:sts) w =
+    case applyStatementWithLog st w of
+        [] -> applyChangesWithLog sts w
+        items -> items >>= \l@ActionApplied{output=w'} ->
+            (l :) <$> applyChangesWithLog sts w'
+
+-- | Apply 'SoundChanges' to a word, returning an 'PWordLog'
+-- for each possible result.
+applyChangesWithLogs :: SoundChanges -> PWord -> [PWordLog Statement]
+applyChangesWithLogs scs w = mapMaybe toPWordLog $ applyChangesWithLog  scs w
+
+-- | Apply a set of 'SoundChanges' to a word.
+applyChanges :: SoundChanges -> PWord -> [PWord]
+applyChanges sts w =
+    lastOutput <$> applyChangesWithLog sts w
+  where
+    lastOutput [] = w
+    lastOutput ls = output $ last ls
+
+-- | Apply 'SoundChanges' to a word returning the final results, as
+-- 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 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

@@ -0,0 +1,281 @@+{-# LANGUAGE DeriveTraversable #-}
+
+{-| __Warning:__ This module is __internal__, and does __not__ follow
+  the Package Versioning Policy. It may be useful for extending
+  Brassica, but be prepared to track development closely if you import
+  this module.
+-}
+module Brassica.SoundChange.Apply.Internal.MultiZipper
+       ( MultiZipper
+       -- * Conversion
+       , fromListStart
+       , fromListPos
+       , toList
+       -- * Querying
+       , curPos
+       , atStart
+       , atEnd
+       , atBoundary
+       , value
+       , valueN
+       , locationOf
+       , yank
+       -- * Movement
+       , move
+       , fwd
+       , bwd
+       , consume
+       , seek
+       , toBeginning
+       , toEnd
+       -- * Modification
+       , insert
+       , insertMany
+       , zap
+       , tag
+       , tagAt
+       , query
+       , untag
+       , untagWhen
+       , modifyBetween
+       , extend
+       , extend'
+       ) where
+
+import Control.Applicative (Alternative((<|>)))
+import Data.Foldable (Foldable(foldl'))
+import qualified Data.Map.Strict as M
+
+-- | A 'MultiZipper' is a list zipper (list+current index), with the
+-- addition of ‘tags’ which can be assigned to indices in the
+-- list. Any tag may be assigned to any index, with the restriction
+-- that two different indices may not be tagged with the same
+-- tag. This sort of data structure is useful for certain algorithms,
+-- where it can be convenient to use tags to save positions in the
+-- list and then return back to them later.
+--
+-- (One subtlety: unlike most list zipper implementations, a
+-- 'MultiZipper' positioned at the ‘end’ of a list is actually at
+-- positioned at the index one past the end of the list, rather than
+-- at the last element of the list. Although this makes some functions
+-- slightly more complex — most notably, 'value' becomes non-total —
+-- it makes other algorithms simpler. For instance, this lets
+-- functions processing a 'MultiZipper' to process a portion of the
+-- '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)
+    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
+
+-- | 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
+    then Nothing
+    else Just $ MultiZipper as pos M.empty
+
+-- | Get the list stored in a 'MultiZipper'.
+toList :: MultiZipper t a -> [a]
+toList (MultiZipper as _ _) = as
+
+-- | The current position of the 'MultiZipper'.
+curPos :: MultiZipper t a -> Int
+curPos (MultiZipper _ pos _) = pos
+
+-- | Determine whether the 'MultiZipper' is positioned at the start of
+-- its list.
+atStart :: MultiZipper t a -> Bool
+atStart (MultiZipper _ pos _) = pos <= 0
+
+-- | Determine whether the 'MultiZipper' is positioned at the end of
+-- its list.
+atEnd :: MultiZipper t a -> Bool
+atEnd (MultiZipper as pos _) = pos >= length as
+
+-- | Determine whether the 'MultiZipper' is positioned at the start or
+-- end of its list.
+atBoundary :: MultiZipper t a -> Bool
+atBoundary = (||) <$> atStart <*> atEnd
+
+-- | The element at the current position of the 'MultiZipper'. Returns
+-- 'Nothing' if the 'MultiZipper' is positioned ‘at the end of the
+-- 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
+
+-- | @valueN n mz@ returns the next @n@ elements of @mz@ starting from
+-- the current position, as well as returning a new 'MultiZipper'
+-- positioned past the end of those @n@ elements. (So running
+-- @valueN m@ and then @valueN n@ would return the next @m+n@
+-- elements.) Returns 'Nothing' if this would move the position of the
+-- 'MultiZipper' past the end of the list.
+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
+        then Nothing
+        else Just (take i $ drop pos as, MultiZipper as pos' ts)
+
+-- | Given a tag, return its position
+locationOf :: Ord t => t -> MultiZipper t a -> Maybe Int
+locationOf t (MultiZipper _ _ ts) = M.lookup t ts
+
+-- | Get all tags at the current position
+query :: Ord t => MultiZipper t a -> [t]
+query (MultiZipper _ pos ts) = M.keys $ M.filter (==pos) ts
+
+seekIx :: Int -> MultiZipper t a -> Maybe (MultiZipper t a)
+seekIx i (MultiZipper as _ ts) =
+    if invalid i as
+    then Nothing
+    else Just (MultiZipper as i ts)
+
+-- | @move n mz@ will move the position of @mz@ by @n@ forward (if
+-- n>0) or by @-n@ backward (if n<0). Returns 'Nothing' if this would
+-- cause the 'MultiZipper' to move after the end or before the
+-- beginning of the list.
+move :: Int -> MultiZipper t a -> Maybe (MultiZipper t a)
+move s mz@(MultiZipper _ pos _) = seekIx (pos + s) mz
+
+-- | Move one position forward if possible, otherwise return 'Nothing'.
+fwd :: MultiZipper t a -> Maybe (MultiZipper t a)
+fwd = move 1
+
+-- | Move one position backwards if possible, otherwise return 'Nothing'.
+bwd :: MultiZipper t a -> Maybe (MultiZipper t a)
+bwd = move (-1)
+
+-- | If possible, move one position forward, returning the value moved
+-- 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)
+
+-- | Move the 'MultiZipper' to be at the specified tag. Returns
+-- 'Nothing' if that tag is not present.
+seek :: Ord t => t -> MultiZipper t a -> Maybe (MultiZipper t a)
+seek t (MultiZipper as _ ts) = case M.lookup t ts of
+    Nothing  -> Nothing
+    Just pos -> Just $ MultiZipper as pos ts
+
+-- | Move to the beginning of the 'MultiZipper'.
+toBeginning :: MultiZipper t a -> MultiZipper t a
+toBeginning (MultiZipper as _ ts) = MultiZipper as 0 ts
+
+-- | Move to the end of the 'MultiZipper'.
+toEnd :: MultiZipper t a -> MultiZipper t a
+toEnd (MultiZipper as _ ts) = MultiZipper as (length as) ts
+
+-- | Find first element before point which returns 'Just' when
+-- queried, if any, returning the result of the query function.
+yank :: (a -> Maybe b) -> MultiZipper t a -> Maybe b
+yank p mz = bwd mz >>= \mz' -> (value mz' >>= p) <|> yank p mz'
+
+-- | 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
+
+-- | Insert multiple elements at point and move after them. A simple
+-- wrapper around 'insert'.
+insertMany :: [a] -> MultiZipper t a -> MultiZipper t a
+insertMany = flip $ foldl' $ flip insert
+
+-- | Modify the first element before point to which the modification
+-- function returns 'Just'.
+zap :: (a -> Maybe a) -> MultiZipper t a -> MultiZipper t a
+zap p = \mz@(MultiZipper as pos ts) -> case go as (pos-1) of
+    Nothing  -> mz
+    Just as' -> MultiZipper as' pos ts
+  where
+    go _ (-1) = Nothing
+    go as pos
+      | pos == length as = go as (pos-1)
+      | 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"
+
+-- | Set a tag at the current position.
+tag :: Ord t => t -> MultiZipper t a -> MultiZipper t a
+tag t (MultiZipper as pos ts) = MultiZipper as pos $ M.insert t pos ts
+
+-- | 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
+    then Nothing
+    else Just $ MultiZipper as pos $ M.insert t i ts
+
+-- | Remove tags satisfying predicate
+untagWhen :: (t -> Bool) -> MultiZipper t a -> MultiZipper t a
+untagWhen p (MultiZipper as pos ts) = MultiZipper as pos $ snd $ M.partitionWithKey (flip $ const p) ts
+
+-- | Remove all tags.
+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
+    (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)
+  where
+    correctOrder (m, n) = if m <= n then (m, n) else (n, m)
+
+-- | Given a function to compute a value from a 'MultiZipper' starting
+-- at a particular point, apply that function to all possible starting
+-- points and collect the results. Tags are left unchanged.
+--
+-- (Note: this is really just the same @extend@ method as in the
+-- @Comonad@ typeclass, although 'MultiZipper' wouldn’t be a lawful
+-- comonad.)
+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]
+
+-- | 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]
+
+-- 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)
+
+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

@@ -0,0 +1,110 @@+{-# LANGUAGE DataKinds      #-}
+{-# LANGUAGE DeriveFunctor  #-}
+{-# LANGUAGE KindSignatures #-}
+
+module Brassica.SoundChange.Category
+       (
+       -- * Category construction
+         Category(..)
+       , CategoryState(..)
+       , categorise
+       -- * Category expansion
+       , Categories
+       , Brassica.SoundChange.Category.lookup
+       , mapCategories
+       , expand
+       -- * Obtaining values
+       , bake
+       , values
+       ) where
+
+import Data.Coerce
+import Data.List (intersect)
+import Data.Maybe (fromMaybe)
+
+import qualified Data.Map.Strict as M
+import Data.Containers.ListUtils (nubOrd)
+
+-- | Type-level tag for 'Category'. When parsing a category definition
+-- from a string, usually categories will refer to other
+-- categories. This is the 'Unexpanded' state. Once 'Expanded', these
+-- references will have been inlined, and the category no longer
+-- depends on other categories.
+data CategoryState = Unexpanded | Expanded
+
+-- | A set of values (usually representing phonemes) which behave the
+-- same way in a sound change. A 'Category' is constructed using the
+-- set operations supplied as constructors, possibly referencing other
+-- 'Category's; these references can then be 'expand'ed, allowing the
+-- 'Category' to be 'bake'd to a list of matching values.
+--
+-- Note that Brassica makes no distinction between ad-hoc categories
+-- and predefined categories beyond the sound change parser; the
+-- latter is merely syntax sugar for the former, and both are
+-- represented using the same 'Category' type. In practise this is not
+-- usually a problem, since 'Category's are still quite convenient to
+-- construct manually.
+data Category (s :: CategoryState) a
+    = Empty
+    -- ^ The empty category (@[]@ in Brassica syntax)
+    | Node a
+    -- ^ A single value (@[a]@)
+    | UnionOf [Category s a]
+    -- ^ The union of multiple categories (@[Ca Cb Cc]@)
+    | Intersect (Category s a) (Category s a)
+    -- ^ The intersection of two categories (@[Ca +Cb]@)
+    | Subtract (Category s a) (Category s a)
+    -- ^ The second category subtracted from the first (@[Ca -Cb]@)
+    deriving (Show, Eq, Ord, Functor)
+
+-- | A map from names to the (expanded) categories they
+-- reference. Used to resolve cross-references between categories.
+type Categories a = M.Map a (Category 'Expanded a)
+
+-- | @Data.Map.Strict.'Data.Map.Strict.lookup'@, specialised to 'Categories'.
+lookup :: Ord a => a -> Categories a -> Maybe (Category 'Expanded a)
+lookup = M.lookup
+
+-- | 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
+
+-- | 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
+
+-- | 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)
+
+-- | Given an 'Expanded' 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
+  where
+    difference l m = filter (not . (`elem` m)) l
+
+-- | Returns a list of every value mentioned in a set of
+-- 'Categories'. This includes all values, even those which are
+-- 'Intersect'ed or 'Subtract'ed out: e.g. given 'Categories'
+-- including @[a b -a]@, this will return a list including
+-- @["a","b"]@, not just @["b"]@.
+values :: Ord a => Categories a -> [a]
+values = nubOrd . concatMap go . M.elems
+  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

@@ -0,0 +1,174 @@+{-# LANGUAGE DeriveAnyClass  #-}
+{-# LANGUAGE DeriveFunctor   #-}
+{-# LANGUAGE DeriveGeneric   #-}
+{-# LANGUAGE TupleSections   #-}
+
+{-| __Warning:__ This module is __internal__, and does __not__ follow
+  the Package Versioning Policy. It may be useful for extending
+  Brassica, but be prepared to track development closely if you import
+  this module.
+-}
+module Brassica.SoundChange.Frontend.Internal where
+
+import Data.Bifunctor (second)
+import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Void (Void)
+import GHC.Generics (Generic)
+
+import Control.DeepSeq (NFData)
+import Text.Megaparsec (ParseErrorBundle)
+
+import Brassica.MDF (MDF, parseMDFWithTokenisation, componentiseMDF, componentiseMDFWordsOnly, duplicateEtymologies)
+import Brassica.SoundChange.Apply
+import Brassica.SoundChange.Apply.Internal (applyChangesWithLog, toPWordLog)
+import Brassica.SoundChange.Tokenise
+import Brassica.SoundChange.Types
+
+-- | Rule application mode of the SCA.
+data ApplicationMode
+    = ApplyRules HighlightMode MDFOutputMode
+    | ReportRulesApplied
+    deriving (Show, Eq)
+
+data HighlightMode
+    = NoHighlight
+    | DifferentToLastRun
+    | DifferentToInput
+    deriving (Show, Eq)
+instance Enum HighlightMode where
+    -- used for conversion to and from C, so want control over values
+    fromEnum NoHighlight = 0
+    fromEnum DifferentToLastRun = 1
+    fromEnum DifferentToInput = 2
+
+    toEnum 0 = NoHighlight
+    toEnum 1 = DifferentToLastRun
+    toEnum 2 = DifferentToInput
+    toEnum _ = undefined
+
+data MDFOutputMode = MDFOutput | WordsOnlyOutput
+    deriving (Show, Eq)
+instance Enum MDFOutputMode where
+    -- used for conversion to and from C, so want control over values
+    fromEnum MDFOutput = 0
+    fromEnum WordsOnlyOutput = 1
+
+    toEnum 0 = MDFOutput
+    toEnum 1 = WordsOnlyOutput
+    toEnum _ = undefined
+
+data TokenisationMode = Normal | AddEtymons
+    deriving (Show, Eq)
+instance Enum TokenisationMode where
+    -- used for conversion to and from C, so want control over values
+    fromEnum Normal = 0
+    fromEnum AddEtymons = 1
+
+    toEnum 0 = Normal
+    toEnum 1 = AddEtymons
+    toEnum _ = undefined
+
+-- | Output of a single application of rules to a wordlist: either a
+-- list of possibly highlighted words, an applied rules table, or a
+-- parse error.
+data ApplicationOutput a r
+    = HighlightedWords [Component (a, Bool)]
+    | AppliedRulesTable [PWordLog r]
+    | ParseError (ParseErrorBundle String Void)
+    deriving (Show, Generic, NFData)
+
+-- | Kind of input: either a raw wordlist, or an MDF file.
+data InputLexiconFormat = Raw | MDF
+    deriving (Show, Eq)
+instance Enum InputLexiconFormat where
+    -- used for conversion to and from C, so want control over values
+    fromEnum Raw = 0
+    fromEnum MDF = 1
+
+    toEnum 0 = Raw
+    toEnum 1 = MDF
+    toEnum _ = undefined
+
+data ParseOutput a = ParsedRaw [Component a] | ParsedMDF (MDF [Component a])
+    deriving (Show, Functor)
+
+componentise :: MDFOutputMode -> ParseOutput a -> [Component a]
+componentise _               (ParsedRaw cs) = cs
+componentise MDFOutput       (ParsedMDF mdf) = componentiseMDF mdf
+componentise WordsOnlyOutput (ParsedMDF mdf) = componentiseMDFWordsOnly mdf
+
+tokeniseAccordingToInputFormat
+    :: InputLexiconFormat
+    -> TokenisationMode
+    -> SoundChanges
+    -> String
+    -> Either (ParseErrorBundle String Void) (ParseOutput PWord)
+tokeniseAccordingToInputFormat Raw _ cs =
+    fmap ParsedRaw . withFirstCategoriesDecl tokeniseWords cs
+tokeniseAccordingToInputFormat MDF Normal cs =
+    fmap ParsedMDF . withFirstCategoriesDecl parseMDFWithTokenisation cs
+tokeniseAccordingToInputFormat MDF AddEtymons cs =
+    fmap ParsedMDF
+    . second (duplicateEtymologies $ ('*':) . detokeniseWords)
+    . withFirstCategoriesDecl parseMDFWithTokenisation cs
+
+-- | Top-level dispatcher for an interactive frontend: given a textual
+-- wordlist and a list of sound changes, returns the result of running
+-- the changes in the specified mode.
+parseTokeniseAndApplyRules
+    :: SoundChanges -- ^ changes
+    -> String       -- ^ words
+    -> InputLexiconFormat
+    -> TokenisationMode
+    -> ApplicationMode
+    -> Maybe [Component PWord]  -- ^ previous results
+    -> ApplicationOutput PWord Statement
+parseTokeniseAndApplyRules statements ws intype tmode mode prev =
+    case tokeniseAccordingToInputFormat intype tmode statements ws of
+        Left e -> ParseError e
+        Right toks -> case mode of
+            ReportRulesApplied ->
+                AppliedRulesTable $ mapMaybe toPWordLog $ concat $
+                    getWords $ componentise WordsOnlyOutput $
+                        applyChangesWithLog statements <$> toks
+            ApplyRules DifferentToLastRun mdfout ->
+                let result = concatMap (splitMultipleResults " ") $
+                      componentise mdfout $ applyChanges statements <$> toks
+                in HighlightedWords $
+                    zipWithComponents result (fromMaybe [] prev) [] $ \thisWord prevWord ->
+                        (thisWord, thisWord /= prevWord)
+            ApplyRules DifferentToInput mdfout ->
+                HighlightedWords $ concatMap (splitMultipleResults " ") $
+                    componentise mdfout $ applyChangesWithChanges statements <$> toks
+            ApplyRules NoHighlight mdfout ->
+                HighlightedWords $ (fmap.fmap) (,False) $ concatMap (splitMultipleResults " ") $
+                    componentise mdfout $ applyChanges statements <$> toks
+  where
+    -- Zips two tokenised input strings. Compared to normal 'zipWith'
+    -- this has two special properties:
+    --
+    --   * It only zips v'Word's. Any non-v'Word's in the first argument
+    --     will be passed unaltered to the output; any in the second
+    --     argument will be ignored.
+    --
+    --   * The returned list will have the same number of elements as does
+    --     the first argument. If a v'Word' in the first argument has no
+    --     corresponding v'Word' in the second, the zipping function is
+    --     called using the default @b@ value given as the third argument.
+    --     Such a v'Word' in the second argument will simply be ignored.
+    --
+    -- Note the persistent assymetry in the definition: each 'Component'
+    -- in the first argument will be reflected in the output, but each in
+    -- the second argument may be ignored.
+    zipWithComponents :: [Component a] -> [Component b] -> b -> (a -> b -> c) -> [Component c]
+    zipWithComponents []             _            _  _ = []
+    zipWithComponents as            []            bd f = (fmap.fmap) (`f` bd) as
+    zipWithComponents (Word a:as)   (Word b:bs)   bd f = Word (f a b) : zipWithComponents as bs bd f
+    zipWithComponents as@(Word _:_) (_:bs)        bd f = zipWithComponents as bs bd f
+    zipWithComponents (a:as)        bs@(Word _:_) bd f = unsafeCastComponent a : zipWithComponents as bs bd f
+    zipWithComponents (a:as)        (_:bs)        bd f = unsafeCastComponent a : zipWithComponents as bs bd f
+
+    unsafeCastComponent :: Component a -> Component b
+    unsafeCastComponent (Word _) = error "unsafeCastComponent: attempted to cast a word!"
+    unsafeCastComponent (Separator s) = Separator s
+    unsafeCastComponent (Gloss s) = Gloss s

@@ -0,0 +1,268 @@+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE KindSignatures   #-}+{-# LANGUAGE RecordWildCards  #-}+{-# LANGUAGE TypeApplications #-}++module Brassica.SoundChange.Parse+    ( parseRule+    , parseRuleWithCategories+    , parseSoundChanges+      -- ** Re-export+    , errorBundlePretty+    ) where++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 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)++class ParseLexeme (a :: LexemeType) where+    parseLexeme :: Parser (Lexeme a)+    parseCategoryElement :: Parser (CategoryElement a)++-- space consumer which does not match newlines+sc :: Parser ()+sc = L.space space1' (L.skipLineComment ";") empty+  where+    -- adapted from megaparsec source: like 'space1', but does not+    -- consume newlines (which are important for rule separation)+    space1' = void $ takeWhile1P (Just "white space") ((&&) <$> isSpace <*> (/='\n'))++-- space consumer which matches newlines+scn :: Parser ()+scn = L.space space1 (L.skipLineComment ";") empty++lexeme :: Parser a -> Parser a+lexeme = L.lexeme sc++symbol :: String -> Parser String+symbol = L.symbol sc++keyChars :: [Char]+keyChars = "#[](){}>\\→/_^%~*"++parseGrapheme :: Parser (Grapheme, Bool)+parseGrapheme = lexeme $ (,) <$> takeWhile1P Nothing (not . ((||) <$> isSpace <*> (`elem` keyChars))) <*> (isJust <$> optional (char '~'))++parseGrapheme' :: Parser Grapheme+parseGrapheme' = lexeme $ takeWhile1P Nothing (not . ((||) <$> isSpace <*> (=='=')))++data CategoryModification a+    = Union     (CategoryElement a)+    | Intersect (CategoryElement a)+    | Subtract  (CategoryElement a)++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 $ GraphemeEl <$> c++parseCategory :: ParseLexeme a => Parser (Lexeme a)+parseCategory = do+    mods <- symbol "[" *> someTill parseCategoryModification (symbol "]")+    cats <- gets categories+    return $ Category $ C.bake $+        C.expand (C.mapCategories GraphemeEl cats) (toCategory mods)++parseCategoryStandalone :: Parser (Grapheme, C.Category 'C.Expanded Grapheme)+parseCategoryStandalone = do+    g <- parseGrapheme'+    _ <- symbol "="+    -- Use Target here because it only allows graphemes, not boundaries+    mods <- some (parseCategoryModification @'Target)+    cats <- gets categories+    return (g, C.expand cats $ toGrapheme <$> toCategory mods)++toGrapheme :: CategoryElement 'Target -> Grapheme+toGrapheme (GraphemeEl g) = g++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 @'Target)+        cats <- gets categories+        let plainCat = C.expand cats $ toGrapheme <$> 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)++parseCategoryModification :: ParseLexeme a => Parser (CategoryModification a)+parseCategoryModification = parsePrefix <*> parseCategoryElement+  where+    parsePrefix =+        (Intersect <$ char '+')+        <|> (Subtract <$ char '-')+        <|> pure Union++toCategory :: [CategoryModification a] -> C.Category 'C.Unexpanded (CategoryElement a)+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++parseOptional :: ParseLexeme a => Parser (Lexeme a)+parseOptional = Optional <$> between (symbol "(") (symbol ")") (some parseLexeme)++parseGeminate :: Parser (Lexeme a)+parseGeminate = Geminate <$ symbol ">"++parseMetathesis :: Parser (Lexeme 'Replacement)+parseMetathesis = Metathesis <$ symbol "\\"++parseWildcard :: (ParseLexeme a, OneOf a 'Target 'Env) => Parser (Lexeme a)+parseWildcard = Wildcard <$> (symbol "^" *> parseLexeme)++parseBoundary :: Parser ()+parseBoundary = () <$ symbol "#"++parseDiscard :: Parser (Lexeme 'Replacement)+parseDiscard = Discard <$ symbol "~"++parseKleene :: OneOf a 'Target 'Env => Lexeme a -> Parser (Lexeme a)+parseKleene l = (Kleene l <$ symbol "*") <|> pure l++instance ParseLexeme 'Target where+    parseLexeme = asum+        [ parseCategory+        , parseOptional+        , parseGeminate+        , parseWildcard+        , parseGraphemeOrCategory+        ] >>= parseKleene+    parseCategoryElement = GraphemeEl . fst <$> parseGrapheme++instance ParseLexeme 'Replacement where+    parseLexeme = asum+        [ parseCategory+        , parseOptional+        , parseMetathesis+        , parseDiscard+        , parseGeminate+        , parseGraphemeOrCategory+        ]+    parseCategoryElement = GraphemeEl . fst <$> parseGrapheme++instance ParseLexeme 'Env where+    parseLexeme = asum+        [ parseCategory+        , Boundary <$ parseBoundary+        , parseOptional+        , parseGeminate+        , parseWildcard+        , parseGraphemeOrCategory+        ] >>= parseKleene+    parseCategoryElement = asum+        [ BoundaryEl <$ parseBoundary+        , GraphemeEl . fst <$> parseGrapheme+        ]++parseLexemes :: ParseLexeme a => Parser [Lexeme a]+parseLexemes = many parseLexeme++parseFlags :: Parser Flags+parseFlags = runPermutation $ Flags+    <$> toPermutation (isNothing <$> optional (symbol "-x"))+    <*> toPermutationWithDefault LTR ((LTR <$ symbol "-ltr") <|> (RTL <$ symbol "-rtl"))+    <*> toPermutation (isJust <$> optional (symbol "-1"))+    <*> toPermutation (isJust <$> optional (symbol "-?"))++ruleParser :: Parser Rule+ruleParser = do+    -- This is an inlined version of 'match' from @megaparsec@;+    -- 'match' itself would be tricky to use here, since it would need+    -- to wrap multiple parsers rather than just one+    o <- getOffset+    s <- getInput++    flags <- parseFlags+    target <- parseLexemes+    _ <- lexeme $ oneOf "/→"+    replacement <- parseLexemes++    let parseEnvironment = do+            _ <- symbol "/"+            env1 <- parseLexemes+            _ <- symbol "_"+            env2 <- parseLexemes+            exception <- optional $ (,) <$> (symbol "/" *> parseLexemes) <* symbol "_" <*> parseLexemes+            return (env1, env2, exception)++    (env1, env2, exception) <- parseEnvironment <|> pure ([], [], Nothing)++    _ <- optional scn   -- consume newline after rule if present++    o' <- getOffset+    let plaintext = takeWhile notNewline $ (fst . fromJust) (takeN_ (o' - o) s)+    return Rule{environment=(env1,env2), ..}+  where+    notNewline c = (c /= '\n') && (c /= '\r')++-- | 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.0.3/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++-- | Parse a list of 'SoundChanges'.+parseSoundChanges :: String -> Either (ParseErrorBundle String Void) SoundChanges+parseSoundChanges s = flip evalState (Config M.empty) $ runParserT (scn *> parser <* eof) "" s+  where+    parser = many $+        CategoriesDeclS <$> categoriesDeclParse+        <|> RuleS <$> ruleParser

@@ -0,0 +1,162 @@+{-# LANGUAGE DeriveAnyClass    #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE ViewPatterns      #-}++module Brassica.SoundChange.Tokenise+       ( +       -- * Components+         Component(..)+       , getWords+       , splitMultipleResults+       -- * High-level interface+       , tokeniseWord+       , tokeniseWords+       , detokeniseWords'+       , detokeniseWords+       , findFirstCategoriesDecl+       , withFirstCategoriesDecl+       -- * Lower-level functions+       , wordParser+       , componentsParser+       , sortByDescendingLength+       ) where++import Data.Char (isSpace)+import Data.Function (on)+import Data.Functor.Identity+import Data.List (intersperse, sortBy)+import Data.Maybe (mapMaybe)+import Data.Ord (Down(..))+import Data.Void (Void)+import GHC.Generics (Generic)++import Control.DeepSeq (NFData)+import Text.Megaparsec hiding (State)+import Text.Megaparsec.Char++import Brassica.SoundChange.Types++-- | Represents a component of a tokenised input string. v'Word's in+-- the input are represented as the type parameter @a@ — which for+-- this reason will usually, though not always, be 'PWord'.+data Component a = Word a | Separator String | Gloss String+    deriving (Eq, Show, Functor, Foldable, Traversable, Generic, NFData)++-- | Given a tokenised input string, return only the v'Word's within+-- it.+getWords :: [Component a] -> [a]+getWords = mapMaybe $ \case+    Word a -> Just a+    _ -> Nothing++-- | Given a 'Component' containing multiple values in a v'Word',+-- split it apart into a list of 'Component's in which the given+-- 'String' is used as a 'Separator' between multiple results.+--+-- For instance:+--+-- >>> splitMultipleResults " " (Word ["abc", "def", "ghi"])+-- [Word "abc", Separator " ", Word "def", Separator " ", Word "ghi"]+--+-- >>> splitMultipleResults " " (Word ["abc"])+-- [Word "abc"]+splitMultipleResults :: String -> Component [a] -> [Component a]+splitMultipleResults wh (Word as) = intersperse (Separator wh) $ Word <$> as+splitMultipleResults _ (Separator w) = [Separator w]+splitMultipleResults _ (Gloss g) = [Gloss g]+    +-- | Megaparsec parser for 'PWord's — see 'tokeniseWord' documentation+-- for details on the parsing strategy and the meaning of the second+-- parameter. For most usecases 'tokeniseWord' should suffice;+-- 'wordParser' itself is only really useful in unusual situations+-- (e.g. as part of a larger parser). The first parameter gives a list+-- of characters (aside from whitespace) which should be excluded from+-- words, i.e. the parser will stop if any of them are found.+--+-- Note: the second parameter __must__ be 'sortByDescendingLength'-ed;+-- otherwise digraphs will not be parsed correctly.+wordParser :: [Char] -> [Grapheme] -> ParsecT Void String Identity PWord+wordParser excludes gs = some $ choice (chunk <$> gs) <|> (pure <$> satisfy (not . exclude))+  where+    exclude = (||) <$> isSpace <*> (`elem` excludes)++-- | Megaparsec parser for 'Component's. Similarly to 'wordParser',+-- usually it’s easier to use 'tokeniseWords' instead.+componentsParser+    :: ParsecT Void String Identity a+    -> ParsecT Void String Identity [Component a]+componentsParser p = many $+    (Separator <$> takeWhile1P Nothing isSpace) <|>+    (Gloss <$> gloss False) <|>+    (Word <$> p)+  where+    gloss returnBracketed = do+        _ <- char '['+        contents <- many $ gloss True <|> takeWhile1P Nothing (not . (`elem` "[]"))+        _ <- char ']'+        pure $ if returnBracketed+           then '[' : concat contents ++ "]"+           else concat contents++sortByDescendingLength :: [[a]] -> [[a]]+sortByDescendingLength = sortBy (compare `on` Down . length)++-- | Tokenise a 'String' input word into a 'PWord' by splitting it up+-- into t'Grapheme's. A list of available t'Grapheme's is supplied as+-- an argument.+--+-- Note that this tokeniser is greedy: if one of the given+-- t'Grapheme's is a prefix of another, the tokeniser will prefer the+-- longest if possible. If there are no matching t'Grapheme's starting+-- at a particular character in the 'String', 'tokeniseWord' will+-- treat that character as its own t'Grapheme'. For instance:+--+-- >>> tokeniseWord [] "cherish"+-- Right ["c","h","e","r","i","s","h"]+-- +-- >>> tokeniseWord ["e","h","i","r","s","sh"] "cherish"+-- Right ["c","h","e","r","i","sh"]+-- +-- >>> tokeniseWord ["c","ch","e","h","i","r","s","sh"] "cherish"+-- Right ["ch","e","r","i","sh"]+tokeniseWord :: [Grapheme] -> String -> Either (ParseErrorBundle String Void) PWord+tokeniseWord (sortByDescendingLength -> gs) = parse (wordParser "[" gs) ""++-- | Given a list of available t'Grapheme's, tokenise an input string+-- into a list of words and other 'Component's. This uses the same+-- tokenisation strategy as 'tokeniseWords', but also recognises+-- 'Gloss'es (in square brackets) and 'Separator's (in the form of+-- whitespace).+tokeniseWords :: [Grapheme] -> String -> Either (ParseErrorBundle String Void) [Component PWord]+tokeniseWords (sortByDescendingLength -> gs) =+    parse (componentsParser $ wordParser "[" gs) ""++-- | Given a function to convert 'Word's to strings, converts a list+-- of 'Component's to strings.+detokeniseWords' :: (a -> String) -> [Component a] -> String+detokeniseWords' f = concatMap $ \case+    Word gs -> f gs+    Separator w -> w+    Gloss g -> '[':(g ++ "]")++-- | Specialisation of 'detokeniseWords'' for 'PWord's, converting+-- words to strings using 'concat'.+detokeniseWords :: [Component PWord] -> String+detokeniseWords = detokeniseWords' concat++-- | Given a list of sound changes, extract the list of graphemes+-- defined in the first categories declaration of the 'SoundChange's.+findFirstCategoriesDecl :: SoundChanges -> [Grapheme]+findFirstCategoriesDecl (CategoriesDeclS (CategoriesDecl gs):_) = gs+findFirstCategoriesDecl (_:ss) = findFirstCategoriesDecl ss+findFirstCategoriesDecl [] = []++-- | CPS'd form of 'findFirstCategoriesDecl'. Nice for doing things+-- like @'withFirstCategoriesDecl' 'tokeniseWords' changes words@ (to+-- tokenise using the graphemes from the first categories declaration)+-- and so on.+withFirstCategoriesDecl :: ([Grapheme] -> t) -> SoundChanges -> t+withFirstCategoriesDecl tok ss = tok (findFirstCategoriesDecl ss)

@@ -0,0 +1,204 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DerivingVia           #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++module Brassica.SoundChange.Types+       (+       -- * Words and graphemes+         Grapheme+       , PWord+       -- * Lexemes+       , Lexeme(..)+       , CategoryElement(..)+       , LexemeType(..)+       -- * Rules+       , Rule(..)+       , Environment+       , Direction(..)+       , Flags(..)+       , defFlags+       -- * Categories and statements+       , CategoriesDecl(..)+       , Statement(..)+       , plaintext'+       , SoundChanges+       -- * Utility+       , OneOf+       ) where++import Control.DeepSeq (NFData(..))+import Data.Kind (Constraint)+import GHC.Generics (Generic)+import GHC.TypeLits++-- | The constraint @OneOf a x y@ is satisfied if @a ~ x@ or @a ~ y@.+--+-- (Note: the strange @() ~ Bool@ constraint is just a simple+-- unsatisfiable constraint, so as to not give ‘non-exhaustive pattern+-- match’ errors everywhere.)+type family OneOf a x y :: Constraint where+    OneOf a a y = ()+    OneOf a x a = ()+    OneOf a b c =+        ( () ~ Bool+        , TypeError ('Text "Couldn't match type "+                     ':<>: 'ShowType a+                     ':<>: 'Text " with "+                     ':<>: 'ShowType b+                     ':<>: 'Text " or "+                     ':<>: 'ShowType c))++-- | The type of graphemes, or more accurately multigraphs: for+-- instance, @"a", "ch", "c̓" :: t'Grapheme'@.+type Grapheme = [Char]++-- | 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'@.+--+-- (The name 'PWord' is from ‘phonological word’, these being what a+-- SCA typically manipulates; this name was chosen to avoid a clash+-- with @Prelude.'Prelude.Word'@.)+type PWord = [Grapheme]++-- | The part of a 'Rule' in which a 'Lexeme' may occur: either the+-- target, the replacement or the environment.+data LexemeType = Target | Replacement | Env++-- | 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+    -- | In Brassica sound-change syntax, one or more letters without intervening whitespace+    Grapheme :: Grapheme -> Lexeme a+    -- | In Brassica sound-change syntax, delimited by square brackets+    Category :: [CategoryElement a] -> Lexeme a+    -- | In Brassica sound-change syntax, specified as @#@+    Boundary :: Lexeme 'Env+    -- | In Brassica sound-change syntax, delimited by parentheses+    Optional :: [Lexeme a] -> Lexeme a+    -- | In Brassica sound-change syntax, specified as @\@+    Metathesis :: Lexeme 'Replacement+    -- | In Brassica sound-change syntax, specified as @>@+    Geminate :: Lexeme a+    -- | In Brassica sound-change syntax, specified as @^@ before another 'Lexeme'+    Wildcard :: OneOf a 'Target 'Env => Lexeme a -> Lexeme a+    -- | In Brassica sound-change syntax, specified as @*@ after another 'Lexeme'+    Kleene   :: OneOf a 'Target 'Env => Lexeme a -> Lexeme a+    -- | In Brassica sound-change syntax, specified as @~@+    Discard  :: Lexeme 'Replacement++deriving instance Show (Lexeme a)++instance NFData (Lexeme a) where+    rnf (Grapheme g) = rnf g+    rnf (Category cs) = rnf cs+    rnf Boundary = ()+    rnf (Optional ls) = rnf ls+    rnf Metathesis = ()+    rnf Geminate = ()+    rnf (Wildcard l) = rnf l+    rnf (Kleene l) = rnf l+    rnf Discard = ()++-- | The elements allowed in a 'Category': currently, only+-- t'Grapheme's and word boundaries.+data CategoryElement (a :: LexemeType) where+    GraphemeEl :: Grapheme -> CategoryElement a+    BoundaryEl :: CategoryElement 'Env++deriving instance Show (CategoryElement a)+deriving instance Eq (CategoryElement a)+deriving instance Ord (CategoryElement a)++instance NFData (CategoryElement a) where+    rnf (GraphemeEl a) = rnf a+    rnf BoundaryEl = ()++-- | An 'Environment' is a tuple of @(before, after)@ components,+-- corresponding to a ‘/ before _ after’ component of a sound change.+--+-- Note that an empty environment is just @([], [])@.+type Environment = ([Lexeme 'Env], [Lexeme 'Env])++-- | Specifies application direction of rule — either left-to-right or right-to-left.+data Direction = LTR | RTL+    deriving (Eq, Show, Generic, NFData)++-- | Flags which can be enabled, disabled or altered on a 'Rule' to+-- change how it is applied.+data Flags = Flags+  { highlightChanges :: Bool+  , applyDirection   :: Direction+  , applyOnceOnly    :: Bool+  , sporadic         :: Bool+  } deriving (Show, Generic, NFData)++-- | A default selection of flags which are appropriate for most+-- rules:+--+-- @+-- 'defFlags' = 'Flags'+--     { 'highlightChanges' = 'True'+--     , 'applyDirection' = 'LTR'+--     , 'applyOnceOnly' = 'False'+--     , 'sporadic' = 'False'+--     }+-- @+--+-- That is: highlight changes, apply from left to right, apply+-- repeatedly, and don’t apply sporadically.+defFlags :: Flags+defFlags = Flags+    { highlightChanges = True+    , applyDirection = LTR+    , applyOnceOnly = False+    , sporadic = False+    }++-- | A single sound change rule: in Brassica sound-change syntax with all elements specified,+-- @-flags target / replacement \/ environment \/ 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+  , flags       :: Flags+  , plaintext   :: String+  } deriving (Show, Generic, NFData)++-- | 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)++-- | A 'Statement' can be either a single sound change rule, or a+-- category declaration.+data Statement = RuleS Rule | CategoriesDeclS CategoriesDecl+    deriving (Show, Generic, NFData)++-- | A simple wrapper around 'plaintext' for 'Statement's. Returns+-- @"categories … end"@ for all 'CategoriesDecl' inputs.+plaintext' :: Statement -> String+plaintext' (RuleS r) = plaintext r+plaintext' (CategoriesDeclS _) = "categories … end"++-- | A set of 'SoundChanges' is simply a list of 'Statement's.+type SoundChanges = [Statement]

@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PartialTypeSignatures #-}+module Main where++import Conduit+import Control.Category ((>>>))+import Control.Monad.Trans.Except (runExceptT, throwE)+import System.IO (IOMode(..), withFile)+import Test.Tasty ( defaultMain, testGroup, TestTree )+import Test.Tasty.Golden (goldenVsFile)++import qualified Data.ByteString as B+import qualified Data.ByteString.UTF8 as B8+import qualified Data.Text as T++import Brassica.SoundChange (applyChanges, splitMultipleResults, applyChangesWithLogs, reportAsText)+import Brassica.SoundChange.Parse (parseSoundChanges, errorBundlePretty)+import Brassica.SoundChange.Tokenise (tokeniseWords, detokeniseWords, withFirstCategoriesDecl, Component, getWords)+import Brassica.SoundChange.Types (SoundChanges, PWord, plaintext')++main :: IO ()+main = defaultMain $ testGroup "brassica-tests"+    [ proto21eTest applyChanges showWord "proto21e golden test" "proto21e.out" "proto21e.golden"+    , proto21eTest applyChangesWithLogs showLogs "proto21e golden test with log" "proto21e-log.out" "proto21e-log.golden"+    ]+  where+    showWord = detokeniseWords . concatMap (splitMultipleResults " ")++    showLogs logs = unlines $ fmap (reportAsText plaintext') $ concat $ getWords logs++proto21eTest+    :: (SoundChanges -> PWord -> [a])+    -> ([Component [a]] -> String)+    -> String+    -> FilePath+    -> FilePath+    -> TestTree+proto21eTest applyFn showWord testName outName goldenName =+    let outName' = "test/" ++ outName+        goldenName' = "test/" ++ goldenName+    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+                liftIO $ putStrLn $+                    "Cannot parse the SCA file because:\n" +++                    errorBundlePretty err+                throwE ()+            let output pre = B8.fromString . (++"\n") . (pre ++)+                prettyError  = output "SCA Error:" . errorBundlePretty+                prettyOutput = output "SCA Output: " . showWord+                evolve =+                    withFirstCategoriesDecl tokeniseWords soundChanges+                    >>> (fmap.fmap.fmap) (applyFn soundChanges)+                    >>> either prettyError prettyOutput+            liftIO $ withSourceFile "test/proto21e.in" $ flip connect+                $ decodeUtf8C+                .| linesUnboundedC+                .| mapC (evolve . T.unpack)+                .| sinkHandle outFile+++catchEither :: Applicative f => Either e a -> (e -> f a) -> f a+catchEither val f = either f pure val