brassica 0.3.0 → 1.0.0

raw patch · 25 files changed

+1841/−753 lines, 25 filesdep +pandocdep +pandoc-typesdep ~aesondep ~bytestringdep ~textPVP ok

version bump matches the API change (PVP)

Dependencies added: pandoc, pandoc-types

Dependency ranges changed: aeson, bytestring, text, transformers

API changes (from Hackage documentation)

Files

• ChangeLog.md +122/−0
• README.md +13/−13
• bench/Changes.hs +7/−5
• brassica.cabal +29/−10
• cli-pb/Main.hs +1/−1
• cli/Main.hs +18/−9
• cli/Server.hs +18/−4
• src/Brassica/Paradigm.hs +16/−7
• src/Brassica/Paradigm/Apply.hs +4/−0
• src/Brassica/Paradigm/Parse.hs +1/−1
• src/Brassica/Paradigm/Types.hs +10/−9
• src/Brassica/SFM/MDF.hs +29/−14
• src/Brassica/SFM/SFM.hs +29/−16
• src/Brassica/SoundChange.hs +56/−2
• src/Brassica/SoundChange/Apply.hs +24/−5
• src/Brassica/SoundChange/Apply/Internal.hs +521/−227
• src/Brassica/SoundChange/Apply/Internal/MultiZipper.hs +26/−10
• src/Brassica/SoundChange/Category.hs +0/−181
• src/Brassica/SoundChange/Expand.hs +373/−0
• src/Brassica/SoundChange/Frontend/Internal.hs +100/−49
• src/Brassica/SoundChange/Parse.hs +94/−41
• src/Brassica/SoundChange/Tokenise.hs +65/−43
• src/Brassica/SoundChange/Types.hs +193/−96
• test/DocTests.hs +81/−0
• test/Spec.hs +11/−10

@@ -1,5 +1,127 @@ # Brassica changelog +## 1.0.0++### Behaviour++(Note: breaking changes are boldfaced.)++- Bugfixes:+  - Etymologies are now added in all situations when processing an MDF file+  - Desktop version correctly warns about unsaved changes when opening a file+  - Rules such as `[p f] / [f h] / (a) _ #` are no longer applied twice to the same grapheme+      (as a consequence of changes to rule application, see below)+  - `noreplace` categories now tokenise multigraphs as expected+- Documentation (user guides and Haddocks) have been comprensively rewritten+- ‘Tonogenesis’ example has been replaced by ‘Thai’ example+- New support for phonetic features:+  - Features can be written as maximal `$name#ident(values)` after another lexeme+  - Categories named `+Feature`, `-Feature` and `+Feature+Value`+      get special interpretation with intersections and subtractions+  - New category syntax: `&` before category name forces union interpretation+      even for category names beginning with `+`/`-`+  - Change to category syntax: first element of category is always interpreted as union+      (**technically a breaking change**, but unlikely in existing sound changes)+  - Syntax `&Feature` after set operation (`&`/`+`/`-`) to include both `-Feature` and `+Feature`+      (i.e. all graphemes with a setting for that feature)+  - Declaration `auto <FeaturalCategory>` in category definition block+      can be used to treat said feature autosegmentally+      whenever a grapheme in the selected category is mentioned+- Other changes to sound change syntax:+  - `report` directive allows for reporting intermediate results in input→output mode+  - Graphemes followed by `~` are now allowed inside a category block,+      but **disallowed in category names and in `extra` declarations** (where they would be meaningless)+  - **Category intersection now produces a category with graphemes+      in the same order as the last category mentioned, rather than the first**+  - Optional elements or categories can now be prefixed by `%` to make them match greedily+  - New backreference syntax `@#id` allows categories to be matched by ID rather than number+  - `extra` graphemes are now always taken into account for multigraph tokenisation+      (**technically a breaking change**, but unlikely in existing sound changes)+  - Within a category, single graphemes inside braces are now treated the same as single graphemes outside braces+      (**technically a breaking change**, but unlikely to change existing sound changes)+- Changes to rule application algorithm:+  - **Sound change applications can now overlap,+      such that the replacement from one application can be used as the environment for the next**+  - New flag `-no` allows for reverting to the previous behaviour (non-overlapping applications)+  - **Make RTL and LTR application symmetric,+      by reimplementing the former as LTR application with words and rules reversed:+      consequently category correspondences, backreferences etc. are also reversed**+- Improvements to graphical interface:+  - Whitespace is now preserved when displaying sound change output on desktop and web+  - New keyboard shortcuts in desktop GUI:+      Ctrl+Enter to apply rules, Ctrl+Tab to toggle between rules and words textboxes+  - Some labels have been changed to be more descriptive:+    ‘Different to input’ to ‘Any rule applied’, and ‘Wordlist’ to ‘Wordlist + glosses’+  - Improvements to output from ‘Report rules apply’: most importantly,+    comments are no longer included next to rules, and+    outputs are no longer aligned across input words (greatly increasing responsiveness on desktop)+  - User can now choose which MDF hierarchy to use for dictionaries+  - Web version brought closer to parity with desktop version+      by adding MDF support and an option to ‘synchronise scroll positions’+  - When ‘view results live’ is selected, results are updated on changes to all controls,+      not just changes to words or sound changes+  - Add ‘Edit’ menu to desktop GUI, including ‘Find’ dialog box+  - Add ‘Help’ menu to desktop GUI+  - Fields of web GUI can now be initialised using URL query parameters+    (`r` for rules, `w` for words)+  - Add ‘select all’ buttons to web GUI+  - Improve display of web application controls on small screens+  - Sound changes editor on web version has been rewritten to work around bug with combining diacritics+  - Add option for ‘input→output’ display format to include glosses and whitespace++### Code++- CMakeLists for desktop GUI now track Haskell binary dependency correctly+- Renamed `Brassica.SoundChange.Category` to `Brassica.SoundChange.Expand`+- Renamed constructor `Brassica.SoundChange.Types.DirectiveS` to `Brassica.SoundChange.Types.DeclS` +- Changes resulting from addition of `report`:+  - New constructor `ReportS` added to `Brassica.SoundChange.Types.Statement`+  - A constructor `ReportWord` has been added to `Brassica.SoundChange.Apply.Internal.LogItem`,+      while its former record fields `input` and `output` have been replaced with functions+      `logInput` and `logOutput`.+  - `Brassica.SoundChange.Frontend.Internal` has been restructured to allow display of intermediate results+  - New function `Brassica.SoundChange.Tokenise.joinComponents` added to assist with said restructure+- Changes resulting from addition of features:+  - New constructors `Feature` and `Autosegment` added to `Brassica.SoundChange.Types.Lexeme`+    (the latter primarily for internal use)+  - New type `Brassica.SoundChange.Apply.Internal`+  - New constructor `DefineAuto` added to `Brassica.SoundChange.Types.CategoryDefinition`+  - Changes in category expansion:+      new type `Brassica.SoundChange.Expand.AutosegmentDef`,+      and new constructor `InvalidDerivedValue`+        added to `Brassica.SoundChange.Expand.ExpandError`+- Changes resulting from new rule application algorithm:+  - New constructore `PrevEnd` added to `Brassica.SoundChange.Apply.Internal.RuleTag`+  - New field `nonOverlappingTarget` added to `Brassica.SoundChange.Types.Flags`+- New constructors `GreedyOptional` and `GreedyCategory` for `Brassica.SoundChange.Types.Lexeme`+- `Brassica.SoundChange.Frontend.Internal.InputLexiconFormat`+    now depends on new type `Brassica.SoundChange.Frontend.Internal.MDFHierarchy`+- Word boundaries are now simply ordinary graphemes `"#"`:+    `Brassica.SoundChange.Types.Grapheme` is now a type synonym for `[Char]`+- Expansion now results in sound changes with declaration type `GraphemesList`+    rather than `[Grapheme]`+- API of `Brassica.SoundChanges.Apply` (and `Brassica.SoundChanges.Apply.Internal`) has been refactored:+  - `LogItem` (now re-exported from `Brassica.SoundChanges.Apply`)+      no longer stores redundant information on input words+  - `PWordLog` is renamed `Log`, and is now based on `LogItem`+  - `initialWord` is now renamed `inputWord`+  - Former functions `applyRule` and `applyStatement`+      have been renamed to `applyRuleMZ` and `applyStatementMZ`;+  - Former functions `applyRuleWithLogs` and `applyStatementWithLog`+      have been renamed to `applyRule` and `applyStatement`+  - Function `applyRuleWithLog` has been removed+  - Set of sound change application functions `applyChanges*`+      has been replaced with a single function `applyChanges` returning a `PWordLog`,+      plus a set of functions to extract various outputs from it+- New constructor `WordsWithProtoOutputPreserve` for `Brassica.SoundChange.Frontend.Internal.OutputMode`+- Remove now-unnecessary pattern `Brassica.SoundChange.Types.Boundary`+- In parsing modules, re-export whole module `Text.Megaparsec.Error`+    rather than only re-exporting the single function `errorBundlePretty`+- Category elements are now represented as simply `[Lexeme category a]`+    (synonym `Brassica.SoundChanges.Types.CategoryElement`),+    without any special case for single-grapheme elements+- `concatWithBoundary` is now no longer re-exported from `Brassica.SoundChange.Tokenise`+ ## 0.3.0  ### Behaviour

@@ -2,27 +2,27 @@  [![Hackage](https://img.shields.io/hackage/v/brassica.svg?logo=haskell)](https://hackage.haskell.org/package/brassica) -Brassica is a new sound change applier.-Its features include:+Brassica is a sound change applier: a program to simulate the evolution of language over time. -- Can be used interactively both [online](https://bradrn.com/brassica/index.html) and as a desktop application, or non-interactively in batch mode on the command-line or as a [Haskell library](https://hackage.haskell.org/package/brassica)-- Natively supports the MDF dictionary format, also used by tools including [SIL Toolbox](https://software.sil.org/toolbox/) and [Lexique Pro](https://software.sil.org/lexiquepro/)-- First-class support for multigraphs-- Easy control over rule application: apply sound changes sporadically, right-to-left, between words, and in many more ways-- Live preview and control over output highlighting let you try out sound changes quickly and easily-- Highlight and visualise results in numerous ways-- Category operations allow phonetic rules to be written in both featural and character-based ways-- Support for ‘features’ lets rules easily manipulate stress, tone and other suprasegmentals+Brassica’s features include:++- A choice of four different platforms: you can use Brassica interactively [online](https://bradrn.com/brassica/index.html) or as a standalone application,+    non-interactively on the command-line, or as a [Haskell library](https://hackage.haskell.org/package/brassica)+- Being well-tested, including several automated test suites, as well as example files with sound changes from natural languages+- First-class support for suprasegmental features, such as stress and tone+- Easy control over rule application: apply sound changes iteratively, sporadically, right-to-left, between words, and in many more ways+- Native support for the MDF dictionary format, also used by tools including [SIL Toolbox](https://software.sil.org/toolbox/) and [Lexique Pro](https://software.sil.org/lexiquepro/)+- A comprehensive user interface with live preview and highlighting for both sound changes and output - Comes with a [paradigm builder](https://bradrn.com/brassica/builder.html) for quickly investigating inflectional and other patterns-- Rich syntax for specifying phonetic rules, including wildcards, optional elements and more  And many more! -See the [documentation](./Documentation.md) for details on Brassica usage.+See the [documentation](./docs) for details on Brassica usage,+  and the [example files](./examples) for examples of practical 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 for Windows and Linux. 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.1.0/gui-interface-example.png)+![Image of Brassica with some example sound changes](./docs/screenshot.png)

@@ -60,22 +60,24 @@ 
     complex = Rule
         { target =
-            [ Category $ FromElements $ Left <$> ["t", "d", "n"]
+            [ Category $ FromElements $ toElem <$> ["t", "d", "n"]
             , Optional [Grapheme "y"]
-            , Category $ FromElements $ Left <$> ["i", "e"]
+            , Category $ FromElements $ toElem <$> ["i", "e"]
             ]
         , replacement =
-            [ Category $ FromElements $ Left <$> ["c", "j", "nh"]
+            [ Category $ FromElements $ toElem <$> ["c", "j", "nh"]
             , Optional [Geminate]
             ]
         , environment = pure
-            ( [Category $ FromElements $ Left <$> [GBoundary, "a", "e", "i"]]
-            , [Category $ FromElements $ Left <$> ["a", "e", "i", "o", "u"]]
+            ( [Category $ FromElements $ toElem <$> ["#", "a", "e", "i"]]
+            , [Category $ FromElements $ toElem <$> ["a", "e", "i", "o", "u"]]
             )
         , exception = Nothing
         , flags = defFlags
         , plaintext = "[t d n] (y) [i e] / [č j ñ] (>) / [# a e i] _ [a e i o u]"
         }
+
+    toElem g = [Grapheme g]
 
     benchChanges :: Rule Expanded -> PWord -> [Benchmark]
     benchChanges cs l =

@@ -1,10 +1,13 @@ cabal-version:      2.0 name:               brassica-version:            0.3.0+version:            1.0.0 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>.+  This is the Brassica library for the simulation of sound changes in historical linguistics and language construction.+  .+  For an introduction to library usage, see the documentation of [Brassica.SoundChange](https://hackage.haskell.org/package/brassica-1.0.0/candidate/docs/Brassica-SoundChange.html).+  .+  For further details on Brassica’s design and usage, please refer to the README below or at <https://github.com/bradrn/brassica/blob/v1.0.0#readme>.  category:           Linguistics homepage:           https://github.com/bradrn/brassica#readme@@ -28,7 +31,7 @@                  , Brassica.SoundChange.Apply                  , Brassica.SoundChange.Apply.Internal                  , Brassica.SoundChange.Apply.Internal.MultiZipper-                 , Brassica.SoundChange.Category+                 , Brassica.SoundChange.Expand                  , Brassica.SoundChange.Frontend.Internal                  , Brassica.SoundChange.Parse                  , Brassica.SoundChange.Tokenise@@ -63,7 +66,7 @@   build-depends:                     base >=4.7 && <5                   , brassica-                  , aeson ^>=2.2+                  , aeson >=2.2 && <2.3                   , attoparsec-aeson ^>=2.2                   , bytestring >=0.10 && <0.13                   , conduit ^>=1.3@@ -71,7 +74,7 @@                   , deepseq >=1.4 && <1.6                   , optparse-applicative ^>=0.17.1 || ^>=0.18                   , parallel ^>= 3.2-                  , text >=1.2 && <2.2+                  , text >=1.2 && <2.3    default-language: Haskell2010 @@ -85,7 +88,7 @@                   , bytestring >=0.10 && <0.13                   , conduit ^>=1.3                   , optparse-applicative ^>=0.17.1 || ^>=0.18-                  , text >=1.2 && <2.2+                  , text >=1.2 && <2.3    default-language: Haskell2010 @@ -100,7 +103,7 @@                   , criterion >=1.5 && <1.7                   , file-embed >=0.0.15 && <0.0.16                   , parallel ^>= 3.2-                  , text >=1.2 && <1.3+                  , text >=1.2 && <2.3    default-language: Haskell2010 @@ -127,9 +130,25 @@                   , tasty ^>=1.4                   , tasty-golden ^>=2.3                   , bytestring-                  , text >=1.2 && <2.1-                  , transformers ^>=0.5+                  , text >=1.2 && <2.3+                  , transformers >=0.5 && <0.7                   , conduit ^>=1.3                   , utf8-string ^>=1.0++  default-language: Haskell2010++test-suite doctests+  type:             exitcode-stdio-1.0+  main-is:          DocTests.hs+  hs-source-dirs:   test+  ghc-options:      -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:+                    base >=4.7 && <5+                  , brassica+                  , tasty ^>=1.4+                  , bytestring+                  , text >=1.2 && <2.3+                  , pandoc >=3.3 && <3.4+                  , pandoc-types >=1.23 && <1.24    default-language: Haskell2010

@@ -34,7 +34,7 @@                 .| encodeUtf8C                 .| outC   where-    opts = info (args <**> helper <**> simpleVersioner "v0.3.0") fullDesc+    opts = info (args <**> helper <**> simpleVersioner "v1.0.0") fullDesc      args = Options         <$> asum

@@ -7,7 +7,7 @@  import Conduit import qualified Data.ByteString as B-import Data.Text (pack, unpack, snoc, Text)+import Data.Text (pack, unpack, snoc, unsnoc, Text) import Data.Text.Encoding (decodeUtf8) import Options.Applicative @@ -32,6 +32,7 @@                     Left err -> putStrLn $ case err of                         (NotFound s) -> "Could not find category: " ++ s                         InvalidBaseValue -> "Invalid value used as base grapheme in feature definition"+                        InvalidDerivedValue -> "Invalid value used as derived grapheme in autosegment"                         MismatchedLengths -> "Mismatched lengths in feature definition"                     Right rules' ->                         withSourceFileIf inWordsFile $ \inC ->@@ -42,7 +43,7 @@                             .| outC    where-    opts = info (args <**> helper <**> simpleVersioner "v0.3.0") fullDesc+    opts = info (args <**> helper <**> simpleVersioner "v1.0.0") fullDesc      args = batchArgs <|> serverArgs     serverArgs = flag' Server (long "server" <> help "Run server (for internal use only)")@@ -53,8 +54,12 @@             , FromFile <$> strArgument                 (metavar "RULES" <> help "File containing sound changes")             ]-        <*> flag Raw MDF-            (long "mdf" <> help "Parse input words in MDF format")+        <*> asum+            [ flag Raw (MDF Standard)+                (long "mdf" <> help "Parse input words in MDF format (standard hierarchy)")+            , flag Raw (MDF Alternate)+                (long "mdf-alt" <> help "Parse input words in MDF format (alternate hierarchy)")+            ]         <*> (asum                 [ flag' (const ReportRulesApplied)                     (long "report" <> help "Report rules applied rather than outputting words")@@ -79,7 +84,7 @@             (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+    incrFor (MDF _) = False      -- duplicated in paradigm builder CLI     withSourceFileIf :: Maybe FilePath -> (ConduitM i B.ByteString IO () -> IO a) -> IO a@@ -104,14 +109,14 @@ processWords     :: (MonadIO m, MonadThrow m)     => Bool  -- split into lines?-    -> SoundChanges Expanded [Grapheme]+    -> SoundChanges Expanded GraphemeList     -> InputLexiconFormat     -> ApplicationMode     -> ConduitT B.ByteString B.ByteString m () processWords incr rules wordsFormat outMode =     decodeUtf8C     .| (if incr then linesUnboundedC else mapC id)-    .| mapC (processApplicationOutput . evolve . unpack . (`snoc` '\n'))+    .| mapC (processApplicationOutput . evolve . unpack)     .| throwOnLeft     .| encodeUtf8C   where@@ -122,10 +127,14 @@         Left e -> throwM e         Right r -> yield r -    processApplicationOutput :: ApplicationOutput PWord (Statement Expanded [Grapheme]) -> Either ParseException Text-    processApplicationOutput (HighlightedWords cs) = Right $ pack $ detokeniseWords' highlight cs+    processApplicationOutput :: ApplicationOutput PWord (Statement Expanded GraphemeList) -> Either ParseException Text+    processApplicationOutput (HighlightedWords cs) = Right $ ensureNewline $ pack $ detokeniseWords' highlight cs     processApplicationOutput (AppliedRulesTable is) = Right $ pack $ unlines $ reportAsText plaintext' <$> is     processApplicationOutput (ParseError e) = Left $ ParseException $ errorBundlePretty e++    ensureNewline t = case unsnoc t of+        Just (_, '\n') -> t+        _ -> snoc t '\n'      highlight (w, False) = concatWithBoundary w     highlight (w, True) = concatWithBoundary w ++ " [+]"

@@ -14,12 +14,14 @@ import Control.DeepSeq (force, NFData) import Control.Exception (evaluate) import Control.Parallel.Strategies (withStrategy, parTraversable, rseq)-import Data.Aeson (Result(..), encode, fromJSON)+import Data.Aeson (Result(..), encode, FromJSON(..), ToJSON(..), Value (..), fromJSON) import Data.Aeson.Parser (json') import Data.Aeson.TH (deriveJSON, defaultOptions, defaultTaggedObject, constructorTagModifier, sumEncoding, tagFieldName)+import Data.Aeson.Types (prependFailure, typeMismatch) import Data.ByteString (toStrict) import Data.Conduit.Attoparsec (conduitParser) import Data.Foldable (toList)+import Data.Text (unpack) import GHC.Generics (Generic) import System.IO (hSetBuffering, stdin, stdout, BufferMode(NoBuffering)) import System.Timeout@@ -57,9 +59,20 @@     | RespError String     deriving (Show, Generic, NFData) +instance ToJSON InputLexiconFormat where+    toJSON Raw = "Raw"+    toJSON (MDF Standard) = "MDFStandard"+    toJSON (MDF Alternate) = "MDFAlternate"++instance FromJSON InputLexiconFormat where+    parseJSON (String "Raw") = pure Raw+    parseJSON (String "MDFStandard") = pure $ MDF Standard+    parseJSON (String "MDFAlternate") = pure $ MDF Alternate+    parseJSON (String s) = fail $ "Unknown InputLexiconFormat: " ++ unpack s+    parseJSON invalid = prependFailure "parsing InputLexiconFormat failed: " $+        typeMismatch "String" invalid+ $(deriveJSON defaultOptions ''Component)-$(deriveJSON defaultOptions ''Grapheme)-$(deriveJSON defaultOptions ''InputLexiconFormat) $(deriveJSON defaultOptions ''HighlightMode) $(deriveJSON defaultOptions ''OutputMode) @@ -107,6 +120,7 @@                 Left err -> RespError $ ("<pre>"++) $ (++"</pre>") $ case err of                     (NotFound s) -> "Could not find category: " ++ s                     InvalidBaseValue -> "Invalid value used as base grapheme in feature definition"+                    InvalidDerivedValue -> "Invalid value used as derived grapheme in autosegment"                     MismatchedLengths -> "Mismatched lengths in feature definition"                 Right statements' ->                     let result' = parseTokeniseAndApplyRules parFmap statements' input inFmt mode prev@@ -117,7 +131,7 @@                             (Just $ (fmap.fmap) fst result)                             (escape $ detokeniseWords' highlightWord result)                         AppliedRulesTable items -> RespRules Nothing $-                            surroundTable $ concatMap (reportAsHtmlRows plaintext') items+                            concatMap (surroundTable . reportAsHtmlRows plaintext') items   where     highlightWord (s, False) = concatWithBoundary s     highlightWord (s, True) = "<b>" ++ concatWithBoundary s ++ "</b>"

@@ -1,6 +1,15 @@+-- |+-- Module      : Brassica.Paradigm+-- Copyright   : See LICENSE file+-- License     : BSD3+-- Maintainer  : Brad Neimann+-- module Brassica.Paradigm        (-         Process(..)+       -- * Re-export+         module Text.Megaparsec.Error+       -- * Paradigm representation+       , Process(..)        , Affix        , Grammeme(..)        , AbstractGrammeme(..)@@ -9,16 +18,16 @@        , FeatureName(..)        , Statement(..)        , Paradigm-       , ResultsTree(..)-       , depth-       , applyParadigm+       -- * Parsing and pretty-printing        , parseParadigm        , formatNested-       -- ** Re-export-       , errorBundlePretty+       -- * Paradigm application+       , applyParadigm+       , ResultsTree(..)+       , depth        ) where  import Brassica.Paradigm.Apply import Brassica.Paradigm.Parse import Brassica.Paradigm.Types-import Text.Megaparsec (errorBundlePretty)+import Text.Megaparsec.Error

@@ -16,6 +16,8 @@ import Data.Maybe (mapMaybe) import Data.Ord (Down(Down)) +-- | Results from applying a 'Paradigm' to a word, represented as a tree+-- containing each possible choice of 'Grammeme's. data ResultsTree a = Node [ResultsTree a] | Result a     deriving (Show, Functor, Foldable) @@ -23,6 +25,8 @@ addLevel f (Result r) = Node $ Result <$> f r addLevel f (Node rs) = Node $ addLevel f <$> rs +-- | Depth of a 'ResultsTree': i.e. how many levels of 'Node's it+-- contains. depth :: ResultsTree a -> Int depth (Node ts) = maximum $ (1+) . depth <$> ts depth (Result _) = 0

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

@@ -34,14 +34,14 @@     deriving stock (Show, Eq)     deriving newtype (IsString) --- | A condition which must be satisfied before including a 'Feature'--- in a word. +-- | A condition which must be satisfied for a 'Feature' to be+-- included 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'+    -- ^ Satisfied when the specified feature has been assigned to the+    -- specified 'Grammeme'     | Not FeatureName Grammeme     -- ^ Satisfied when the specified feature has /not/ been assigned     -- to the specified 'Grammeme'@@ -54,6 +54,7 @@ data Feature = Feature Condition (Maybe FeatureName) [Grammeme]     deriving (Show, Eq) +-- | Name to identify a specific 'Feature'. newtype FeatureName = FeatureName String     deriving stock (Show, Eq)     deriving newtype (IsString)@@ -64,9 +65,9 @@ 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.)+-- | A paradigm is specified as a list of 'Statement's. The order is+-- reflected in the output 'Brassica.Paradigm.Apply.ResultsTree': the+-- root has one child for each grammeme in the first 'Feature', with+-- each child then having one child for each grammeme in the second+-- 'Feature', and so on. type Paradigm = [Statement]

@@ -1,10 +1,14 @@ {-# LANGUAGE NamedFieldPuns #-} -{-| 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.SFM.MDF+-- Copyright   : See LICENSE file+-- License     : BSD3+-- Maintainer  : Brad Neimann+--+-- This module contains types and functions for working with the MDF+-- dictionary format. For more on the MDF format, refer to e.g.+-- [Coward & Grimes (2000)](http://downloads.sil.org/legacy/shoebox/MDF_2000.pdf). module Brassica.SFM.MDF where  import Brassica.SFM.SFM@@ -71,7 +75,7 @@     , ("xr" , Regional)   , ("xv" , Vernacular)     ] --- | Standard MDF hierarchy: with @\lx@ > @\se@ > @\ps@ > @\sn@.+-- | Standard MDF hierarchy, with @\lx@ > @\se@ > @\ps@ > @\sn@. -- Intended for use with 'toTree'. mdfHierarchy :: Hierarchy mdfHierarchy = M.fromList@@ -98,7 +102,7 @@     , ("wr", "sn"), ("xe", "xv"), ("xn", "xv"), ("xr", "xv"), ("xv", "rf")     ] --- | Alternate MDF hierarchy: with @\lx@ > @\sn@ > @\se@ > @\ps@.+-- | Alternate MDF hierarchy, with @\lx@ > @\sn@ > @\se@ > @\ps@. -- Intended for use with 'toTree'. mdfAlternateHierarchy :: Hierarchy mdfAlternateHierarchy = M.fromList@@ -130,15 +134,20 @@ -- if using 'tokeniseWords'; everything else is treated as a -- 'Separator', so that it is not disturbed by operations such as rule -- application or rendering to text.+--+-- (This is a simple wrapper around 'tokeniseField'.) tokeniseMDF     :: [String]  -- ^ List of available multigraphs (as with 'tokeniseWord')     -> SFM -> Either (ParseErrorBundle String Void) [Component PWord] tokeniseMDF gs = fmap concat . traverse (tokeniseField gs) --- | Like 'tokeniseMDF', but for a single 'Field'.+-- | Like 'tokeniseMDF', but for a single 'Field' rather than a whole+-- SFM file. tokeniseField :: [String] -> Field -> Either (ParseErrorBundle String Void) [Component PWord] tokeniseField gs f = case M.lookup (fieldMarker f) fieldLangs of     Just Vernacular ->+        -- initialise megaparsec state with position starting at given+        -- field         let ps = initialPosState "" (fieldValue f)             s = State                 { stateInput = fieldValue f@@ -154,7 +163,7 @@      _ -> Right [Separator $ '\\' : fieldMarker f ++ fieldWhitespace f ++ fieldValue f] --- | Add etymological fields to an 'MDF' by duplicating the values in+-- | Add etymological fields to an MDF file by duplicating the values in -- @\lx@, @\se@ and @\ge@ fields. e.g.: -- -- > \lx kapa@@ -177,7 +186,11 @@ -- -- 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.
+-- changes can be applied leaving the etymologies as is.+--+-- Note that the hierarchy must already be resolved before this+-- function can be used, as it depends on the tree structure to know+-- where the etymologies should be placed. duplicateEtymologies     :: (String -> String)     -- ^ Transformation to apply to etymologies, e.g. @('*':)@@@ -215,7 +228,7 @@             { fieldMarker = "et"             , fieldWhitespace = " "             , fieldSourcePos = Nothing-            , fieldValue = f $ trim lx+            , fieldValue = ensureNewline $ f $ trim lx             }         $ case gl of               Nothing -> []@@ -224,10 +237,12 @@                       { fieldMarker = "eg"                       , fieldWhitespace = " "                       , fieldSourcePos = Nothing-                      , fieldValue = gl'-                        -- no need to add newline here because 'gl'-                        -- should already have whitespace+                      , fieldValue = ensureNewline gl'                       } []                   ]      trim = dropWhile isSpace . dropWhileEnd isSpace++    ensureNewline s+        | last s == '\n' = s+        | otherwise = s ++ "\n"

@@ -1,12 +1,17 @@ {-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE LambdaCase #-}
 
-{-| This module implements basic support for the SIL Standard Format
-Marker (SFM) format, used by dictionary software such as
-[FieldWorks](https://software.sil.org/fieldworks/). This format forms
-the basis of standards such as Multi-Dictionary Formatter (MDF),
-implemented here in 'Brassica.SFM.MDF'.
--}
+-- |
+-- Module      : Brassica.SFM.SFM
+-- Copyright   : See LICENSE file
+-- License     : BSD3
+-- Maintainer  : Brad Neimann
+--
+-- This module implements basic support for the SIL Standard Format
+-- Marker (SFM) format, used by dictionary software such as
+-- [FieldWorks](https://software.sil.org/fieldworks/). This format forms
+-- the basis of standards such as Multi-Dictionary Formatter (MDF),
+-- implemented here in @Brassica.SFM.MDF@.
 module Brassica.SFM.SFM
        ( -- * Linear SFM documents
          Field(..)
@@ -41,6 +46,7 @@     -- ^ Whitespace after the field marker
     , fieldSourcePos :: Maybe SourcePos
     -- ^ Optionally, a Megaparsec 'SourcePos' marking the start of the value
+    -- (to enable further parsing)
     , fieldValue :: String
     -- ^ The value of the field, including all whitespace until the next marker
     } deriving (Show)
@@ -80,7 +86,7 @@     value <- parseFieldValue
     pure (marker, s, ps, value)
 
--- | Parse an SFM file to an 'SFM'.
+-- | Parse an SFM file to an 'SFM' value.
 parseSFM
     :: String  -- ^ Name of source file
     -> String  -- ^ Input SFM data to parse
@@ -108,7 +114,8 @@     deriving (Show)
 
 -- | The hierarchy underlying an SFM document, defined as a map from
--- field names to their parents. Unlisted fields are treated as roots.
+-- field names to their parents. Fields which are absent from the map
+-- are treated as roots.
 type Hierarchy = M.Map String String
 
 -- | Returns the full hierarchy of a marker, starting with its
@@ -126,11 +133,11 @@ (Filled f s) <+:> t = Filled f (s ++ [t])
 (Missing f s) <+:> t = Missing f (s ++ [t])
 
--- | Use a 'Hierarchy' to generate a tree structure from an 'SFM'
--- document. Fields are converted to 'Filled' nodes, containing as
--- many following nodes as possible, until the next node which is at
--- the same level of the hierarchy or lower. 'Missing' nodes are
--- created for any missing levels of the hierarchy.
+-- | Generate a tree structure from an 'SFM' document according to the
+-- given 'Hierarchy'. Fields are converted to 'Filled' nodes,
+-- containing as many following nodes as possible, until the next node
+-- which is at the same level of the hierarchy or lower. 'Missing'
+-- nodes are created for any missing levels of the hierarchy.
 toTree :: Hierarchy -> SFM -> SFMTree
 toTree h = fst . go (Root [])
   where
@@ -158,8 +165,13 @@                 in go (s <+:> subtree) fs'
 
             -- otherwise, recurse into the hierarchy
-            (m:_, _) ->
-                let (subtree, fs') = go (Missing m []) (f:fs)
+            (ms, _) ->
+                -- NB. 'last ms' is the /highest/ missing level! Then
+                -- the recursive call infers the next-highest level,
+                -- and so on until all the levels are created. This
+                -- could be sped up by creating all the levels at once,
+                -- but it's not worth it for now.
+                let (subtree, fs') = go (Missing (last ms) []) (f:fs)
                 in go (s <+:> subtree) fs'
 
 -- | Inverse of 'toTree': convert an 'SFMTree' back into a linear
@@ -175,7 +187,8 @@ mapField g (Filled f s) = Filled (g f) $ mapField g <$> s
 mapField g (Missing m s) = Missing m $ mapField g <$> s
 
--- | Depth-first search for fields under an 'SFMTree'.
+-- | Depth-first search for fields under an 'SFMTree' which satisfy
+-- the given predicate.
 searchField :: (Field -> Maybe a) -> SFMTree -> [a]
 searchField p (Root ts) = searchField p =<< ts
 searchField p (Filled f ts)

@@ -1,7 +1,61 @@+-- |
+-- Module      : Brassica.SoundChange
+-- Copyright   : See LICENSE file
+-- License     : BSD3
+-- Maintainer  : Brad Neimann
+--
+-- The modules below provide Brassica’s support for sound changes.
+-- For further details on their syntax and processing, refer to the
+-- [reference guide](https://github.com/bradrn/brassica/blob/v1.0.0/docs/Reference.md),
+-- and the documentation of individual modules.
+--
+-- In brief, a sound changes file passes through the following phases:
+--
+--     1. First it is /parsed/ to a @'SoundChanges' 'CategorySpec' 'Directive'@
+--     2. Next it undergoes /expansion/ to give a @'SoundChanges' 'Expanded' 'GraphemeList'@
+--     3. Finally it can be /applied/ to a 'PWord' using 'applyChanges' or similar.
+--
+-- Words may also be extracted from a words file for application using
+-- 'tokeniseWords', and the file can be recreated using
+-- 'detokeniseWords' or similar. (For an MDF file one can similarly
+-- use 'Brassica.SFM.MDF.tokeniseMDF'.)
+--
+-- For a simple example, the following sample applies a sound change
+-- file to a words file (without error-handling):
+--
+-- @
+-- import Data.Maybe (mapMaybe)
+-- import System.Environment (getArgs)
+-- import Brassica.SoundChange
+--
+-- main :: IO ()
+-- main = do
+--     [changesFile, wordsFile] <- getArgs
+--     changes <- readFile changesFile
+--     words <- readFile wordsFile
+--
+--     let Right changesParsed = 'parseSoundChanges' changes
+--         Right changesExpanded = 'expandSoundChanges' changesParsed
+--
+--         Right wordsTokenised =
+--             'withFirstCategoriesDecl' 'tokeniseWords' changesExpanded words
+--
+--         wordsOutput = fmap (mapMaybe 'getOutput' . 'applyChanges' changesExpanded) <$> wordsTokenised
+--
+--     putStrLn $ 'detokeniseWords' $
+--         concatMap ('splitMultipleResults' "/") wordsOutput
+-- @
+--
+-- If writing sound changes in Haskell, it is suggested to skip
+-- parsing and expansion and directly create a value of type
+-- @'SoundChanges' 'Expanded' ('Bool', [t'Grapheme'])@. Expansion is
+-- of little use when v'Category's and v'Autosegment's can be assigned
+-- names in the code itself.
 module Brassica.SoundChange (module X) where
 
+-- NB. Haddock seems to list these re-exports in reverse order
+import Brassica.SoundChange.Tokenise  as X
 import Brassica.SoundChange.Apply     as X
-import Brassica.SoundChange.Category  as X
+import Brassica.SoundChange.Expand    as X
 import Brassica.SoundChange.Parse     as X
-import Brassica.SoundChange.Tokenise  as X
 import Brassica.SoundChange.Types     as X

@@ -1,13 +1,32 @@+-- |+-- Module      : Brassica.SoundChange.Apply+-- Copyright   : See LICENSE file+-- License     : BSD3+-- Maintainer  : Brad Neimann+--+-- This module contains functions to apply one or more expanded sound+-- changes to words.+--+-- The most important function is 'applyChanges', which applies a set+-- of 'Brassica.SoudnChanges.Types.SoundChanges' to an input word. It+-- returns a log of all sound changes and other actions which were+-- applied to produce intermediate forms and the final result. The+-- results can be summarised using the functions in+-- [Reporting results](#g:3). module Brassica.SoundChange.Apply        (-       -- * Sound change application+       -- * Applying single rules          applyRuleStr        , applyStatementStr+       -- * Applying multiple sound changes        , applyChanges-       -- * Logging-       , applyChangesWithLogs-       , applyChangesWithChanges-       , PWordLog(..)+       , Log(..)+       , LogItem(..)+       -- * Reporting results+       , getOutput+       , getReports+       , getChangedOutputs+       , getChangedReports        , reportAsText        , reportAsHtmlRows        ) where

@@ -20,54 +20,89 @@ {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE UndecidableInstances  #-}
 
-{-| __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
+-- Copyright   : See LICENSE file
+-- License     : BSD3
+-- Maintainer  : Brad Neimann
+--
+-- __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.
+--
+-- This module contains the lower-level functions used by Brassica to
+-- match and apply sound changes. The overall algorithm is similar to
+-- that described by [Howard (1973)](https://dspace.mit.edu/bitstream/handle/1721.1/12982/26083289-MIT.pdf?sequence=2).
+--
+-- Some essential points:
+--
+--     * Words are represented as 'MultiZipper's, with a cursor index
+--       and zero or more tagged indices. A sound change can then be
+--       applied ('applyRuleMZ') by advancing through the word from
+--       left to right. (Right-to-left application is achieved by
+--       reversing both word and rule.)
+--
+--     * For each potential application site, 'applyOnce' checks the
+--       target, environments and exceptions. If they are all
+--       satisfied, it then replaces the target graphemes with the
+--       replacement graphemes. After running 'applyOnce',
+--       'setupForNextApplication' can be used to advance to the next
+--       application site.
+--
+--     * The lowest-level function for matching is 'match', which
+--       matches an individual 'Lexeme' at some point in a word. The
+--       lowest-level function for replacement is 'mkReplacement',
+--       which constructs replacement graphemes.
 module Brassica.SoundChange.Apply.Internal
        (
        -- * Lexeme matching
          RuleTag(..)
        , RuleStatus(..)
        , MatchOutput(..)
+       , FeatureState(..)
+       , newOutput
+       , initialOutput
        , match
        , matchMany
-       , matchMany'
        , mkReplacement
        , exceptionAppliesAtPoint
        , matchRuleAtPoint
        -- * Sound change application
        , applyOnce
-       , applyRule
+       , setupForNextApplication
+       , applyRuleMZ
        , checkGraphemes
-       , applyStatement
+       , applyStatementMZ
        , applyRuleStr
        , applyStatementStr
-       , applyChanges
        -- * Logging
        , LogItem(..)
-       , PWordLog(..)
-       , toPWordLog
+       , Log(..)
        , reportAsHtmlRows
        , reportAsText
-       , applyStatementWithLog
-       , applyChangesWithLog
-       , applyChangesWithLogs
-       , applyChangesWithChanges
+       , applyStatement
+       , applyChanges
+       , getOutput
+       , getReports
+       , getChangedOutputs
+       , getChangedReports
        ) where
 
 import Control.Applicative ((<|>))
 import Control.Category ((>>>))
-import Control.Monad ((>=>), join)  -- needed for mtl>=2.3
+import Control.Monad ((>=>), (<=<), join)  -- needed for mtl>=2.3
 import Data.Containers.ListUtils (nubOrd)
 import Data.Functor ((<&>))
+import Data.List (elemIndex)
 import Data.Maybe (maybeToList, fromMaybe, listToMaybe, mapMaybe)
 import GHC.Generics (Generic)
 
 import Control.DeepSeq (NFData)
 import Control.Monad.State
 
+import qualified Data.Map.Strict as Map
+
 import Brassica.SoundChange.Apply.Internal.MultiZipper
 import Brassica.SoundChange.Types
 import Data.Bifunctor (Bifunctor(first))
@@ -77,6 +112,9 @@     = AppStart     -- ^ The start of a rule application
     | TargetStart  -- ^ The start of the target
     | TargetEnd    -- ^ The end of the target
+    | PrevEnd
+    -- ^ The end of the replacement from the last rule application
+    -- (used to avoid infinite loops from iterative rules)
     deriving (Eq, Ord, Show)
 
 -- | A monad in which to process a 'MultiZipper' over
@@ -85,11 +123,7 @@ -- 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)
-
-    , MonadFail
-
-    )
+    deriving (Functor, Applicative, Monad, MonadState (MultiZipper RuleTag Grapheme), MonadFail)
       via (StateT (MultiZipper RuleTag Grapheme) [])
 
 -- | Lift a partial modification function into a 'State'. Update state
@@ -110,30 +144,57 @@         [] -> [(Nothing, s)]
         r -> first Just <$> r
 
+-- | The result of matching a 'Feature' or 'Autosegment': either a
+-- specific index in the 'Feature', or an indeterminate result (when
+-- no indices matched)
+data FeatureState = Index Int | Indeterminate
+    deriving (Show, Eq)
+
 -- | Describes the output of a 'match' operation.
 data MatchOutput = MatchOutput
-    { -- | For each category matched, the index of the matched
-      -- grapheme in that category.
+    { -- | For each non-backreferenced category matched: the index of
+      -- the matched grapheme in that category.
       matchedCatIxs    :: [Int]
-      -- | For each optional group whether it matched or not
+      -- | For each optional group: whether it matched or not
     , matchedOptionals :: [Bool]
-      -- | For each wildcard, the graphemes which it matched
+      -- | For each wildcard: the graphemes which it matched
     , matchedWildcards :: [[Grapheme]]
-      -- | For each Kleene star, how many repititions it matched
+      -- | For each Kleene star: how many repetitions it matched
     , matchedKleenes   :: [Int]
-      -- | The graphemes which were matched
+      -- | The actual graphemes which were matched
     , matchedGraphemes :: [Grapheme]
+      -- | The features which were matched, by name
+    , matchedFeatures :: Map.Map String [FeatureState]
+      -- | Backreferenced categories which were matched, by ID
+    , matchedBackrefIds :: Map.Map String Int
+      -- | Backreferenced features which were matched, by ID
+    , matchedFeatureIds :: Map.Map String FeatureState
     } deriving (Show)
 
+-- | Create 'MatchOutput' for next section of rule given last output
+-- (preserving backreferences but emptying all other fields)
+newOutput :: MatchOutput -> MatchOutput
+newOutput m = MatchOutput
+    { matchedCatIxs = []
+    , matchedOptionals = []
+    , matchedWildcards = []
+    , matchedKleenes = []
+    , matchedGraphemes = []
+    , matchedFeatures = Map.empty
+    , matchedBackrefIds = matchedBackrefIds m
+    , matchedFeatureIds = matchedFeatureIds m
+    }
+
+-- | The empty 'MatchOutput'
+initialOutput :: MatchOutput
+initialOutput = MatchOutput [] [] [] [] [] Map.empty Map.empty Map.empty
+
 modifyMatchedGraphemes :: ([Grapheme] -> [Grapheme]) -> MatchOutput -> MatchOutput
 modifyMatchedGraphemes f MatchOutput{..} = MatchOutput{matchedGraphemes=f matchedGraphemes, ..}
 
 appendGrapheme :: MatchOutput -> Grapheme -> MatchOutput
 appendGrapheme out g = modifyMatchedGraphemes (++[g]) out
 
-instance Semigroup MatchOutput where
-    (MatchOutput a1 b1 c1 d1 e1) <> (MatchOutput a2 b2 c2 d2 e2) =
-        MatchOutput (a1++a2) (b1++b2) (c1++c2) (d1++d2) (e1++e2)
 
 zipWith' :: [a] -> [b] -> (a -> b -> c) -> [c]
 zipWith' xs ys f = zipWith f xs ys
@@ -144,15 +205,24 @@ insertAt :: Int -> a -> [a] -> [a]
 insertAt n a as = let (xs,ys) = splitAt n as in xs ++ (a:ys)
 
+insertAtOptional :: Int -> Bool -> MatchOutput -> MatchOutput
+insertAtOptional n o mz = mz { matchedOptionals = insertAt n o $ matchedOptionals mz }
+
 insertAtCat :: Int -> Int -> MatchOutput -> MatchOutput
 insertAtCat n i mz = mz { matchedCatIxs = insertAt n i $ matchedCatIxs mz }
 
 insertAtKleene :: Int -> Int -> MatchOutput -> MatchOutput
 insertAtKleene n i mz = mz { matchedKleenes = insertAt n i $ matchedKleenes mz }
 
+appendFeatureAt :: Int -> String -> FeatureState -> MatchOutput -> MatchOutput
+appendFeatureAt n name fs out = out { matchedFeatures = Map.alter go name $ matchedFeatures out }
+  where
+    go Nothing = Just [fs]
+    go (Just fss) = Just $ insertAt n fs fss
+
 -- | 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'.
+-- updated 'MatchOutput' tupled with the updated 'MultiZipper'.
 match :: MatchOutput          -- ^ The previous 'MatchOutput'
       -> Maybe Grapheme       -- ^ The previously-matched grapheme, if any. (Used to match a 'Geminate'.)
       -> Lexeme Expanded 'Matched  -- ^ The lexeme to match.
@@ -160,29 +230,91 @@       -> [(MatchOutput, MultiZipper t Grapheme)]
       -- ^ The output: a tuple @(g, mz)@ as described below.
 match out prev (Optional l) mz =
-    (out <> MatchOutput [] [False] [] [] [], mz) :
-    matchMany (out <> MatchOutput [] [True] [] [] []) prev l mz
+    let i = length (matchedOptionals out)
+    in
+        (insertAtOptional i False out, mz) :
+        matchMany (insertAtOptional i True out) prev l mz
+match out prev (GreedyOptional l) mz =
+    let i = length (matchedOptionals out)
+        m = matchMany (insertAtOptional i True out) prev l mz
+    in case m of
+        -- skip, but only if no matches
+        [] -> [(insertAtOptional i False out, mz)]
+        _ -> m
 match out prev (Wildcard l) mz = matchWildcard out prev l mz
 match out prev (Kleene l) mz = matchKleene out prev l mz
-match out _ (Grapheme g) mz = (out <> MatchOutput [] [] [] [] [g],) <$> maybeToList (matchGrapheme g mz)
+match out _ (Grapheme g) mz = (appendGrapheme out g,) <$> maybeToList (matchGrapheme g mz)
 match out prev (Category (FromElements gs)) mz =
-    concat $ zipWith' gs [0..] $ \e i ->
+    concat $ zipWith' gs [0..] $ \ls i ->
         -- make sure to insert new index BEFORE any new ones which
         -- might be added by the recursive call
         first (insertAtCat (length $ matchedCatIxs out) i) <$>
-            case e of
-                Left  g  -> match out prev (Grapheme g :: Lexeme Expanded a) mz
-                Right ls -> matchMany out prev ls mz
+            matchMany out prev ls mz
+match out prev (GreedyCategory c) mz =
+    -- Take first match only
+    case match out prev (Category c) mz of
+        [] -> []
+        (m:_) -> [m]
 match out prev Geminate mz = case prev of
     Nothing -> []
-    Just prev' -> (out <> MatchOutput [] [] [] [] [prev'],) <$> maybeToList (matchGrapheme prev' mz)
+    Just prev' -> (appendGrapheme out prev',) <$> maybeToList (matchGrapheme prev' mz)
+match out prev (Backreference (Left ident) (FromElements gs)) mz
+    | Nothing <- Map.lookup ident (matchedBackrefIds out) =
+        -- first occurrence, set backref
+        -- similar to Category case above
+        concat $ zipWith' gs [0..] $ \ls i ->
+            first (\o -> o { matchedBackrefIds = Map.insert ident i $ matchedBackrefIds o })
+                <$> matchMany out prev ls mz
 match out prev (Backreference i (FromElements gs)) mz = do
-    e <- maybeToList $
-        (gs !?) =<< matchedCatIxs out !? (i-1)
-    case e of
-        Left  g  -> match out prev (Grapheme g :: Lexeme Expanded a) mz
-        Right ls -> matchMany out prev ls mz
+    ls <- maybeToList $ case i of
+        Left i' -> (gs !?) =<< Map.lookup i' (matchedBackrefIds out)
+        Right i' -> (gs !?) =<< matchedCatIxs out !? (i'-1)
+    matchMany out prev ls mz
+match out prev (Feature r _n (Just ident) kvs l) mz
+    | Just fs <- Map.lookup ident (matchedFeatureIds out) = do
+        -- similar to next case, but just check that features are the same
+        -- (NB. feature name is irrelevant for this)
+        (out', mz') <- match out prev l mz
+        let fs' = case matchedGraphemes out' of
+                gs | Just g <- lastMay gs -> checkFeature kvs g
+                _ -> Indeterminate
+            satisfied = case (fs, fs') of
+                (Indeterminate, _) -> True
+                (_, Indeterminate) -> True
+                _  ->
+                    if r
+                    then fs /= fs'  -- reverse comparison
+                    else fs == fs'
+        if satisfied
+            then pure (out', mz')
+            else []
+match out prev (Feature _r n ident kvs l) mz = do
+    let i = maybe 0 length $ Map.lookup n (matchedFeatures out)
+    (out', mz') <- match out prev l mz
+    let fs = case matchedGraphemes out' of
+            gs | Just g <- lastMay gs -> checkFeature kvs g
+            _ -> Indeterminate
+    pure $ case ident of
+        Nothing -> (appendFeatureAt i n fs out', mz')
+        Just ident' ->
+            ( out' { matchedFeatureIds = Map.insert ident' fs $ matchedFeatureIds out' }
+            , mz'
+            )
+match out prev (Autosegment n kvs gs) mz =
+    -- act as 'Category' + 'Feature', without capture
+    -- and accounting for unmatchable values
+    gs >>= \g -> do
+        let i = maybe 0 length $ Map.lookup n (matchedFeatures out)
+        (out', mz') <- match out prev (Grapheme g) mz
+        let fs = checkFeature kvs (g, True)
+        pure (appendFeatureAt i n fs out', mz')
 
+checkFeature :: Eq a => [[a]] -> a -> FeatureState
+checkFeature [] _ = Indeterminate
+checkFeature (gs:gss) x
+    | Just i <- x `elemIndex` gs = Index i
+    | otherwise = checkFeature gss x
+
 matchKleene
     :: MatchOutput
     -> Maybe Grapheme
@@ -208,7 +340,7 @@   where
     go matched out prev l mz = case match out prev l mz of
         [] -> maybeToList (consume mz) >>= \case
-            (GBoundary, _) -> []   -- don't continue past word boundary
+            ("#", _) -> []   -- don't continue past word boundary
             (g, mz') -> go (g:matched) (appendGrapheme out g) prev l mz'
         r -> r <&> \(out', mz') ->
             ( out'
@@ -224,9 +356,7 @@ 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.
+-- 'MultiZipper'. Arguments and output are as with 'match'.
 matchMany :: MatchOutput
           -> Maybe Grapheme
           -> [Lexeme Expanded 'Matched]
@@ -237,13 +367,6 @@     match out prev l mz >>= \(out', mz') ->
     matchMany  out' (lastMay (matchedGraphemes out') <|> prev) ls mz'
 
--- | 'matchMany' without any previous match output.
-matchMany' :: Maybe Grapheme
-          -> [Lexeme Expanded 'Matched]
-          -> MultiZipper t Grapheme
-          -> [(MatchOutput, MultiZipper t Grapheme)]
-matchMany' = matchMany (MatchOutput [] [] [] [] [])
-
 -- Small utility function, not exported
 lastMay :: [a] -> Maybe a
 lastMay l = if null l then Nothing else Just (last l)
@@ -253,10 +376,11 @@     , ixInOptionals :: Int
     , ixInWildcards :: Int
     , ixInKleenes :: Int
+    , ixInFeatures :: Map.Map String Int
     , forcedCategory :: Maybe CategoryNumber
     } deriving (Show)
 
-data CategoryNumber = CategoryNumber Int | Nondeterministic
+data CategoryNumber = CategoryNumber Int | CategoryId String | Nondeterministic
     deriving (Show)
 
 advanceCategory :: ReplacementIndices -> Int -> (CategoryNumber, ReplacementIndices)
@@ -284,6 +408,12 @@     let i = ixInKleenes ix
     in (i, ix { ixInKleenes = i+1 })
 
+advanceFeature :: String -> ReplacementIndices -> Maybe (Int, ReplacementIndices)
+advanceFeature n ix =
+    case Map.lookup n (ixInFeatures ix) of
+        Nothing -> Just (0, ix { ixInFeatures = Map.insert n 1    $ ixInFeatures ix })
+        Just i  -> Just (i, ix { ixInFeatures = Map.adjust (+1) n $ ixInFeatures ix })
+
 forceCategory :: CategoryNumber -> ReplacementIndices -> ReplacementIndices
 forceCategory i ixs = ixs { forcedCategory = Just i }
 
@@ -302,7 +432,7 @@     -> [MultiZipper t Grapheme]
 mkReplacement out = \ls -> fmap (fst . snd) . go startIxs ls . (,Nothing)
   where
-    startIxs = ReplacementIndices 0 0 0 0 Nothing
+    startIxs = ReplacementIndices 0 0 0 0 Map.empty Nothing
 
     go
         :: ReplacementIndices
@@ -329,12 +459,19 @@                 case matchedCatIxs out !? ci of
                     Just i | Just g' <- gs !? i ->
                         case g' of
-                            Left g -> [(ixs', (insert g mz, Just g))]
-                            Right ls -> go ixs' ls (mz, prev)
-                    _ -> [(ixs', (insert (GMulti "\xfffd") mz, Nothing))]  -- Unicode replacement character
+                            [Grapheme g] -> [(ixs', (insert g mz, Just g))]
+                            ls -> go ixs' ls (mz, prev)
+                    _ -> [(ixs', (insert "\xfffd" mz, Nothing))]  -- Unicode replacement character
+            (CategoryId ci, ixs') ->  -- as above
+                case Map.lookup ci (matchedBackrefIds out) of
+                    Just i | Just g' <- gs !? i ->
+                        case g' of
+                            [Grapheme g] -> [(ixs', (insert g mz, Just g))]
+                            ls -> go ixs' ls (mz, prev)
+                    _ -> [(ixs', (insert "\xfffd" mz, Nothing))]  -- Unicode replacement character
             (Nondeterministic, ixs') -> gs >>= \case
-                Left g -> [(ixs', (insert g mz, Just g))]
-                Right ls -> go ixs' ls (mz, prev)
+                [Grapheme g] -> [(ixs', (insert g mz, Just g))]
+                ls -> go ixs' ls (mz, prev)
     replaceLex ixs (Optional ls) mz prev =
         let (co, ixs') = advanceOptional ixs in
             case matchedOptionals out !? co of
@@ -351,7 +488,10 @@     replaceLex ixs Discard mz prev =
         let (_, ixs') = advanceCategory ixs numCatsMatched
         in [(ixs', (mz, prev))]
-    replaceLex ixs (Backreference i c) mz prev =
+    replaceLex ixs (Backreference (Left i) c) mz prev =
+        let ixs' = forceCategory (CategoryId i) ixs
+        in replaceLex ixs' (Category c) mz prev
+    replaceLex ixs (Backreference (Right i) c) mz prev =
         let ixs' = forceCategory (CategoryNumber $ i-1) ixs -- 1-based indexing!
         in replaceLex ixs' (Category c) mz prev
     replaceLex ixs (Multiple c) mz prev =
@@ -368,34 +508,111 @@         in case matchedKleenes out !? i of
             Just n -> go ixs' (replicate n l) (mz, prev)
             Nothing -> [(ixs', (mz, prev))]
+    replaceLex ixs (Feature r n ident kvs l) mz prev =
+        let (fs, ixs') = case ident of
+                Nothing -> case advanceFeature n ixs of
+                    Just (i, ixs_)
+                        | Just fss <- Map.lookup n (matchedFeatures out)
+                        , Just fs_ <- fss !? i
+                        -> (fs_, ixs_)
+                    _ -> (Indeterminate, ixs)
+                Just ident' -> case Map.lookup ident' (matchedFeatureIds out) of
+                    Just fs_ -> (fs_, ixs)
+                    Nothing -> (Indeterminate, ixs)
+        in do
+            (ixs'', (mz', prev')) <- replaceLex ixs' l mz prev
+            case (kvs, prev') of
+                (gs:_, Just g) | g /= "#" -> do
+                    g' <- case fs of
+                        Index i -> applyFeature kvs g <$>
+                            if r
+                            then filter (/=i) [0 .. length gs - 1]
+                            else pure i
+                        Indeterminate -> applyFeature kvs g <$> [0 .. length gs - 1]
+                    -- now overwrite previous grapheme
+                    let mz'' = zap (Just . const g') mz'
+                    pure (ixs'', (mz'', Just g'))
+                -- cannot modify nonexistent or boundary grapheme,
+                -- or if there are zero key-value pairs
+                _ -> pure (ixs'', (mz', prev'))
+    replaceLex ixs (Autosegment _ _ []) mz prev = pure (ixs, (mz, prev))
+    replaceLex ixs (Autosegment n kvs (gBase:_)) mz prev =
+        -- ignore other segments, just produce a single one
+        -- as if modulated by a 'Feature', but accounting for Nothing values
+        let (fs, ixs') = case advanceFeature n ixs of
+                Just (i, ixs_)
+                    | Just fss <- Map.lookup n (matchedFeatures out)
+                    , Just fs_ <- fss !? i
+                    -> (fs_, ixs_)
+                _ -> (Indeterminate, ixs)
+        in do
+            (ixs'', (mz', prev')) <- replaceLex ixs' (Grapheme gBase) mz prev
+            case prev' of
+                Just g | g /= "#" -> do
+                    g' <- case fs of
+                        Index i
+                            | Just g'' <- applyFeature' kvs g i
+                            -> pure g''
+                        _ -> applyFeatureInd' kvs g
+                    -- now overwrite previous grapheme
+                    let mz'' = zap (Just . const g') mz'
+                    pure (ixs'', (mz'', Just g'))
+                -- cannot modify nonexistent or boundary grapheme,
+                -- or if there are zero key-value pairs
+                _ -> pure (ixs'', (mz', prev'))
 
+applyFeature :: [[String]] -> String -> Int -> String
+applyFeature [] g _ = g
+applyFeature (gs:gss) g i
+    | g `elem` gs = fromMaybe "\xfffd" $ gs !? i
+    | otherwise = applyFeature gss g i
+
+applyFeature' :: [[(String, Bool)]] -> String -> Int -> Maybe String
+applyFeature' [] g _ = Just g
+applyFeature' (gs:gss) g i = case lookup g gs of
+    Just _ -> case gs !? i of
+        Just (g', True) -> Just g'
+        Just (_, False) -> Nothing  -- this grapheme was excluded, need to act as if Indeterminate
+        Nothing -> Just "\xfffd"
+    Nothing -> applyFeature' gss g i
+
+applyFeatureInd' :: [[(String, Bool)]] -> String -> [String]
+applyFeatureInd' [] g = [g]
+applyFeatureInd' (gs:gss) g = case lookup g gs of
+    Just _ -> mapMaybe note gs
+    Nothing -> applyFeatureInd' gss g
+  where
+    note (a, True) = Just a
+    note _ = Nothing
+
 -- | 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'.
+-- position of the 'MultiZipper'; if it does, returns the index at
+-- which each matching target begins.
 exceptionAppliesAtPoint
-    :: [Lexeme Expanded 'Matched]
-    -> Environment Expanded
+    :: [Lexeme Expanded 'Matched]  -- ^ Target
+    -> Environment Expanded        -- ^ Exceptional environment
     -> MultiZipper RuleTag Grapheme -> [Int]
 exceptionAppliesAtPoint target (ex1, ex2) mz = fmap fst $ flip runRuleAp mz $ do
-    ex1Out <- RuleAp $ matchMany' Nothing ex1
+    ex1Out <- RuleAp $ matchMany initialOutput Nothing ex1
     pos <- gets curPos
-    MatchOutput{matchedGraphemes} <- RuleAp $ matchMany' Nothing target
-    _ <- RuleAp $ matchMany ex1Out (listToMaybe matchedGraphemes) ex2
+    targetOut@MatchOutput{matchedGraphemes} <- RuleAp $ matchMany (newOutput ex1Out) Nothing target
+    _ <- RuleAp $ matchMany (newOutput targetOut) (listToMaybe matchedGraphemes) ex2
     return pos
 
--- | Given a target and environment, determine if they 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.
+-- | Given a target and environment, determine if the rule matches at
+-- the current position of the 'MultiZipper'. If so, for each match,
+-- return the 'MatchOutput' and the output 'MultiZipper'. The output
+-- 'MultiZipper' is advanced past the matched environment, and has its
+-- 'RuleTag's set as appropriate.
 matchRuleAtPoint
-    :: [Lexeme Expanded 'Matched]
-    -> Environment Expanded
+    :: [Lexeme Expanded 'Matched]  -- ^ Target
+    -> Environment Expanded        -- ^ Environment
     -> MultiZipper RuleTag Grapheme
     -> [(MatchOutput, MultiZipper RuleTag Grapheme)]
 matchRuleAtPoint target (env1,env2) mz = flip runRuleAp mz $ do
-    env1Out <- RuleAp $ matchMany' Nothing env1
+    let initMO = MatchOutput [] [] [] [] [] Map.empty Map.empty Map.empty
+    env1Out <- RuleAp $ matchMany initMO Nothing env1
     -- start of target needs to be INSIDE 'MultiZipper'!
     -- otherwise get weird things like /x/#_ resulting in
     -- #abc#→#xabd#x when it should be #abc#→#xabc#
@@ -403,22 +620,29 @@         True -> RuleAp $ const []
         False -> do
             modify $ tag TargetStart
-            matchResult <- RuleAp $ matchMany' Nothing target
+            matchResult <- RuleAp $ matchMany (newOutput env1Out) Nothing target
             modify $ tag TargetEnd
-            _ <- RuleAp $ matchMany env1Out (listToMaybe $ matchedGraphemes matchResult) env2
+            env2Out <- RuleAp $ matchMany (newOutput matchResult)
+                (listToMaybe $ matchedGraphemes matchResult) env2
+            -- environment can affect replacement via IDs
+            -- only, so collect those
             return matchResult
+                { matchedFeatureIds = matchedFeatureIds env2Out
+                , matchedBackrefIds = matchedBackrefIds env2Out
+                }
 
+-- | Status of a rule application at a single location.
 data RuleStatus
-    = SuccessNormal      -- ^ Rule was successful, no need for special handling
-    | SuccessEpenthesis  -- ^ Rule was successful, but cursor was not advanced: need to avoid infinite loop
+    = SuccessNormal      -- ^ Rule was successful, with no need for special handling
+    | SuccessEpenthesis  -- ^ Rule was successful, but cursor was not advanced (need to avoid infinite loop)
     | Failure            -- ^ Rule failed
     deriving (Eq, Show)
 
 -- | Given a 'Rule', determine if the rule matches at the current
 -- point; if so, apply the rule, adding appropriate tags.
 applyOnce :: Rule Expanded -> StateT (MultiZipper RuleTag Grapheme) [] RuleStatus
-applyOnce r@Rule{target, replacement, exception} =
-    modify (tag AppStart) >> go (environment r)
+applyOnce Rule{..} =
+    modify (tag AppStart) >> go environment
   where
     go [] = return Failure
     go (env:envs) = do
@@ -429,19 +653,28 @@                     Nothing -> pure []
                     Just ex -> gets $ join . toList .
                         extend' (exceptionAppliesAtPoint target ex)
-                gets (locationOf TargetStart) >>= \p ->
-                    if maybe True (`elem` exs) p
-                    then return Failure
-                    else do
-                        originalWord <- get
+                originalWord <- get
+                let pMay = locationOf TargetStart originalWord
+                    pMay' = locationOf PrevEnd originalWord
+                case pMay of
+                    Nothing -> error "applyOnce: start of target was not tagged"
+                    Just p
+                        | p `elem` exs -> return Failure
+                        -- do not apply rule if it would be
+                        -- applied twice to the same substring
+                        | Just p' <- pMay', p < p' -> return Failure
+                        | otherwise -> do
                         modifyMay $ delete (TargetStart, TargetEnd)
                         modifyMay $ seek TargetStart
                         modifyM $ \w ->
                             let replacedWords = mkReplacement out replacement w
-                            in case sporadic (flags r) of
+                            in case sporadic flags of
                                 -- make sure to re-insert original word
                                 PerApplication -> originalWord : replacedWords
                                 _ -> replacedWords
+                        -- we want TargetEnd to move forward as the replacement is added,
+                        -- but not TargetStart, so restore its old position
+                        modifyMay $ tagAt TargetStart p
                         return $
                             -- An epenthesis rule will cause an infinite loop
                             -- if it matched no graphemes before the replacement
@@ -457,232 +690,293 @@     -> Rule Expanded
     -> MultiZipper RuleTag Grapheme
     -> Maybe (MultiZipper RuleTag Grapheme)
-setupForNextApplication status Rule{flags=Flags{applyDirection}} =
-    fmap untag . case applyDirection of
-        RTL -> seek AppStart >=> bwd
-        LTR -> case status of
-            SuccessNormal -> seek TargetEnd
-            SuccessEpenthesis ->
-                -- need to move forward if applying an epenthesis rule to avoid an infinite loop
-                seek TargetEnd >=> fwd
-            Failure -> seek AppStart >=> fwd
+setupForNextApplication status Rule{flags=Flags{nonOverlappingTarget}} =
+    resetTags <=< case status of
+        SuccessNormal ->
+            seek (if nonOverlappingTarget then TargetEnd else TargetStart)
+        SuccessEpenthesis ->
+            -- need to move forward if applying an epenthesis rule to avoid an infinite loop
+            seek TargetEnd >=> fwd
+        Failure -> seek AppStart >=> fwd
+  where
+    resetTags mz =
+        -- update PrevEnd to farthest replaced position on success,
+        -- or keep it the same on failure
+        let p = locationOf TargetEnd mz
+            p' = locationOf PrevEnd mz
+            newPrevEnd = case status of
+                Failure -> p'
+                _ -> max p p'
+        in maybe Just (tagAt PrevEnd) newPrevEnd $ untag mz
 
 -- | 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 Expanded -> MultiZipper RuleTag Grapheme -> [MultiZipper RuleTag Grapheme]
-applyRule r = \mz ->    -- use a lambda so mz isn't shadowed in the where block
-    let startingPos = case applyDirection $ flags r of
-            LTR -> toBeginning mz
-            RTL -> toEnd mz
-        result = repeatRule (applyOnce r) startingPos
+--
+-- Note: unlike 'applyRuleStr', this can produce duplicate outputs.
+applyRuleMZ :: Rule Expanded -> MultiZipper RuleTag Grapheme -> [MultiZipper RuleTag Grapheme]
+applyRuleMZ r = \mz ->    -- use a lambda so mz isn't shadowed in the where block
+    let result = case applyDirection (flags r) of
+            LTR -> repeatRule $ toBeginning mz
+            -- Apply RTL by reversing both rule and word
+            RTL -> fmap reverseMZ $ repeatRule $ toBeginning $ reverseMZ mz
     in case sporadic (flags r) of
         PerWord -> mz : result
         _ -> result  -- PerApplication handled in 'applyOnce'
   where
+    r' = case applyDirection (flags r) of
+        LTR -> r
+        RTL -> Rule
+            { target = reverse $ target r
+            , replacement = reverse $ replacement r
+            , environment = reverseEnv <$> environment r
+            , exception = reverseEnv <$> exception r
+            , flags = flags r
+            , plaintext = plaintext r
+            }
+
+    reverseEnv (e1, e2) = (reverse e2, reverse e1)
+
     repeatRule
-        :: StateT (MultiZipper RuleTag Grapheme) [] RuleStatus
-        -> MultiZipper RuleTag Grapheme
+        :: MultiZipper RuleTag Grapheme
         -> [MultiZipper RuleTag Grapheme]
-    repeatRule m mz = runStateT m mz >>= \(status, mz') ->
-        if (status /= Failure) && applyOnceOnly (flags r)
+    repeatRule mz = runStateT (applyOnce r') mz >>= \(status, mz') ->
+        if (status /= Failure) && applyOnceOnly (flags r')
         then [mz']
-        else case setupForNextApplication status r mz' of
-            Just mz'' -> repeatRule m mz''
-            Nothing -> [mz']
+        else maybe [mz'] repeatRule (setupForNextApplication status r' mz')
 
 -- | Check if a 'MultiZipper' matches a 'Filter'.
 filterMatches :: Filter Expanded -> MultiZipper RuleTag Grapheme -> Bool
 filterMatches (Filter _ ls) = go . toBeginning
   where
     go mz =
-        let mzs = matchMany' Nothing ls mz
+        let mzs = matchMany initialOutput Nothing ls mz
         in case mzs of
             [] -> maybe False go $ fwd mz  -- try next position if there is one
             _ -> True  -- filter has matched
 
 -- | Check that the 'MultiZipper' contains only graphemes listed in
--- the given 'CategoriesDecl', replacing all unlisted graphemes with
--- U+FFFD.
+-- the given list, replacing all unlisted graphemes other than @"#"@
+-- with U+FFFD.
 checkGraphemes :: [Grapheme] -> MultiZipper RuleTag Grapheme -> MultiZipper RuleTag Grapheme
 checkGraphemes gs = fmap $ \case
-    GBoundary -> GBoundary
-    g -> if g `elem` gs then g else GMulti "\xfffd"
+    "#" -> "#"
+    g -> if g `elem` gs then g else "\xfffd"
 
 -- | Apply a 'Statement' to a 'MultiZipper', returning zero, one or
 -- more results.
-applyStatement
-    :: Statement Expanded [Grapheme]
+applyStatementMZ
+    :: Statement Expanded GraphemeList
     -> MultiZipper RuleTag Grapheme
     -> [MultiZipper RuleTag Grapheme]
-applyStatement (RuleS r) mz = applyRule r mz
-applyStatement (FilterS f) mz
+applyStatementMZ (RuleS r) mz = applyRuleMZ r mz
+applyStatementMZ (FilterS f) mz
     | filterMatches f mz = []
     | otherwise = [mz]
-applyStatement (DirectiveS gs) mz = [checkGraphemes gs mz]
+applyStatementMZ ReportS mz = [mz]
+applyStatementMZ (DeclS (GraphemeList noreplace gs)) mz
+    | noreplace = [mz]
+    | otherwise = [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.
+-- | Apply a single sound change 'Rule' to a word.
 applyRuleStr :: Rule Expanded -> PWord -> [PWord]
 -- Note: 'fromJust' is safe here as 'apply' should always succeed
 applyRuleStr r =
     addBoundaries
     >>> fromListStart
-    >>> applyRule r
+    >>> applyRuleMZ r
     >>> fmap (toList >>> removeBoundaries)
     >>> nubOrd
 
--- | 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 Expanded [Grapheme] -> PWord -> [PWord]
+-- | Apply a single 'Statement' to a word. The statement can be a
+-- sound change, a filter, or any other element which remains in a
+-- sound change file after expansion.
+applyStatementStr :: Statement Expanded GraphemeList -> PWord -> [PWord]
 applyStatementStr st =
     addBoundaries
     >>> fromListStart
-    >>> applyStatement st
+    >>> applyStatementMZ st
     >>> fmap (toList >>> removeBoundaries)
     >>> nubOrd
 
--- | 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 :: Maybe PWord
-    } deriving (Show, Functor, Generic, NFData)
+-- | A log item representing a single action @r@ (usually a
+-- 'Statement'), and the result from that action.
+data LogItem r
+    = ActionApplied r (Maybe PWord)
+    -- ^ The word was modified: gives the output word, or 'Nothing' if
+    -- the wordwas deleted
+    | ReportWord PWord
+    -- ^ Corresponds to 'ReportS', giving the intermediate form to report
+    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 :: [(Maybe 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)
+-- action :: LogItem r -> Maybe r
+-- action (ActionApplied r _ _) = Just r
+-- action (ReportWord _) = Nothing
 
-toPWordLog :: [LogItem r] -> Maybe (PWordLog r)
-toPWordLog [] = Nothing
-toPWordLog ls@(l : _) = Just $ PWordLog
-    { initialWord = input l
-    , derivations = (\ActionApplied{..} -> (output, action)) <$> ls
-    }
+logOutput :: LogItem r -> Maybe PWord
+logOutput (ActionApplied _ o) = o
+logOutput (ReportWord o) = Just o
 
--- | Render a single 'PWordLog' to rows of an HTML table. For
+-- | Logs the evolution of a word as it undergoes sound changes and
+-- other actions.
+data Log r = Log
+    { inputWord :: PWord
+    -- ^ The input word, before any actions have been applied
+    , derivations :: [LogItem r]
+    -- ^ All actions which were applied, with the state of the word at
+    -- each point
+    } deriving (Show, Functor, Generic, NFData)
+
+-- | Pretty-print a single 'Log' as 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>"
+-- > <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:
+-- Which might be displayed in a browser as follows:
 --
--- +------+---+-------+-------------+ 
+-- +------+---+-------+-------------+
 -- | tara | → | tazha | (r / zh)    |
--- +------+---+-------+-------------+ 
+-- +------+---+-------+-------------+
 -- |      | → | tazh  | (V / / _ #) |
--- +------+---+-------+-------------+ 
+-- +------+---+-------+-------------+
 
-reportAsHtmlRows :: (r -> String) -> PWordLog r -> String
-reportAsHtmlRows render item = go (concatWithBoundary $ initialWord item) (derivations item)
+reportAsHtmlRows
+    :: (r -> String)  -- ^ Specifies how to pretty-print actions as text
+    -> Log r -> String
+reportAsHtmlRows render item = go (concatWithBoundary $ inputWord item) (derivations item)
   where
     go _ [] = ""
-    go cell1 ((output, action) : ds) =
+    go cell1 (ActionApplied action output : ds) =
         ("<tr><td>" ++ cell1 ++ "</td><td>&rarr;</td><td>"
          ++ maybe "<i>deleted</i>" concatWithBoundary output
          ++ "</td><td>(" ++ render action ++ ")</td></tr>")
         ++ go "" ds
+    go cell1 (ReportWord w : ds) =
+        ("<tr><td>" ++ cell1 ++ "</td><td>&rarr;</td><td>"
+         ++ concatWithBoundary w
+         ++ "</td><td>(report)</td></tr>")
+        ++ go "" ds
 
--- | Render a single 'PWordLog' to plain text. For instance, this log:
+-- | Pretty-print a 'Log' as plain text. For instance, this log:
 --
--- > PWordLog
--- >   { initialWord = ["t", "a", "r", "a"]
--- >   , derivations =
--- >     [ (["t", "a", "zh", "a"], "r / zh")
--- >     , (["t", "a", "zh"], "V / / _ #")
--- >     ]
--- >   }
+-- @
+-- 'Log'
+--   { 'inputWord' = ["t", "a", "r", "a"]
+--   , 'derivations' =
+--     [ ('Just' ["t", "a", "zh", "a"], "r \/ zh")
+--     , ('Just' ["t", "a", "zh"], "V \/ \/ _ #")
+--     ]
+--   }
+-- @
 --
--- Would render as:
+-- Would be pretty-printed by @'reportAsText' 'id'@ as:
 --
 -- > tara
 -- >   -> tazha  (r / zh)
 -- >   -> tazh   (V / / _ #)
-reportAsText :: (r -> String) -> PWordLog r -> String
+reportAsText
+    :: (r -> String)  -- ^ Specifies how to pretty-print actions as text
+    -> Log r -> String
 reportAsText render item = unlines $
-    concatWithBoundary (initialWord item) : fmap toLine (alignWithPadding $ derivations item)
+    concatWithBoundary (inputWord item) : fmap toLine (alignWithPadding $ derivations item)
   where
-    alignWithPadding :: [(Maybe PWord, b)] -> [([Char], b)]
     alignWithPadding ds =
-        let (rawOutputs, actions) = unzip ds
+        let (rawOutputs, actions) = unzip $ toPrintable <$> ds
             outputs = maybe "(deleted)" concatWithBoundary <$> rawOutputs
             maxlen = maximum $ length <$> outputs
             padded = outputs <&> \o -> o ++ replicate (maxlen - length o) ' '
         in zip padded actions
 
-    toLine (output, action) = "  -> " ++ output ++ "  (" ++ render action ++ ")"
+    toLine (output, action) = "  -> " ++ output ++ "  (" ++ action ++ ")"
 
+    toPrintable (ActionApplied a o) = (o, render a)
+    toPrintable (ReportWord w) = (Just w, "report")
+
 -- | 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 Expanded [Grapheme]
+applyStatement
+    :: Statement Expanded GraphemeList
     -> PWord
-    -> [LogItem (Statement Expanded [Grapheme])]
-applyStatementWithLog st w = case applyStatementStr st w of
-    [] -> [ActionApplied st w Nothing]
+    -> [LogItem (Statement Expanded GraphemeList)]
+applyStatement ReportS w = [ReportWord w]
+applyStatement st w = case applyStatementStr st w of
+    [] -> [ActionApplied st Nothing]
     [w'] | w' == w -> []
-    r -> ActionApplied st w . Just <$> r
+    r -> ActionApplied st . Just <$> r
 
--- | Apply 'SoundChanges' to a word. For each possible result, returns
--- a 'LogItem' for each 'Statement' which altered the input.
-applyChangesWithLog
-    :: SoundChanges Expanded [Grapheme]
+-- | Apply a set of 'SoundChanges' to a word, returning a log of which
+-- sound changes applied to produce each output word.
+applyChanges
+    :: SoundChanges Expanded GraphemeList
     -> PWord
-    -> [[LogItem (Statement Expanded [Grapheme])]]
-applyChangesWithLog [] _ = [[]]
-applyChangesWithLog (st:sts) w =
-    case applyStatementWithLog st w of
-        [] -> applyChangesWithLog sts w
-        outputActions -> outputActions >>= \l@ActionApplied{output} ->
-            case output of
-                Just w' -> (l :) <$> applyChangesWithLog sts w'
-                -- apply no further changes to a deleted word
-                Nothing -> [[l]]
+    -> [Log (Statement Expanded GraphemeList)]
+applyChanges scs w = go scs w <&> \ls -> Log
+    { inputWord = w
+    , derivations = ls
+    }
+  where
+    go [] _ = [[]]   -- one result, no changes applied
+    go (st:sts) w' =
+        case applyStatement st w' of
+            [] -> go sts w'
+            outputActions -> outputActions >>= \case
+                l@(ReportWord w'') -> (l :) <$> go sts w''
+                l@(ActionApplied _ output) -> case output of
+                    Just w'' -> (l :) <$> go sts w''
+                    -- apply no further changes to a deleted word
+                    Nothing -> [[l]]
 
--- | Apply 'SoundChanges' to a word, returning an 'PWordLog'
--- for each possible result.
-applyChangesWithLogs
-    :: SoundChanges Expanded [Grapheme]
-    -> PWord
-    -> [PWordLog (Statement Expanded [Grapheme])]
-applyChangesWithLogs scs w = mapMaybe toPWordLog $ applyChangesWithLog  scs w
+-- | Returns the final output from a sound change log.
+getOutput :: Log r -> Maybe PWord
+getOutput l = case derivations l of
+    d@(_:_) -> logOutput $ last d
+    [] -> Just $ inputWord l
 
--- | Apply a set of 'SoundChanges' to a word.
-applyChanges :: SoundChanges Expanded [Grapheme] -> PWord -> [PWord]
-applyChanges sts w =
-    mapMaybe lastOutput $ applyChangesWithLog sts w
+-- | Returns, in order: the input word, any intermediate results from
+-- 'ReportS', and then the final output.
+getReports :: Log r -> [PWord]
+getReports l = inputWord l : go (derivations l)
   where
-    -- If no changes were applied, output is same as input
-    lastOutput [] = Just w
-    lastOutput ls = output $ last ls
+    go [] = []
+    go [ActionApplied _ (Just w')] = [w']
+    go (ReportWord w':ls) = w' : go ls
+    go (_:ls) = go 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 Expanded [Grapheme] -> PWord -> [(Maybe PWord, Bool)]
-applyChangesWithChanges sts w = applyChangesWithLog sts w <&> \case
-    [] -> (Just w, False)
-    logs -> (output $ last logs, hasChanged logs)
+-- | Returns the final output from a sound change log, as well as an
+-- indication of whether any sound changes have applied to it
+-- (accounting for 'highlightChanges' flags).
+getChangedOutputs :: Log (Statement c d) -> Maybe (PWord, Bool)
+getChangedOutputs l = case derivations l of
+    [] -> Just (inputWord l, False)
+    logs -> case logOutput (last logs) of
+        Just out -> Just (out, hasChanged logs)
+        Nothing -> Nothing
   where
     hasChanged = any $ \case
-        ActionApplied (RuleS rule) _ _ -> highlightChanges $ flags rule
-        ActionApplied (FilterS _) _ _ -> False  -- cannot highlight nonexistent word
-        ActionApplied (DirectiveS _) _ _ -> True
+        ActionApplied (RuleS rule) _ -> highlightChanges $ flags rule
+        ActionApplied (FilterS _) _ -> False  -- cannot highlight nonexistent word
+        ActionApplied (DeclS _) _ -> True
+        ActionApplied ReportS _ -> False  -- reporting a word yields no change
+        ReportWord _ -> False
+
+-- | A combination of 'getOutput' and 'getChangedOutputs': returns all
+-- intermediate results, as well as whether each has undergone any
+-- sound changes.
+getChangedReports :: Log (Statement c d) -> [(PWord, Bool)]
+getChangedReports l = (inputWord l, False) : case derivations l of
+    [] -> []
+    ls -> go False ls
+  where
+    go _ [] = []
+    go hasChanged (ActionApplied action _:ls) =
+        let hasChanged' = case action of
+                RuleS rule -> hasChanged || highlightChanges (flags rule)
+                _ -> hasChanged
+        in go hasChanged' ls
+    go hasChanged (ReportWord w':ls) = (w', hasChanged) : go hasChanged ls
+
+-- | Apply a set of 'SoundChanges' to a word, returning the final
+-- output word(s) as well as any intermediate results from 'ReportS',
+-- each with a boolean marking changed results (as with 'applyChangesWithChanges').

@@ -1,11 +1,16 @@ {-# LANGUAGE DeriveTraversable #-}
 {-# 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.Apply.Internal.MultiZipper
+-- Copyright   : See LICENSE file
+-- License     : BSD3
+-- Maintainer  : Brad Neimann
+--
+-- __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
@@ -32,6 +37,7 @@        -- * Modification
        , insert
        , insertMany
+       , reverseMZ
        , zap
        , tag
        , tagAt
@@ -63,11 +69,11 @@ -- 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'.)
+-- it makes sound changes application easier to implement. In
+-- particular, it means that functions processing a portion of a
+-- 'MultiZipper' can finish by moving to the next element immediately
+-- after the processed portion; any subsequent function will then
+-- continue by processing the next part of the 'MultiZipper'.)
 data MultiZipper t a = MultiZipper (V.Vector a) Int (M.Map t Int)
     deriving (Show, Functor, Foldable, Traversable)
 
@@ -87,6 +93,16 @@ -- | Get the list stored in a 'MultiZipper'.
 toList :: MultiZipper t a -> [a]
 toList (MultiZipper as _ _) = V.toList as
+
+-- | Reverse the contents of a 'MultiZipper', ensuring its current
+-- position and tags remain attatched to their elements.
+reverseMZ :: MultiZipper t a -> MultiZipper t a
+reverseMZ (MultiZipper as pos ts) =
+    let l = length as
+    in MultiZipper
+        (V.reverse as)
+        (l - pos)
+        (M.map (l-) ts)
 
 -- | The current position of the 'MultiZipper'.
 curPos :: MultiZipper t a -> Int

@@ -1,181 +0,0 @@-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE TupleSections #-}
-
-module Brassica.SoundChange.Category
-       ( Categories
-       , Brassica.SoundChange.Category.lookup
-       , values
-       , ExpandError(..)
-       , expand
-       , expandRule
-       , extendCategories
-       , expandSoundChanges
-       ) where
-
-import Prelude hiding (lookup)
-import Control.DeepSeq (NFData)
-import Control.Monad (foldM, unless)
-import Control.Monad.State.Strict (StateT, evalStateT, lift, get, put, gets)
-import Data.Containers.ListUtils (nubOrd)
-import Data.List (intersect, transpose, foldl')
-import Data.Maybe (mapMaybe, catMaybes)
-import GHC.Generics (Generic)
-
-import qualified Data.Map.Strict as M
-
-import Brassica.SoundChange.Types
-import Data.Traversable (for)
-
--- | A map from names to the (expanded) categories they
--- reference. Used to resolve cross-references between categories.
-type Categories = M.Map String (Expanded 'AnyPart)
-
--- | Lookup a category name in 'Categories'.
-lookup :: String -> Categories -> Maybe (Expanded a)
-lookup = (fmap generaliseExpanded .) . M.lookup
-
--- | Returns a list of every value mentioned in a set of
--- 'Categories'
-values :: Categories -> [Either Grapheme [Lexeme Expanded 'AnyPart]]
-values = nubOrd . concatMap elements . M.elems
-
--- Errors which can be emitted while inlining or expanding category
--- definitions.
-data ExpandError
-    = NotFound String
-      -- ^ A category with that name was not found
-    | InvalidBaseValue
-      -- ^ A 'Lexeme' was used as a base value in a feature
-    | MismatchedLengths
-      -- ^ A 'FeatureSpec' contained a mismatched number of values
-    deriving (Show, Generic, NFData)
-
--- | Given a category, return the list of values which it
--- matches.
-expand :: Categories -> CategorySpec a -> Either ExpandError (Expanded a)
-expand cs (MustInline g) = maybe (Left $ NotFound g) Right $ lookup g cs
-expand cs (CategorySpec spec) = FromElements <$> foldM go [] spec
-  where
-    go es (modifier, e) = do
-        new <- case e of
-            Left (GMulti g)
-                | Just (FromElements c) <- lookup g cs
-                -> pure c
-                | otherwise -> pure [Left (GMulti g)]
-            Left GBoundary -> pure [Left GBoundary]
-            Right ls -> pure . Right <$> traverse (expandLexeme cs) ls
-        pure $ case modifier of
-            Union -> es ++ new
-            Intersect -> es `intersect` new
-            Subtract -> es `subtractAll` new
-
-    -- NB. normal (\\) only removes the first matching element
-    subtractAll xs ys = filter (`notElem` ys) xs
-
-expandLexeme :: Categories -> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
-expandLexeme cs (Grapheme (GMulti g))
-    | Just (g', '~') <- unsnoc g
-        = Right $ Grapheme $ GMulti g'
-    | otherwise = Right $
-        case lookup g cs of
-            Just c -> Category c
-            Nothing -> Grapheme (GMulti g)
-  where
-    -- taken from base-4.19
-    unsnoc :: [a] -> Maybe ([a], a)
-    unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing
-    {-# INLINABLE unsnoc #-}
-
-expandLexeme _  (Grapheme GBoundary) = Right $ Grapheme GBoundary
-expandLexeme cs (Category c) = Category <$> expand cs c
-expandLexeme cs (Optional ls) = Optional <$> traverse (expandLexeme cs) ls
-expandLexeme _  Metathesis = Right Metathesis
-expandLexeme _  Geminate = Right Geminate
-expandLexeme cs (Wildcard l) = Wildcard <$> expandLexeme cs l
-expandLexeme cs (Kleene l) = Kleene <$> expandLexeme cs l
-expandLexeme _  Discard = Right Discard
-expandLexeme cs (Backreference i c) = Backreference i <$> expand cs c
-expandLexeme cs (Multiple c) = Multiple <$> expand cs c
-
-expandRule :: Categories -> Rule CategorySpec -> Either ExpandError (Rule Expanded)
-expandRule cs r = Rule
-    <$> traverse (expandLexeme cs) (target r)
-    <*> traverse (expandLexeme cs) (replacement r)
-    <*> traverse expandEnvironment (environment r)
-    <*> traverse expandEnvironment (exception r)
-    <*> pure (flags r)
-    <*> pure (plaintext r)
-  where
-    expandEnvironment (e1, e2) = (,)
-        <$> traverse (expandLexeme cs) e1
-        <*> traverse (expandLexeme cs) e2
-
-expandFilter :: Categories -> Filter CategorySpec -> Either ExpandError (Filter Expanded)
-expandFilter cs (Filter p f) = Filter p <$> traverse (expandLexeme cs) f
-
-extendCategories
-    :: Categories
-    -> (Bool, [CategoryDefinition])  -- ^ The fields of a v'Categories' directive
-    -> Either ExpandError Categories
-extendCategories cs' (overwrite, defs) =
-    foldM go (if overwrite then M.empty else cs') defs
-  where
-    go :: Categories -> CategoryDefinition -> Either ExpandError Categories
-    go cs (DefineCategory name val) = flip (M.insert name) cs <$> expand cs val
-    go cs (DefineFeature spec) = do
-        baseValues <- expand cs $ featureBaseValues spec
-        derivedCats <- traverse (traverse $ expand cs) $ featureDerived spec
-
-        baseValues' <- for (elements baseValues) $ \case
-            Left (GMulti g) -> Right g
-            _ -> Left InvalidBaseValue
-        let baseLen = length baseValues'
-            derivedValues = elements . snd <$> derivedCats
-        unless (all ((==baseLen) . length) derivedValues) $
-            Left MismatchedLengths
-
-        let features = zipWith
-               (\base ds -> (base, FromElements $ Left (GMulti base) : ds))
-               baseValues'
-               (transpose derivedValues)
-            newCats =
-                maybe [] (pure . (,baseValues)) (featureBaseName spec)
-                ++ derivedCats
-                ++ features
-        Right $ foldl' (flip $ uncurry M.insert) cs newCats
-
-expandSoundChanges
-    :: SoundChanges CategorySpec Directive
-    -> Either ExpandError (SoundChanges Expanded [Grapheme])
-expandSoundChanges = fmap catMaybes . flip evalStateT (M.empty, []) . traverse go
-  where
-    go  :: Statement CategorySpec Directive
-        -> StateT
-            (Categories, [String])
-            (Either ExpandError)
-            (Maybe (Statement Expanded [Grapheme]))
-    go (RuleS r) = do
-        cs <- gets fst
-        lift $ Just . RuleS <$> expandRule cs r
-    go (FilterS f) = do
-        cs <- gets fst
-        lift $ Just . FilterS <$> expandFilter cs f
-    go (DirectiveS (ExtraGraphemes extra)) = do
-        (cs, _) <- get
-        put (cs, extra)
-        pure Nothing
-    go (DirectiveS (Categories overwrite noreplace defs)) = do
-        (cs, extra) <- get
-        cs' <- lift $ extendCategories cs (overwrite, defs)
-        put (cs', extra)
-        pure $ if noreplace
-            then Nothing
-            else Just $ DirectiveS $ fmap GMulti extra ++ mapMaybe left (values cs')
-
-    left (Left l) = Just l
-    left (Right _) = Nothing

@@ -0,0 +1,373 @@+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TupleSections #-}
+
+-- |
+-- Module      : Brassica.SoundChange.Expand
+-- Copyright   : See LICENSE file
+-- License     : BSD3
+-- Maintainer  : Brad Neimann
+--
+-- This module implements the process of /expansion/, from Brassica’s
+-- surface syntax to a simpler representation in which all categories,
+-- features and autosegments have been inlined. For further
+--
+-- In the surface syntax, each category is represented as a
+-- 'CategorySpec', a description in terms of predefined categories
+-- combined with category operations. Expansion converts each one to
+-- an 'Expanded' list of graphemes.
+--
+-- Similarly, category definitions are parsed as 'Directive's. Once
+-- inlined, these can be replaced with simple 'GraphemeList's to be
+-- used for filtering graphemes.
+module Brassica.SoundChange.Expand
+       (
+       -- * Main function
+         expandSoundChanges
+       , ExpandError(..)
+       -- * Expanding individual elements
+       , expand
+       , expandRule
+       , extendCategories
+       -- * Categories
+       , Categories
+       , AutosegmentDef(..)
+       , Brassica.SoundChange.Expand.lookup
+       , values
+       ) where
+
+import Prelude hiding (lookup)
+import Control.DeepSeq (NFData)
+import Control.Monad (foldM, unless)
+import Control.Monad.State.Strict (StateT, evalStateT, lift, get, put, gets)
+import Data.Bifunctor (first, second)
+import Data.Containers.ListUtils (nubOrd)
+import Data.List (transpose, foldl', stripPrefix)
+import Data.Maybe (mapMaybe, catMaybes)
+import Data.Traversable (for)
+import GHC.Generics (Generic)
+
+import qualified Data.Map.Strict as M
+import qualified Data.Map.Merge.Strict as M
+
+import Brassica.SoundChange.Types
+
+-- | Expanding an autosegment from a grapheme requires knowing its
+-- feature name, and a set of graphemes cross-cutting that feature.
+-- (Note that 'autoGraphemes' includes the originally-written
+-- grapheme.)
+data AutosegmentDef = AutosegmentDef
+    { autoFeature :: String
+    , autoGraphemes :: [String]
+    }
+    deriving (Eq, Show)
+
+-- | A map from names to the (expanded) categories or autosegments
+-- they reference. Used to resolve cross-references between
+-- categories.
+type Categories = M.Map String (Either (Expanded 'AnyPart) AutosegmentDef)
+
+-- | Lookup a category name in t'Categories'.
+lookup :: String -> Categories -> Maybe (Either (Expanded a) AutosegmentDef)
+lookup = (fmap (first generaliseExpanded) .) . M.lookup
+
+-- | Returns a list of every value mentioned in a set of
+-- t'Categories'
+values :: Categories -> [[Lexeme Expanded 'AnyPart]]
+values = nubOrd . concatMap (either elements autoElements) . M.elems
+  where
+    autoElements = fmap (pure . Grapheme) . autoGraphemes
+
+-- | Errors which can be emitted while inlining or expanding category
+-- definitions.
+data ExpandError
+    = NotFound String
+      -- ^ A category with the given name was not found
+    | InvalidBaseValue
+      -- ^ A 'Lexeme' was used as a base value in a feature
+    | InvalidDerivedValue
+      -- ^ A 'Lexeme' was used as a derived value in an autosegment
+    | MismatchedLengths
+      -- ^ A phonetic feature or 'FeatureSpec' contained a mismatched number of values
+    deriving (Show, Generic, NFData)
+
+-- | Given an unexpanded category, return the list of values which it
+-- matches.
+expand :: Categories -> CategorySpec a -> Either ExpandError (Expanded a)
+expand cs (MustInline g) = case lookup g cs of
+    Just (Left expanded) -> Right expanded
+    _ -> Left $ NotFound g
+expand cs (CategorySpec spec) = FromElements <$> foldM go [] spec
+  where
+    go :: [CategoryElement Expanded a]
+                  -> (CategoryModification, CategoryElement CategorySpec a)
+                  -> Either ExpandError [CategoryElement Expanded a]
+    go es (modifier, e) = do
+        (new, modifier') <- case e of
+            [Grapheme g]
+                | Just (g', '~') <- unsnoc g
+                    -> pure ([[Grapheme g']], modifier)
+                | modifier == Intersect
+                , Just (Left (FromElements c)) <- lookup ('+':g) cs
+                    -> pure (c, Intersect)
+                | modifier == Subtract
+                , Just (Left (FromElements c)) <- lookup ('-':g) cs
+                    -> pure (c, Intersect)  -- do intersection with negative instead!
+                | '&':g' <- g
+                , Just (Left (FromElements p)) <- lookup ('+':g') cs
+                , Just (Left (FromElements n)) <- lookup ('-':g') cs
+                    -> pure (n++p, modifier)
+                | Just (Left (FromElements c)) <- lookup g cs
+                    -> pure (c, modifier)
+                | Just (Right _) <- lookup g cs
+                    -- re-expand to produce appropriate 'Auto'
+                    -> (,modifier) . pure . pure <$> expandLexeme cs (Grapheme g)
+
+                    -- Note: there are other options for design here
+                    -- see https://verduria.org/viewtopic.php?p=85766#p85766
+                    -- | Just (Right (AutosegmentDef _ gs)) <- lookup g cs
+                    -- 1. -> pure ([Left (GMulti g)], modifier)
+                    -- 2. -> pure (Left . GMulti <$> g:gs, modifier)
+                | otherwise -> pure ([[Grapheme g]], modifier)
+            ls -> (,modifier) . pure <$> traverse (expandLexeme cs) ls
+        pure $ case modifier' of
+            Union -> es ++ new
+            -- important: intersection preserves order of the /last/ category mentioned!
+            Intersect -> es `intersectC` new
+            Subtract -> es `subtractC` new
+
+    -- Set operations, also looking into 'Autosegment's
+    subtractC, intersectC
+        :: [[Lexeme Expanded a]]
+        -> [[Lexeme Expanded a]]
+        -> [[Lexeme Expanded a]]
+
+    subtractC es new = mapMaybe go' es
+      where
+        go' g | g `elemAuto` new = Nothing
+        go' [Autosegment n kvs gs] =
+            Just [Autosegment n
+                  (filterkvs (`notElem` new) kvs)
+                  (filter ((`notElem` new) . pure . Grapheme) gs)]
+        go' g = Just g
+
+    intersectC es new = mapMaybe go' new
+      where
+        go' g | g `elemAuto` es = Just g
+        go' [Autosegment n kvs gs] =
+            Just [Autosegment n
+                  (filterkvs (`elem` es) kvs)
+                  (filter ((`elem` es) . pure . Grapheme) gs)]
+        go' _ = Nothing
+
+    elemAuto :: [Lexeme Expanded a] -> [[Lexeme Expanded a]] -> Bool
+    elemAuto _ [] = False
+    elemAuto g'@[Grapheme gm] ([Autosegment _ _ gs]:ls) = (gm `elem` gs) || elemAuto g' ls
+    elemAuto g' (g:ls) = (g' == g) || elemAuto g' ls
+
+    filterkvs :: ([Lexeme Expanded a] -> Bool) -> [[(Grapheme, Bool)]] -> [[(Grapheme, Bool)]]
+    filterkvs p = fmap . fmap $ \(g, b) -> (g, b && p [Grapheme g])
+
+expandLexeme :: Categories -> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a)
+expandLexeme cs (Grapheme g)
+    | Just (g', '~') <- unsnoc g
+        = Right $ Grapheme g'
+    | otherwise =
+        case lookup g cs of
+            Just (Left c) -> Right $ Category c
+            Just (Right a) -> do
+                kvs <- expandFeature cs (autoFeature a)
+                pure $ Autosegment (autoFeature a) ((fmap.fmap) (,True) kvs) (autoGraphemes a)
+            Nothing -> Right $ Grapheme g
+expandLexeme cs (Category c) = Category <$> expand cs c
+expandLexeme cs (GreedyCategory c) = GreedyCategory <$> expand cs c
+expandLexeme cs (Optional ls) = Optional <$> traverse (expandLexeme cs) ls
+expandLexeme cs (GreedyOptional ls) = GreedyOptional <$> traverse (expandLexeme cs) ls
+expandLexeme _  Metathesis = Right Metathesis
+expandLexeme _  Geminate = Right Geminate
+expandLexeme cs (Wildcard l) = Wildcard <$> expandLexeme cs l
+expandLexeme cs (Kleene l) = Kleene <$> expandLexeme cs l
+expandLexeme _  Discard = Right Discard
+expandLexeme cs (Backreference i c) = Backreference i <$> expand cs c
+expandLexeme cs (Multiple c) = Multiple <$> expand cs c
+expandLexeme cs (Feature r n i [] l) = do
+    kvs <- expandFeature cs n
+    l' <- expandLexeme cs l
+    pure $ Feature r n i kvs l'
+expandLexeme cs (Feature r n i kvs l) = Feature r n i kvs <$> expandLexeme cs l
+expandLexeme _  (Autosegment n kvs gs) =
+    -- in reality this case should never occur from parsed sound changes
+    pure $ Autosegment n kvs gs
+
+expandFeature :: Categories -> String -> Either ExpandError [[String]]
+expandFeature cs n = transpose . fmap snd <$> lookupFeature cs n
+
+lookupFeature
+    :: Categories
+    -> String  -- ^ Feature name (no +/- prefix or +value suffix)
+    -> Either ExpandError [(String, [String])]
+lookupFeature cs n =
+    let pluss :: M.Map String (String, Either (Expanded 'AnyPart) AutosegmentDef)
+        pluss = M.mapMaybeWithKey plusPrefix cs
+    -- NB. consistency is guaranteed as 'elems' always returns items in ascending order
+    in case M.elems pluss of
+        [] -> Left $ NotFound ('+':n)
+        [("", Left (FromElements positive))] ->
+            case M.lookup ('-':n) cs of
+                Just (Left (FromElements negative))
+                    | length positive /= length negative -> Left MismatchedLengths
+                    | Just positive' <- traverse getBaseValue positive
+                    , Just negative' <- traverse getBaseValue negative
+                    -> Right [("-", negative'), ("+", positive')]
+                    | otherwise -> Left InvalidBaseValue
+                _ -> Left $ NotFound ('-':n)
+        kvs -> case traverse getCategory kvs of
+            Just vs@(v:vs')
+                | any ((length v /=) . length) vs' -> Left MismatchedLengths
+                | Just vs'' <- traverse (traverse getBaseValue) vs
+                -> Right $ zip (fst <$> kvs) vs''
+            _ -> Left InvalidBaseValue
+  where
+    plusPrefix ('+':k) v = case stripPrefix n k of
+        Just ('+':k') -> Just (k', v)
+        Just "" -> Just ("", v)
+        _ -> Nothing
+    plusPrefix _ _ = Nothing
+
+    getCategory (_, Left (FromElements c)) = Just c
+    getCategory _ = Nothing
+
+getBaseValue :: CategoryElement Expanded 'AnyPart -> Maybe String
+getBaseValue [Grapheme g] = Just g
+getBaseValue _ = Nothing
+
+-- taken from base-4.19
+unsnoc :: [a] -> Maybe ([a], a)
+unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing
+{-# INLINABLE unsnoc #-}
+
+-- | Expand all categories in a given sound change 'Rule'.
+expandRule :: Categories -> Rule CategorySpec -> Either ExpandError (Rule Expanded)
+expandRule cs r = Rule
+    <$> traverse (expandLexeme cs) (target r)
+    <*> traverse (expandLexeme cs) (replacement r)
+    <*> traverse expandEnvironment (environment r)
+    <*> traverse expandEnvironment (exception r)
+    <*> pure (flags r)
+    <*> pure (plaintext r)
+  where
+    expandEnvironment (e1, e2) = (,)
+        <$> traverse (expandLexeme cs) e1
+        <*> traverse (expandLexeme cs) e2
+
+expandFilter :: Categories -> Filter CategorySpec -> Either ExpandError (Filter Expanded)
+expandFilter cs (Filter p f) = Filter p <$> traverse (expandLexeme cs) f
+
+-- | Extend a set of previously defined t'Categories' to give the
+-- resulting state after a v'Categories' directive.
+extendCategories
+    :: Categories
+    -> (Bool, [CategoryDefinition])  -- ^ The fields of a v'Categories' directive
+    -> Either ExpandError Categories
+extendCategories cs' (overwrite, defs) =
+    foldM go (if overwrite then M.empty else cs') defs
+  where
+    go :: Categories -> CategoryDefinition -> Either ExpandError Categories
+    go cs (DefineCategory name val) = flip (M.insert name) cs . Left <$> expand cs val
+    go cs (DefineFeature spec) = do
+        baseValues <- expand cs $ featureBaseValues spec
+        derivedCats <- traverse (traverse $ expand cs) $ featureDerived spec
+
+        baseValues' <- for (elements baseValues) $
+            maybe (Left InvalidBaseValue) Right . getBaseValue
+        let baseLen = length baseValues'
+            derivedValues = elements . snd <$> derivedCats
+        unless (all ((==baseLen) . length) derivedValues) $
+            Left MismatchedLengths
+
+        let features = zipWith
+               (\base ds -> (base, FromElements $ [Grapheme base] : ds))
+               baseValues'
+               (transpose derivedValues)
+            newCats = fmap (second Left) $
+                maybe [] (pure . (,baseValues)) (featureBaseName spec)
+                ++ derivedCats
+                ++ features
+        Right $ foldl' (flip $ uncurry M.insert) cs newCats
+    go cs (DefineAuto catName) = do
+        let (featureName, featureValue) = case catName of
+                '-':n -> (n, "-")
+                '+':n -> case break (=='+') n of
+                    (prefix, '+':suffix) -> (prefix, suffix)
+                    (_, []) -> (n, "+")
+                    _ -> error "extendCategories: unexpected output from 'break'"
+                n -> (n, "")  -- let it error out below
+        features <- M.fromList <$> lookupFeature cs featureName
+        case M.lookup featureValue features of
+            Nothing -> Left $ NotFound catName
+            Just gs ->
+                -- NB. consistency is guaranteed as 'elems' always returns items in ascending order
+                let autoCs = M.fromList $
+                        zipWith (mkAuto featureName) gs (transpose $ M.elems features)
+                in pure $ M.merge
+                    M.preserveMissing M.preserveMissing
+                    (M.zipWithMatched $ \_ _ c -> c)
+                    cs autoCs
+
+    mkAuto :: String -> String -> [String] -> (String, Either (Expanded 'AnyPart) AutosegmentDef)
+    mkAuto f g gs = (g, Right $ AutosegmentDef f gs)
+
+-- | Expand a set of 'SoundChanges'. Expansion proceeds from beginning
+-- to end as follows:
+--
+--     * Rules and filters are expanded by expanding all categories
+--       within them (with 'expand'). Graphemes are replaced with
+--       categories or autosegments if previously defined as such.
+--
+--     * If a v'Categories' definition block is found, the categories
+--       defined within it are expanded and added to (or replace) the
+--       list of current categories. The block is replaced with a list
+--       of currently defined graphemes.
+--
+--     * If 'ExtraGraphemes' are found, they are added to a list of
+--       currently defined graphemes. They are replaced with a
+--       'GraphemeList' only if no categories are defined in the
+--       'SoundChanges'.
+expandSoundChanges
+    :: SoundChanges CategorySpec Directive
+    -> Either ExpandError (SoundChanges Expanded GraphemeList)
+expandSoundChanges scs = fmap catMaybes $ flip evalStateT (M.empty, []) $ traverse go scs
+  where
+    noCategories = any (\case DeclS (Categories {}) -> True; _ -> False) scs
+
+    go  :: Statement CategorySpec Directive
+        -> StateT
+            (Categories, [String])
+            (Either ExpandError)
+            (Maybe (Statement Expanded GraphemeList))
+    go (RuleS r) = do
+        cs <- gets fst
+        lift $ Just . RuleS <$> expandRule cs r
+    go (FilterS f) = do
+        cs <- gets fst
+        lift $ Just . FilterS <$> expandFilter cs f
+    go ReportS = pure (Just ReportS)
+    go (DeclS (ExtraGraphemes extra)) = do
+        (cs, _) <- get
+        put (cs, extra)
+        pure $
+            if noCategories
+            then Just $ DeclS $ GraphemeList True extra
+            else Nothing
+    go (DeclS (Categories overwrite noreplace defs)) = do
+        (cs, extra) <- get
+        cs' <- lift $ extendCategories cs (overwrite, defs)
+        put (cs', extra)
+        pure $ Just $ DeclS $ GraphemeList noreplace $ extra ++ mapMaybe grapheme (values cs')
+
+    grapheme [Grapheme g] = Just g
+    grapheme _ = Nothing

@@ -1,17 +1,30 @@ {-# LANGUAGE DeriveAnyClass  #-}
 {-# LANGUAGE DeriveGeneric   #-}
 {-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE LambdaCase      #-}
 {-# LANGUAGE RankNTypes      #-}
 {-# 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
+-- Copyright   : See LICENSE file
+-- License     : BSD3
+-- Maintainer  : Brad Neimann
+--
+-- __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.
+--
+-- This module exists primarily as an internal common interface for
+-- Brassica’s two ‘official’ GUI frontends (desktop and web). If you
+-- wish to make your own frontend to Brassica, it is probably easier
+-- to write it yourself rather than trying to use this.
 module Brassica.SoundChange.Frontend.Internal where
 
 import Control.Monad ((<=<))
+import Data.Containers.ListUtils (nubOrd)
+import Data.List (transpose, intersperse)
 import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Void (Void)
 import GHC.Generics (Generic)
@@ -23,25 +36,30 @@ import Brassica.SFM.MDF
 import Brassica.SFM.SFM
 import Brassica.SoundChange.Apply
-import Brassica.SoundChange.Apply.Internal (applyChangesWithLog, toPWordLog)
 import Brassica.SoundChange.Tokenise
 import Brassica.SoundChange.Types
-import Data.Bifunctor (first)
 
 -- | Rule application mode of the SCA.
 data ApplicationMode
     = ApplyRules HighlightMode OutputMode String
+    -- ^ Apply sound changes as normal, with the given modes and
+    -- separator
     | ReportRulesApplied
+    -- ^ Apply reporting the rules which were applied (as HTML)
     deriving (Show, Eq)
 
+-- | Get the 'OutputMode' if one is set, otherwise default to
+-- 'WordsOnlyOutput'.
 getOutputMode :: ApplicationMode -> OutputMode
 getOutputMode (ApplyRules _ o _) = o
-getOutputMode ReportRulesApplied = WordsOnlyOutput  -- default option
+getOutputMode ReportRulesApplied = WordsOnlyOutput
 
+-- | Mode for highlighting output words
 data HighlightMode
     = NoHighlight
     | DifferentToLastRun
     | DifferentToInput
+    -- ^ NB. now labeled ‘any rule applied’ in GUI
     deriving (Show, Eq)
 instance Enum HighlightMode where
     -- used for conversion to and from C, so want control over values
@@ -54,11 +72,14 @@     toEnum 2 = DifferentToInput
     toEnum _ = undefined
 
+-- | Mode for reporting output words (and sometimes intermediate and
+-- input words too)
 data OutputMode
     = MDFOutput
     | WordsOnlyOutput
     | MDFOutputWithEtymons
     | WordsWithProtoOutput
+    | WordsWithProtoOutputPreserve
     deriving (Show, Eq)
 instance Enum OutputMode where
     -- used for conversion to and from C, so want control over values
@@ -66,11 +87,13 @@     fromEnum WordsOnlyOutput = 1
     fromEnum MDFOutputWithEtymons = 2
     fromEnum WordsWithProtoOutput = 3
+    fromEnum WordsWithProtoOutputPreserve = 4
 
     toEnum 0 = MDFOutput
     toEnum 1 = WordsOnlyOutput
     toEnum 2 = MDFOutputWithEtymons
     toEnum 3 = WordsWithProtoOutput
+    toEnum 4 = WordsWithProtoOutputPreserve
     toEnum _ = undefined
 
 -- | Output of a single application of rules to a wordlist: either a
@@ -78,95 +101,92 @@ -- parse error.
 data ApplicationOutput a r
     = HighlightedWords [Component (a, Bool)]
-    | AppliedRulesTable [PWordLog r]
+    | AppliedRulesTable [Log r]
     | ParseError (ParseErrorBundle String Void)
     deriving (Show, Generic, NFData)
 
+-- | For MDF input, the hierarchy used
+data MDFHierarchy = Standard | Alternate
+    deriving (Show, Eq)
+
 -- | Kind of input: either a raw wordlist, or an MDF file.
-data InputLexiconFormat = Raw | MDF
+data InputLexiconFormat = Raw | MDF MDFHierarchy
     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
+    fromEnum (MDF Standard) = 1
+    fromEnum (MDF Alternate) = 2
 
     toEnum 0 = Raw
-    toEnum 1 = MDF
+    toEnum 1 = MDF Standard
+    toEnum 2 = MDF Alternate
     toEnum _ = undefined
 
+-- | Either a list of 'Component's for a Brassica wordlist file, or a
+-- list of 'SFM' fields for an MDF file
 data ParseOutput a = ParsedRaw [Component a] | ParsedMDF SFM
     deriving (Show, Functor, Foldable, Traversable)
 
-componentise :: OutputMode -> [a] -> [Component a] -> [Component a]
-componentise WordsWithProtoOutput ws cs = intersperseWords ws cs
-componentise _                    _  cs = cs
-
-intersperseWords :: [a] -> [Component a] -> [Component a]
-intersperseWords (w:ws) (Word c:cs) =
-    Word w : Separator " → " : Word c : Separator "\n" : intersperseWords ws cs
-intersperseWords ws (_:cs) = intersperseWords ws cs
-intersperseWords [] cs = cs
-intersperseWords _ [] = []
-
+-- | Given the selected input and output modes, and the expanded sound
+-- changes, tokenise the input according to the format which was selected
 tokeniseAccordingToInputFormat
     :: InputLexiconFormat
     -> OutputMode
-    -> SoundChanges Expanded [Grapheme]
+    -> SoundChanges Expanded GraphemeList
     -> String
     -> Either (ParseErrorBundle String Void) [Component PWord]
 tokeniseAccordingToInputFormat Raw _ cs =
     withFirstCategoriesDecl tokeniseWords cs
-tokeniseAccordingToInputFormat MDF MDFOutputWithEtymons cs =
-    withFirstCategoriesDecl tokeniseMDF cs <=<
-    -- TODO don't hard-code hierarchy and filename
-    fmap (fromTree . duplicateEtymologies ('*':) . toTree mdfHierarchy)
-    . parseSFM ""
-tokeniseAccordingToInputFormat MDF o cs = \input -> do
+tokeniseAccordingToInputFormat (MDF h) MDFOutputWithEtymons cs =
+    let h' = case h of
+            Standard -> mdfHierarchy
+            Alternate -> mdfAlternateHierarchy
+    in
+        withFirstCategoriesDecl tokeniseMDF cs <=<
+        fmap (fromTree . duplicateEtymologies ('*':) . toTree h')
+        . parseSFM ""
+tokeniseAccordingToInputFormat (MDF _) o cs = \input -> do
     sfm <- parseSFM "" input
     ws <- withFirstCategoriesDecl tokeniseMDF cs sfm
     pure $ case o of
         MDFOutput -> ws
-        _ ->  -- need to extract words for other output modes
-            Word <$> getWords ws
+        _ ->
+            -- need to extract words for other output modes
+            -- also add separators to keep words apart visually
+            intersperse (Separator "\n") $ Word <$> getWords ws
 
 -- | 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
     :: (forall a b. (a -> b) -> [Component a] -> [Component b])  -- ^ mapping function to use (for parallelism)
-    -> SoundChanges Expanded [Grapheme] -- ^ changes
+    -> SoundChanges Expanded GraphemeList -- ^ changes
     -> String       -- ^ words
     -> InputLexiconFormat
     -> ApplicationMode
     -> Maybe [Component PWord]  -- ^ previous results
-    -> ApplicationOutput PWord (Statement Expanded [Grapheme])
+    -> ApplicationOutput PWord (Statement Expanded GraphemeList)
 parseTokeniseAndApplyRules parFmap statements ws intype mode prev =
     case tokeniseAccordingToInputFormat intype (getOutputMode mode) statements ws of
         Left e -> ParseError e
-        Right toks
-          | ws' <- getWords toks
-          -> case mode of
+        Right toks -> case mode of
             ReportRulesApplied ->
-                AppliedRulesTable $ mapMaybe toPWordLog $ concat $
-                    getWords $ componentise WordsOnlyOutput [] $
-                        parFmap (applyChangesWithLog statements) toks
+                AppliedRulesTable $ concat $
+                    getWords $ parFmap (applyChanges statements) toks
             ApplyRules DifferentToLastRun mdfout sep ->
                 let result = concatMap (splitMultipleResults sep) $
-                      componentise mdfout (fmap pure ws') $
-                          parFmap (applyChanges statements) toks
+                        joinComponents' mdfout $ parFmap (doApply mdfout statements) toks
                 in HighlightedWords $
                     mapMaybe polyDiffToHighlight $ getDiff (fromMaybe [] prev) result
                     -- zipWithComponents result (fromMaybe [] prev) [] $ \thisWord prevWord ->
                     --     (thisWord, thisWord /= prevWord)
             ApplyRules DifferentToInput mdfout sep ->
                 HighlightedWords $ concatMap (splitMultipleResults sep) $
-                    (fmap.fmap) (mapMaybe extractMaybe) $
-                        componentise mdfout (fmap (pure . first Just . (,False)) ws') $
-                            parFmap (applyChangesWithChanges statements) toks
+                        joinComponents' mdfout $ parFmap (doApplyWithChanges mdfout statements) toks
             ApplyRules NoHighlight mdfout sep ->
                 HighlightedWords $ (fmap.fmap) (,False) $ concatMap (splitMultipleResults sep) $
-                    componentise mdfout (fmap pure ws') $
-                        parFmap (applyChanges statements) toks
+                    joinComponents' mdfout $ parFmap (doApply mdfout statements) toks
   where
     -- highlight words in 'Second' but not 'First'
     polyDiffToHighlight :: PolyDiff (Component a) (Component a) -> Maybe (Component (a, Bool))
@@ -181,5 +201,36 @@     unsafeCastComponent (Separator s) = Separator s
     unsafeCastComponent (Gloss s) = Gloss s
 
-    extractMaybe (Just a, b) = Just (a, b)
-    extractMaybe (Nothing, _) = Nothing
+    doApply :: OutputMode -> SoundChanges Expanded GraphemeList -> PWord -> [Component [PWord]]
+    doApply WordsWithProtoOutput scs w = doApplyWithProto scs w
+    doApply WordsWithProtoOutputPreserve scs w = doApplyWithProto scs w
+    doApply _ scs w = [Word $ mapMaybe getOutput $ applyChanges scs w]
+
+    doApplyWithProto scs w =
+        let intermediates :: [[PWord]]
+            intermediates = fmap nubOrd $ transpose $ getReports <$> applyChanges scs w
+        in intersperse (Separator " → ") (fmap Word intermediates)
+
+    doApplyWithChanges :: OutputMode -> SoundChanges Expanded GraphemeList -> PWord -> [Component [(PWord, Bool)]]
+    doApplyWithChanges WordsWithProtoOutput scs w = doApplyWithChangesWithProto scs w
+    doApplyWithChanges WordsWithProtoOutputPreserve scs w = doApplyWithChangesWithProto scs w
+    doApplyWithChanges _ scs w = [Word $ mapMaybe getChangedOutputs $ applyChanges scs w]
+
+    doApplyWithChangesWithProto scs w =
+        let intermediates :: [[(PWord, Bool)]]
+            intermediates = fmap nubOrd $ transpose $ getChangedReports <$> applyChanges scs w
+        in intersperse (Separator " → ") (fmap Word intermediates)
+
+    joinComponents' WordsWithProtoOutput =
+        joinComponents . intersperse (Separator "\n") . filter (\case Word _ -> True; _ -> False)
+    joinComponents' WordsWithProtoOutputPreserve = joinComponents . linespace
+    joinComponents' _ = joinComponents
+
+    -- Insert newlines as necessary to put each 'Word' on a separate line
+    linespace :: [Component a] -> [Component a]
+    linespace (Separator s:cs)
+        | '\n' `elem` s = Separator s : linespace cs
+        | otherwise = Separator ('\n':s) : linespace cs
+    linespace (c:cs@(Separator _:_)) = c : linespace cs
+    linespace (c:cs) = c : Separator "\n" : linespace cs
+    linespace [] = []

@@ -5,16 +5,26 @@ {-# LANGUAGE RecordWildCards  #-} {-# LANGUAGE ScopedTypeVariables #-} +-- |+-- Module      : Brassica.SoundChange.Parse+-- Copyright   : See LICENSE file+-- License     : BSD3+-- Maintainer  : Brad Neimann+--+-- Functions to parse sound changes in Brassica syntax. (For details+-- on the syntax, refer to the+-- [reference guide](https://github.com/bradrn/brassica/blob/v1.0.0/docs/Reference.md).) module Brassica.SoundChange.Parse     ( parseRule     , parseSoundChanges       -- ** Re-export-    , errorBundlePretty+    , module Text.Megaparsec.Error     ) where  import Data.Char (isSpace) import Data.Foldable (asum)-import Data.Maybe (isNothing, isJust, fromJust)+import Data.List (dropWhileEnd)+import Data.Maybe (isNothing, isJust, fromJust, fromMaybe) import Data.Void (Void)  import Control.Applicative.Permutations@@ -23,6 +33,7 @@ import Text.Megaparsec hiding (State) import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L+import Text.Megaparsec.Error  import Brassica.SoundChange.Types @@ -31,15 +42,15 @@ class ParseLexeme (a :: LexemeType) where     parseLexeme :: Parser (Lexeme CategorySpec a) --- space consumer which does not match newlines+-- space consumer which does not match newlines or comments sc :: Parser ()-sc = L.space space1' (L.skipLineComment ";") empty+sc = L.space space1' empty 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+-- space consumer which matches newlines and comments scn :: Parser () scn = L.space space1 (L.skipLineComment ";") empty @@ -50,7 +61,7 @@ symbol = L.symbol sc  keyChars :: [Char]-keyChars = "#[](){}>\\→/_^%~*@"+keyChars = "#[](){}>\\→/_^%~*@$;"  nonzero :: Parser Int nonzero = label "nonzero postive number" $ try $ do@@ -60,14 +71,17 @@  parseGrapheme :: Parser Grapheme parseGrapheme = lexeme $-    GBoundary <$ char '#'-    <|> GMulti <$> parseGrapheme'+    pure <$> char '#'+    <|> parseGrapheme' True -parseGrapheme' :: Parser String-parseGrapheme' = lexeme $ do+parseGrapheme' :: Bool -> Parser String+parseGrapheme' wantTilde = lexeme $ do     star <- optional (char '*')     rest <- takeWhile1P Nothing (not . ((||) <$> isSpace <*> (`elem` keyChars)))-    nocat <- optional (char '~')+    nocat <-+        if wantTilde+        then optional (char '~')+        else pure Nothing     pure .         maybe id (const ('*':)) star .         maybe id (const (++"~")) nocat@@ -76,51 +90,62 @@ parseExplicitCategory :: ParseLexeme a => Parser (Lexeme CategorySpec a) parseExplicitCategory = Category <$> parseExplicitCategory' +parseGreedyCategory :: Parser (Lexeme CategorySpec 'Matched)+parseGreedyCategory = GreedyCategory <$> (char '%' *> parseExplicitCategory')+ parseExplicitCategory' :: ParseLexeme a => Parser (CategorySpec a)-parseExplicitCategory' =-    CategorySpec <$> (symbol "[" *> someTill parseCategoryModification (symbol "]"))+parseExplicitCategory' = fmap CategorySpec $+    (:) <$> (symbol "[" *> parseCategoryModification True)+        <*> manyTill (parseCategoryModification False) (symbol "]")  -- This is unused currently, but convenient to keep around just in case -- parseCategory :: ParseLexeme a => Parser (Lexeme CategorySpec a) -- parseCategory = Category <$> parseCategory'  parseCategory' :: ParseLexeme a => Parser (CategorySpec a)-parseCategory' = parseExplicitCategory' <|> MustInline <$> parseGrapheme'+parseCategory' = parseExplicitCategory' <|> MustInline <$> parseGrapheme' True  parseCategoryStandalone     :: Parser (String, CategorySpec 'AnyPart) parseCategoryStandalone = do-    g <- parseGrapheme'+    g <- parseGrapheme' True     _ <- symbol "="-    mods <- some parseCategoryModification+    mods <- some (parseCategoryModification False)     return (g, CategorySpec mods)  parseFeature :: Parser FeatureSpec parseFeature = do     _ <- symbol "feature"-    featureBaseName <- optional $ try $ parseGrapheme' <* symbol "="-    featureBaseValues <- CategorySpec <$> some parseCategoryModification+    featureBaseName <- optional $ try $ parseGrapheme' False <* symbol "="+    featureBaseValues <- CategorySpec <$> some (parseCategoryModification False)     featureDerived <- some (symbol "/" *> parseCategoryStandalone) <* scn     pure FeatureSpec { featureBaseName, featureBaseValues, featureDerived } +parseAuto :: Parser String+parseAuto = symbol "auto" *> parseGrapheme' False <* scn+ parseCategoryModification     :: ParseLexeme a-    => Parser (CategoryModification, Either Grapheme [Lexeme CategorySpec a])-parseCategoryModification = (,)-    <$> parsePrefix-    <*> ( (Right <$> (symbol "{" *> manyTill parseLexeme (symbol "}")))-        <|> (Left <$> parseGrapheme))+    => Bool+    -> Parser (CategoryModification, [Lexeme CategorySpec a])+parseCategoryModification forceUnion = (,)+    <$> (if forceUnion+           then Union <$ optional (char '&')+           else parsePrefix)+    <*> (symbol "{" *> manyTill parseLexeme (symbol "}")+        <|> (pure . Grapheme <$> parseGrapheme))   where     parsePrefix =         (Intersect <$ char '+')         <|> (Subtract <$ char '-')+        <|> (Union <$ char '&')  -- necessary for featural categories         <|> pure Union  parseDirective :: Parser Directive parseDirective = parseCategoriesDirective <|> parseExtraDirective   where     parseExtraDirective = fmap ExtraGraphemes $-        symbol "extra" *> many parseGrapheme' <* scn+        symbol "extra" *> many (parseGrapheme' False) <* scn      parseCategoriesDirective = do         overwrite <- isJust <$> optional (symbol "new")@@ -129,6 +154,7 @@         scn         cs <- some $             DefineFeature <$> parseFeature <|>+            DefineAuto <$> parseAuto <|>             uncurry DefineCategory <$> (try parseCategoryStandalone <* scn)         _ <- symbol "end" <* scn         pure $ Categories overwrite noreplace cs@@ -136,6 +162,9 @@ parseOptional :: ParseLexeme a => Parser (Lexeme CategorySpec a) parseOptional = Optional <$> between (symbol "(") (symbol ")") (some parseLexeme) +parseGreedyOptional :: Parser (Lexeme CategorySpec 'Matched)+parseGreedyOptional = GreedyOptional <$> between (symbol "%(") (symbol ")") (some parseLexeme)+ parseGeminate :: Parser (Lexeme CategorySpec a) parseGeminate = Geminate <$ symbol ">" @@ -148,26 +177,44 @@ parseDiscard :: Parser (Lexeme CategorySpec 'Replacement) parseDiscard = Discard <$ symbol "~" -parseKleene :: Lexeme CategorySpec a -> Parser (Lexeme CategorySpec a)-parseKleene l =-    try (lexeme $ Kleene l <$ char '*' <* notFollowedBy parseGrapheme')+parsePost :: Lexeme CategorySpec a -> Parser (Lexeme CategorySpec a)+parsePost l =+    try parseFeatureApp+    <|> try (lexeme $ Kleene l <$ char '*' <* notFollowedBy (parseGrapheme' True))     <|> pure l+  where+    parseFeatureApp =+        Feature <$ char '$'+        <*> fmap isJust (optional $ char '-')+        <*> parseGrapheme' False+        <*> optional (char '#' *> parseGrapheme' False)+        <*> fmap (fromMaybe [])+            ( optional $ between (symbol "(") (symbol ")") $+              many $ lexeme $ parseGrapheme' False `sepBy1` char '~'+            )+        <*> pure l  parseMultiple :: Parser (Lexeme CategorySpec 'Replacement) parseMultiple = Multiple <$> (symbol "@?" *> parseCategory')  parseBackreference :: forall a. ParseLexeme a => Parser (Lexeme CategorySpec a)-parseBackreference = Backreference <$> (symbol "@" *> nonzero) <*> parseCategory'+parseBackreference = Backreference <$> (symbol "@" *> ref) <*> parseCategory'+  where+    ref =+        Left <$> (char '#' *> parseGrapheme' False)+        <|> Right <$> nonzero  instance ParseLexeme 'Matched where     parseLexeme = asum         [ parseExplicitCategory         , parseOptional+        , parseGreedyOptional+        , parseGreedyCategory         , parseGeminate         , parseWildcard         , parseBackreference         , Grapheme <$> parseGrapheme-        ] >>= parseKleene+        ] >>= parsePost  instance ParseLexeme 'Replacement where     parseLexeme = asum@@ -180,7 +227,7 @@         , parseWildcard         , parseBackreference         , Grapheme <$> parseGrapheme-        ] >>= parseKleene+        ] >>= parsePost  instance ParseLexeme 'AnyPart where     parseLexeme = asum@@ -188,7 +235,7 @@         , parseOptional         , parseWildcard         , Grapheme <$> parseGrapheme-        ] >>= parseKleene+        ] >>= parsePost  parseLexemes :: ParseLexeme a => Parser [Lexeme CategorySpec a] parseLexemes = many parseLexeme@@ -200,6 +247,7 @@     <*> toPermutation (isJust <$> optional (symbol "-1"))     <*> toPermutationWithDefault ApplyAlways         ((PerApplication <$ symbol "-??") <|> (PerWord <$ symbol "-?"))+    <*> toPermutation (isJust <$> optional (symbol "-no"))  ruleParser :: Parser (Rule CategorySpec) ruleParser = do@@ -228,29 +276,34 @@      exception <- optional $ (,) <$> (symbol "//" *> parseLexemes) <* symbol "_" <*> parseLexemes +    o' <- getOffset+     _ <- optional scn   -- consume newline after rule if present -    o' <- getOffset-    let plaintext = takeWhile notNewline $ (fst . fromJust) (takeN_ (o' - o) s)+    let plaintext = dropWhile isSpace $ dropWhileEnd isSpace $+            (fst . fromJust) (takeN_ (o' - o) s)     return Rule{environment=envs, ..}-  where-    notNewline c = (c /= '\n') && (c /= '\r')  filterParser :: Parser (Filter CategorySpec) filterParser = fmap (uncurry Filter) $ match $ symbol "filter" *> parseLexemes <* optional scn --- | 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.3.0/Documentation.md#basic-rule-syntax>.+-- Space handline is a little complex here: we want to make sure that+-- 'report' is always on its own line, but can have as much or as+-- little space after it as needed+reportParser :: Parser ()+reportParser = symbol "report" *> sc *> ((newline *> void (optional scn)) <|> eof)++-- | Parse a single sound change into a 'Rule'. Returns 'Left' if the+-- input string is malformed. parseRule :: String -> Either (ParseErrorBundle String Void) (Rule CategorySpec) parseRule = runParser (scn *> ruleParser <* eof) "" --- | Parse a list of 'SoundChanges'.+-- | Parse a sound change file into a set of 'SoundChanges'. parseSoundChanges :: String -> Either (ParseErrorBundle String Void) (SoundChanges CategorySpec Directive) parseSoundChanges = runParser (scn *> parser <* eof) ""   where     parser = many $-        DirectiveS <$> parseDirective+        DeclS <$> parseDirective         <|> FilterS <$> filterParser+        <|> ReportS <$ reportParser         <|> RuleS <$> ruleParser

@@ -5,18 +5,27 @@ {-# LANGUAGE TypeFamilies      #-} {-# LANGUAGE ViewPatterns      #-} +-- |+-- Module      : Brassica.SoundChange.Tokenise+-- Copyright   : See LICENSE file+-- License     : BSD3+-- Maintainer  : Brad Neimann+--+-- This module provides functions to parse a Brassica words file into+-- its constituent 'Component's, and to tokenise the words in that+-- file into their constituent graphemes to form 'PWord's. It also+-- provides functions to reverse these processes. module Brassica.SoundChange.Tokenise-       ( -       -- * Components-         Component(..)+       (+       -- * High-level interface+         tokeniseWord+       , Component(..)        , getWords        , splitMultipleResults-       -- * High-level interface-       , tokeniseWord+       , joinComponents        , tokeniseWords        , detokeniseWords'        , detokeniseWords-       , concatWithBoundary        , findFirstCategoriesDecl        , withFirstCategoriesDecl        -- * Lower-level functions@@ -40,12 +49,22 @@  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+-- | Represents a component of a Brassica words file. Each word in the+-- input has type @a@ (often 'PWord' or @['PWord']@).+data Component a+    = Word a            -- ^ An input word to which sound changes will be applied+    | Separator String  -- ^ A separator, e.g. whitespace+    | Gloss String      -- ^ A gloss (in Brassica syntax, between square brackets)     deriving (Eq, Show, Functor, Foldable, Traversable, Generic, NFData) +-- | Flatten a nested list of 'Component's.+joinComponents :: [Component [Component a]] -> [Component a]+joinComponents = concatMap go+  where+    go (Word cs) = cs+    go (Separator s) = [Separator s]+    go (Gloss s) = [Gloss s]+ -- | Given a tokenised input string, return only the v'Word's within -- it. getWords :: [Component a] -> [a]@@ -59,8 +78,8 @@ -- -- For instance: ----- >>> splitMultipleResults " " (Word ["abc", "def", "ghi"])--- [Word "abc", Separator " ", Word "def", Separator " ", Word "ghi"]+-- >>> splitMultipleResults "/" (Word ["abc", "def", "ghi"])+-- [Word "abc", Separator "/", Word "def", Separator "/", Word "ghi"] -- -- >>> splitMultipleResults " " (Word ["abc"]) -- [Word "abc"]@@ -68,30 +87,31 @@ 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. The second--- gives a list of multigraphs which might be expected.+-- for details on the parsing strategy. For most usecases+-- 'tokeniseWord' should suffice; 'wordParser' itself is only really+-- useful in unusual situations (e.g. as part of a larger parser). ----- Note: the second parameter __must__ be 'sortByDescendingLength'-ed;--- otherwise multigraphs will not be parsed correctly.+-- 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. The second gives a list of+-- multigraphs which might be expected, as with 'tokeniseWord'.+--+-- Note: the second parameter __must__ be already be sorted by descending length;+-- otherwise multigraphs will not be parsed correctly (i.e. greedily). wordParser :: [Char] -> [String] -> ParsecT Void String Identity PWord wordParser excludes gs = some $-    (GBoundary <$ single '#')-    <|> choice (fmap GMulti . chunk <$> gs)-    <|> (GMulti . pure <$> satisfy (not . exclude))+    ("#" <$ single '#')+    <|> 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 a  -- ^ Parser for individual words (e.g. 'wordParser')     -> ParsecT Void String Identity [Component a] componentsParser p = many $     (Separator <$> takeWhile1P Nothing isSpace) <|>@@ -106,6 +126,8 @@            then '[' : concat contents ++ "]"            else concat contents +-- | Sort a list of lists by the length of the inner lists, in+-- descending order. sortByDescendingLength :: [[a]] -> [[a]] sortByDescendingLength = sortBy (compare `on` Down . length) @@ -117,30 +139,33 @@ -- multigraphs is a prefix of another, the tokeniser will prefer the -- longest if possible. If there are no matching multigraphs starting -- at a particular character in the 'String', 'tokeniseWord' will--- treat that character as its own t'Grapheme'. For instance:+-- take that character as forming its own t'Grapheme'. For instance: -- -- >>> tokeniseWord [] "cherish" -- Right [GMulti "c",GMulti "h",GMulti "e",GMulti "r",GMulti "i",GMulti "s",GMulti "h"]--- +-- -- >>> tokeniseWord ["e","h","i","r","s","sh"] "cherish" -- Right [GMulti "c",GMulti "h",GMulti "e",GMulti "r",GMulti "i",GMulti "sh"]--- +-- -- >>> tokeniseWord ["c","ch","e","h","i","r","s","sh"] "cherish" -- Right [GMulti "ch",GMulti "e",GMulti "r",GMulti "i",GMulti "sh"]+--+-- The resulting 'PWord' can be converted back to a 'String' using+-- 'concatWithBoundary'. (However, it is not strictly speaking a true+-- inverse as it deletes word boundaries). tokeniseWord :: [String] -> String -> Either (ParseErrorBundle String Void) PWord tokeniseWord (sortByDescendingLength -> gs) = parse (wordParser "[" gs) "" --- | Given a list of available multigraphs, 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).+-- | Given a list of available multigraphs, tokenise an input words+-- file 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 (as whitespace). tokeniseWords :: [String] -> 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.+-- | Inverse of 'tokeniseWords': given a function to convert v'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@@ -153,12 +178,9 @@ detokeniseWords = detokeniseWords' concatWithBoundary  -- | Given a list of sound changes, extract the list of multigraphs--- defined in the first categories declaration of the 'SoundChange's.-findFirstCategoriesDecl :: SoundChanges c [Grapheme] -> [String]-findFirstCategoriesDecl (DirectiveS gs:_) =-    mapMaybe-        (\case GBoundary -> Nothing; GMulti m -> Just m)-        gs+-- defined in the first 'GraphemeList' of the 'SoundChanges'.+findFirstCategoriesDecl :: SoundChanges c GraphemeList -> [String]+findFirstCategoriesDecl (DeclS (GraphemeList _ gs):_) = gs findFirstCategoriesDecl (_:ss) = findFirstCategoriesDecl ss findFirstCategoriesDecl [] = [] @@ -166,5 +188,5 @@ -- like @'withFirstCategoriesDecl' 'tokeniseWords' changes words@ (to -- tokenise using the graphemes from the first categories declaration) -- and so on.-withFirstCategoriesDecl :: ([String] -> t) -> SoundChanges c [Grapheme] -> t+withFirstCategoriesDecl :: ([String] -> t) -> SoundChanges c GraphemeList -> t withFirstCategoriesDecl tok ss = tok (findFirstCategoriesDecl ss)

@@ -6,32 +6,52 @@ {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE GADTs                 #-}-{-# LANGUAGE LambdaCase            #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE PatternSynonyms       #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes            #-} {-# LANGUAGE StandaloneDeriving    #-} {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE UndecidableInstances  #-} +-- |+-- Module      : Brassica.SoundChange.Types+-- Copyright   : See LICENSE file+-- License     : BSD3+-- Maintainer  : Brad Neimann+--+-- This module contains the types used to represent sound changes and+-- words in Brassica. In brief:+--+--     * A set of 'SoundChanges' is composed of a list of elements+--+--     * Their most important elements are sound change 'Rule's+--+--     * Sound changes are composed of 'Lexeme's denoting parts of the+--       input and output words+--+--     * Each word is a sequence of t'Grapheme's+--+-- For more details on the syntax and semantics of sound changes,+-- refer to the [reference guide](https://github.com/bradrn/brassica/blob/v1.0.0/docs/Reference.md). module Brassica.SoundChange.Types        (        -- * Words and graphemes-         Grapheme(..)+         Grapheme        , PWord        , addBoundaries        , removeBoundaries        , concatWithBoundary        -- * Lexemes        , Lexeme(..)-       , pattern Boundary        , LexemeType(..)        , generalise        -- * Categories        , mapCategory        , mapCategoryA+       , CategoryElement+       , CategorySpec(..)+       , CategoryModification(..)        , Expanded(..)        , generaliseExpanded        -- * Rules@@ -47,91 +67,106 @@        , plaintext'        , SoundChanges        -- * Directives-       , CategoryModification(..)-       , CategorySpec(..)-       , FeatureSpec(..)-       , CategoryDefinition(..)        , Directive(..)+       , CategoryDefinition(..)+       , FeatureSpec(..)+       , GraphemeList(..)        ) where -import Control.DeepSeq (NFData(..))-import Data.String (IsString(..))+import Control.DeepSeq (NFData(..), deepseq) import GHC.Generics (Generic) import GHC.OldList (dropWhileEnd) --- | The type of graphemes within a word.-data Grapheme-    = GMulti [Char]  -- ^ A multigraph: for instance @GMulti "a", GMulti "ch", GMulti "c̓" :: t'Grapheme'@.-    | GBoundary      -- ^ A non-letter element representing a word boundary which sound changes can manipulate-    deriving (Eq, Ord, Show, Generic, NFData)--instance IsString Grapheme where-    fromString = GMulti+-- | The type of graphemes within a word. @"#"@ is taken to denote a+-- word boundary (whch is universally treated as a normal grapheme in+-- sound changes.)+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'@.+-- | Brassica views a word, or a subsequence of one, as a list of+-- @Grapheme@s. For instance, Portuguese "filha" becomes+-- @["f", "i", "lh", "a"]@ when tokenised correctly. ----- (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'@.)+-- (The name 'PWord' is from ‘phonological word’, these being what+-- sound changes typically manipulate. The name was chosen to avoid a+-- clash with @t'Word'@ from @base@.) type PWord = [Grapheme] --- Add a 'GBoundary' at the beginning and end of the 'PWord'.+-- | Add word boundaries (@"#"@) at the beginning and end of a 'PWord'. addBoundaries :: PWord -> PWord-addBoundaries w = GBoundary : w ++ [GBoundary]+addBoundaries w = "#" : w ++ ["#"] --- Remove 'GBoundary's from the beginning and end of the 'PWord'.+-- | Remove word boundaries (@"#"@) from the beginning and end of a 'PWord'. removeBoundaries :: PWord -> PWord-removeBoundaries = dropWhile (==GBoundary) . dropWhileEnd (==GBoundary)+removeBoundaries = dropWhile (=="#") . dropWhileEnd (=="#") --- | Render a 'PWord' as a 'String'. Very much like 'concat', but--- treating 'GBoundary's specially. Word-external boundaries are--- deleted, while word-internal boundaries are converted to @"#"@.+-- | Render a 'PWord' as a 'String': does 'removeBoundaries' then 'concat'. concatWithBoundary :: PWord -> String-concatWithBoundary = go . removeBoundaries-  where-    go = concatMap $ \case-        GMulti g -> g-        GBoundary -> "#"+concatWithBoundary = concat . removeBoundaries --- | The part of a 'Rule' in which a 'Lexeme' may occur: in a matched--- part (target or environment), in replacement, or in either of--- those.-data LexemeType = Matched | Replacement | AnyPart+-- | The part of a 'Rule' in which a 'Lexeme' may occur.+data LexemeType+    = Matched      -- ^ In the target, environment or exception (‘matching’ position)+    | Replacement  -- ^ In the replacement only+    | AnyPart      -- ^ Not restricted to any one part --- | A 'Lexeme' is the smallest part of a sound change. Both matches--- and replacements are made up of 'Lexeme's: the phantom type--- variable @a@ specifies where each different variety of 'Lexeme' may--- occur. 'Lexeme's are also parameterised by their category type,--- which may be 'Expanded' or something else.+-- | Each part of a sound change is made up of a sequence of+-- 'Lexeme's. Each 'Lexeme' denotes part of an input or output word.+--+-- The first type variable @category@ is the type used to represent+-- categories within the sound change. This will usually be+-- 'CategorySpec' after parsing, or 'Expanded' after expansion.+--+-- The second type variable is phantom and represents the part of the+-- rule in which the lexeme is placed. Various lexemes are restricted+-- to 'Matched' or 'Replacement' positions respectively.+--+-- For details on the syntax and semantics of each kind of lexeme,+-- refer to the [reference guide](https://github.com/bradrn/brassica/blob/v1.0.0/docs/Reference.md). data Lexeme category (a :: LexemeType) where-    -- | In Brassica sound-change syntax, one or more letters without intervening whitespace,-    -- or a word boundary specified as @#@     Grapheme :: Grapheme -> Lexeme category a-    -- | In Brassica sound-change syntax, delimited by square brackets     Category :: category a -> Lexeme category a-    -- | In Brassica sound-change syntax, delimited by parentheses+    -- | Written @%category@, matching-only+    GreedyCategory :: category 'Matched -> Lexeme category 'Matched+    -- | Written @(lexemes)@     Optional :: [Lexeme category a] -> Lexeme category a-    -- | In Brassica sound-change syntax, specified as @\@+    -- | Written @%(lexemes)@, matching-only+    GreedyOptional :: [Lexeme category 'Matched] -> Lexeme category 'Matched+    -- | Written @\\@, replacement-only     Metathesis :: Lexeme category 'Replacement-    -- | In Brassica sound-change syntax, specified as @>@+    -- | Written @>@     Geminate :: Lexeme category a-    -- | In Brassica sound-change syntax, specified as @^@ before another 'Lexeme'+    -- | Written @^lexeme@     Wildcard :: Lexeme category a -> Lexeme category a-    -- | In Brassica sound-change syntax, specified as @*@ after another 'Lexeme'+    -- | Written @lexeme*@     Kleene   :: Lexeme category a -> Lexeme category a-    -- | In Brassica sound-change syntax, specified as @~@+    -- | Written @~@, replacement-only     Discard  :: Lexeme category 'Replacement-    -- | In Brassica sound-change syntax, specified as \@i before a category-    Backreference :: Int -> category a -> Lexeme category a-    -- | In Brassica sound-change syntax, specified as \@? before a category+    -- | Written @\@n category@ or @\@#id category@+    Backreference :: Either String Int -> category a -> Lexeme category a+    -- | Written @\@? category@     Multiple :: category 'Replacement -> Lexeme category 'Replacement+    -- | Written @lexeme$Name@ or variations (see reference guide)+    Feature+        :: Bool                -- ^ 'True' iff the feature is negated+        -> String              -- ^ Feature name+        -> Maybe String        -- ^ Identifier if backreferenced, else 'Nothing'+        -> [[Grapheme]]        -- ^ List of correspondence sets+        -> Lexeme category a+        -> Lexeme category a+    -- | Not directly available in Brassica syntax, inserted in expansion+    Autosegment+        :: Grapheme                -- ^ Feature name+        -> [[(Grapheme, Bool)]]    -- ^ List of correspondence sets, with exclusion states+        -> [Grapheme]              -- ^ Graphemes to be matched by this 'Autosegment'+        -> Lexeme category a +-- | Map a function over any categories in the given 'Lexeme'. mapCategory :: (forall x. c x -> c' x) -> Lexeme c a -> Lexeme c' a mapCategory _ (Grapheme g) = Grapheme g mapCategory f (Category c) = Category (f c)+mapCategory f (GreedyCategory c) = GreedyCategory (f c) mapCategory f (Optional ls) = Optional (mapCategory f <$> ls)+mapCategory f (GreedyOptional ls) = GreedyOptional (mapCategory f <$> ls) mapCategory _ Metathesis = Metathesis mapCategory _ Geminate = Geminate mapCategory f (Wildcard l) = Wildcard (mapCategory f l)@@ -139,7 +174,10 @@ mapCategory _ Discard = Discard mapCategory f (Backreference i c) = Backreference i (f c) mapCategory f (Multiple c) = Multiple (f c)+mapCategory f (Feature r n i kvs l) = Feature r n i kvs $ mapCategory f l+mapCategory _ (Autosegment n kvs gs) = Autosegment n kvs gs +-- | Like 'mapCategory', with an 'Applicative' effect. mapCategoryA     :: Applicative t     => (forall x. c x -> t (c' x))@@ -147,7 +185,9 @@     -> t (Lexeme c' a) mapCategoryA _ (Grapheme g) = pure $ Grapheme g mapCategoryA f (Category c) = Category <$> f c+mapCategoryA f (GreedyCategory c) = GreedyCategory <$> f c mapCategoryA f (Optional ls) = Optional <$> traverse (mapCategoryA f) ls+mapCategoryA f (GreedyOptional ls) = GreedyOptional <$> traverse (mapCategoryA f) ls mapCategoryA _ Metathesis = pure Metathesis mapCategoryA _ Geminate = pure Geminate mapCategoryA f (Wildcard l) = Wildcard <$> mapCategoryA f l@@ -155,9 +195,12 @@ mapCategoryA _ Discard = pure Discard mapCategoryA f (Backreference i c) = Backreference i <$> f c mapCategoryA f (Multiple c) = Multiple <$> f c+mapCategoryA f (Feature r n i kvs l) = Feature r n i kvs <$> mapCategoryA f l+mapCategoryA _ (Autosegment n kvs gs) = pure $ Autosegment n kvs gs --- | The type of a category after expansion.-newtype Expanded a = FromElements { elements :: [Either Grapheme [Lexeme Expanded a]] }+-- | The type of a category after expansion: a simple list of+-- 'CategoryElement's.+newtype Expanded a = FromElements { elements :: [CategoryElement Expanded a] }     deriving (Eq, Ord, Show, Generic, NFData)  instance Semigroup (Expanded a) where@@ -166,6 +209,9 @@ instance Monoid (Expanded a) where     mempty = FromElements [] +-- | Generalise a @'Lexeme' c ''AnyPart'@ so it can be used in any+-- specific part of a sound change, given a way to similarly+-- generalise any categories it contains. generalise :: (c 'AnyPart -> c a) -> Lexeme c 'AnyPart -> Lexeme c a generalise _ (Grapheme g) = Grapheme g generalise f (Category es) = Category $ f es@@ -174,13 +220,13 @@ generalise f (Backreference i es) = Backreference i $ f es generalise f (Wildcard l) = Wildcard $ generalise f l generalise f (Kleene l) = Kleene $ generalise f l+generalise f (Feature r n i kvs l) = Feature r n i kvs $ generalise f l+generalise _ (Autosegment n kvs gs) = Autosegment n kvs gs +-- | Generalise an 'Expanded' category to be used in any part of a+-- sound change, similarly to 'generalise'. generaliseExpanded :: Expanded 'AnyPart -> Expanded a-generaliseExpanded = FromElements . (fmap.fmap.fmap) (generalise generaliseExpanded) . elements---- | A 'Lexeme' matching a single word boundary, specified as @#@ in Brassica syntax.-pattern Boundary :: Lexeme c a-pattern Boundary = Grapheme GBoundary+generaliseExpanded = FromElements . (fmap.fmap) (generalise generaliseExpanded) . elements  deriving instance (forall x. Show (c x)) => Show (Lexeme c a) deriving instance (forall x. Eq (c x)) => Eq (Lexeme c a)@@ -189,26 +235,33 @@ instance (forall x. NFData (c x)) => NFData (Lexeme c a) where     rnf (Grapheme g) = rnf g     rnf (Category cs) = rnf cs+    rnf (GreedyCategory cs) = rnf cs     rnf (Optional ls) = rnf ls+    rnf (GreedyOptional ls) = rnf ls     rnf Metathesis = ()     rnf Geminate = ()     rnf (Wildcard l) = rnf l     rnf (Kleene l) = rnf l     rnf Discard = ()-    rnf (Backreference i l) = seq i $ rnf l+    rnf (Backreference i l) = i `deepseq` rnf l     rnf (Multiple l) = rnf l+    rnf (Feature r n i kvs l) = r `deepseq` l `deepseq` n `deepseq` i `deepseq` rnf kvs+    rnf (Autosegment n kvs gs) = n `deepseq` kvs `deepseq` rnf gs  -- | An 'Environment' is a tuple of @(before, after)@ components,--- corresponding to a ‘/ before _ after’ component of a sound change.+-- corresponding to an environment or exception in a sound change:+-- @before _ after@. ----- Note that an empty environment is just @([], [])@.+-- (An empty environment is just @([], [])@.) type Environment c = ([Lexeme c 'Matched], [Lexeme c 'Matched]) --- | Specifies application direction of rule — either left-to-right or right-to-left.+-- | Specifies application direction of rule: either left-to-right or right-to-left. data Direction = LTR | RTL     deriving (Eq, Show, Generic, NFData) --- | Specifies how regularly a rule should be applied.+-- | Specifies how regularly a rule should be applied. A sporadic+-- rule will produce two or more results, preserving the input as one+-- of the outputs. data Sporadicity     = ApplyAlways     -- ^ Always apply the rule@@ -221,10 +274,11 @@ -- | 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         :: Sporadicity+  { highlightChanges :: Bool         -- ^ Whether results from this sound change can be highlighted in a GUI+  , applyDirection   :: Direction    -- ^ Direction in which to apply the rule+  , applyOnceOnly    :: Bool         -- ^ Whether to apply the rule only once to a word+  , sporadic         :: Sporadicity  -- ^ Whether the rule should be applied sporadically, and if so, how+  , nonOverlappingTarget :: Bool     -- ^ Whether the rule should apply non-iteratively (avoiding environments which overlap with targets)   } deriving (Show, Generic, NFData)  -- | A default selection of flags which are appropriate for most@@ -236,29 +290,32 @@ --     , 'applyDirection' = 'LTR' --     , 'applyOnceOnly' = 'False' --     , 'sporadic' = 'False'+--     , 'nonOverlappingTarget' = 'False' --     } -- @ ----- That is: highlight changes, apply from left to right, apply--- repeatedly, and don’t apply sporadically.+-- That is: apply repeatedly and iteratively from left to right,+-- non-sporadically, with the results available for highlighting. defFlags :: Flags defFlags = Flags     { highlightChanges = True     , applyDirection = LTR     , applyOnceOnly = False     , sporadic = ApplyAlways+    , nonOverlappingTarget = False     } --- | A single sound change rule: in Brassica sound-change syntax with all elements specified,--- @-flags target / replacement \/ environment1 | environment2 | … \/ exception@.--- (And usually the 'plaintext' of the rule will contain a 'String' resembling that pattern.)+-- | A single sound change rule.+--+-- In Brassica sound-change syntax with all elements specified, this would be+-- @-flags target / replacement \/ environment1 \/ environment2 \/ … \/ exception@. data Rule c = Rule   { target      :: [Lexeme c 'Matched]   , replacement :: [Lexeme c 'Replacement]   , environment :: [Environment c]   , exception   :: Maybe (Environment c)   , flags       :: Flags-  , plaintext   :: String+  , plaintext   :: String  -- ^ Rule text before parsing (displayed e.g. for debugging purposes)   } deriving (Generic)  deriving instance (forall a. Show (c a)) => Show (Rule c)@@ -272,40 +329,67 @@ deriving instance (forall a. Show (c a)) => Show (Filter c) deriving instance (forall a. NFData (c a)) => NFData (Filter c) --- | A 'Statement' can be a single sound change rule, a filter,--- or a directive (e.g. category definition).+-- | A 'Statement' within a sound change file can be a single sound+-- change rule, a filter, an instruction to report intermediate+-- results, or some other declaration.+--+-- The declaration type depends on the current sound change+-- phase. Usually it will be 'Directive' after parsing, or+-- 'GraphemeList' after expansion. data Statement c decl-    = RuleS (Rule c)-    | FilterS (Filter c)-    | DirectiveS decl+    = RuleS (Rule c)        -- ^ Sound change rule+    | FilterS (Filter c)    -- ^ Filter+    | ReportS               -- ^ Report intermediate result+    | DeclS decl            -- ^ Declaration (phase-dependent)     deriving (Generic)  deriving instance (forall a. Show (c a), Show decl) => Show (Statement c decl) deriving instance (forall a. NFData (c a), NFData decl) => NFData (Statement c decl)  -- | A simple wrapper around 'plaintext' for 'Statement's. Returns--- @"<directive>"@ for all 'DirectiveS' inputs.+-- @"\<declaration\>"@ for all 'DeclS' inputs. plaintext' :: Statement c decl -> String plaintext' (RuleS r) = plaintext r plaintext' (FilterS (Filter p _)) = p-plaintext' (DirectiveS _) = "<directive>"+plaintext' ReportS = "intermediate result"+plaintext' (DeclS _) = "<declaration>"  -- | A set of 'SoundChanges' is simply a list of 'Statement's. type SoundChanges c decl = [Statement c decl]  -- | The individual operations used to construct a category in -- Brassica sound-change syntax.-data CategoryModification = Union | Intersect | Subtract+data CategoryModification+    = Union     -- ^ Written @[Category1 &Category2]@ or @[Category1 Category2]@+    | Intersect -- ^ Written @[Category1 +Category2]@+    | Subtract  -- ^ Written @[Category1 -Category2]@     deriving (Show, Eq, Ord, Generic, NFData) --- | The specification of a category in Brassica sound-change syntax.+-- | A single element of a category: a sequence of 'Lexeme's. (Single+-- v'Grapheme's receive some special treatment, e.g. they can be+-- written without surrounding braces in Brassica syntax.)+type CategoryElement category a = [Lexeme category a]++-- | The specification of a category in Brassica sound-change+-- syntax. Usually this will be as a 'CategorySpec': a list of+-- 'CategoryElement's, each of which modifies the previous definition+-- using the given 'CategoryModification' method.+--+-- In some positions (e.g. after a 'Backreference') a category must be+-- provided, but that category can be predefined, to be inlined during+-- expansion. In such positions, the given category name is stored as+-- a 'MustInline' category. (In other positions predefined categories+-- are indistinguishable from normal v'Grapheme's, and represented as+-- such.) data CategorySpec a-    = CategorySpec [(CategoryModification, Either Grapheme [Lexeme CategorySpec a])]+    = CategorySpec [(CategoryModification, CategoryElement CategorySpec a)]     | MustInline String  -- ^ A single grapheme assumed to have been specified earlier as a category     deriving (Show, Eq, Ord, Generic, NFData)  -- | The specification of a suprasegmental feature in Brassica -- sound-change syntax.+--+-- Deprecated since 1.0.0. data FeatureSpec = FeatureSpec     { featureBaseName :: Maybe String     , featureBaseValues :: CategorySpec 'AnyPart@@ -313,19 +397,32 @@     }     deriving (Show, Eq, Ord, Generic, NFData) --- | A definition of a new category, either directly or via features.+-- | A single definition within a category definition block. data CategoryDefinition     = DefineCategory String (CategorySpec 'AnyPart)+    -- ^ Defines a category with the given name and value     | DefineFeature FeatureSpec+    -- ^ Defines a feature as a set of categories+    | DefineAuto String+    -- ^ Defines a category as autosegmental     deriving (Show, Eq, Ord, Generic, NFData)  -- | A directive used in Brassica sound-change syntax: anything which--- is not actually a sound change-+-- occurs in a sound change file with the primary purpose of defining+-- something for later use. data Directive-    = Categories Bool Bool [CategoryDefinition]-      -- ^ @categories … end@: first 'Bool' for @new@,-      -- second for @noreplace@+    = Categories  -- ^ Category definition block+        Bool  -- ^ Whether category was introduced with @new@+        Bool  -- ^ Whether category was introduced with @noreplace@+        [CategoryDefinition]     | ExtraGraphemes [String]-      -- ^ @extra …@+      -- ^ Extra graphemes declaration: @extra …@     deriving (Show, Eq, Ord, Generic, NFData)++-- | A list of graphemes, replacing v'Categories' in expanded sound+-- changes. These are used in tokenisation to determine which+-- multigraphs are used, and in rule application to filter unwanted+-- graphemes. The first 'Bool' indicates whether filtration should+-- occur for any particular categories block.+data GraphemeList = GraphemeList Bool [Grapheme]+    deriving (Eq, Show, Ord, Generic, NFData)

@@ -0,0 +1,81 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Data.Functor ((<&>))+import Data.List (intercalate)+import Data.Maybe (mapMaybe)+import Data.Traversable (for)+import Text.Pandoc+import Test.Tasty (defaultMain, testGroup)+import Test.Tasty.Providers++import qualified Data.Text as T+import qualified Data.Text.IO as T++import Brassica.SoundChange (applyChanges, concatWithBoundary, getOutput)+import Brassica.SoundChange.Expand (expandSoundChanges)+import Brassica.SoundChange.Parse (parseSoundChanges, errorBundlePretty)+import Brassica.SoundChange.Tokenise (withFirstCategoriesDecl, tokeniseWord)++main :: IO ()+main = defaultMain $ testGroup "brassica-doctests"+    [ doctest "docs/Writing-Sound-Changes.md" ""+    , doctest "docs/Reference.md" "\+\categories noreplace\n\+\C = m n p t ch k b d j g f s sh h v z r l w y\n\+\-Stress = a e i o u\n\+\+Stress = á é í ó ú\n\+\auto -Stress\n\+\V = &&Stress\n\+\end\n"+    ]++doctest :: FilePath -> String -> TestTree+doctest file prefix = singleTest file $ DocTest file prefix++data DocTest = DocTest FilePath String++instance IsTest DocTest where+    testOptions = pure []+    run _ (DocTest path prefix) _ = do+        doc <- T.readFile path+        runIO (readMarkdown def { readerExtensions = githubMarkdownExtensions } doc) <&> \case+            Left err -> testFailed $ T.unpack $ renderError err+            Right (Pandoc _ blocks) ->+                let rules = flip mapMaybe blocks $ \case+                        CodeBlock (_, cs, _) text+                            | "brassica" `elem` cs+                            ->+                                let rule = prefix ++ T.unpack text+                                    examples = flip mapMaybe (T.lines text) $ \x ->+                                        case words $ T.unpack x of+                                            ";":i:"→":o:_ -> Just (i, o)+                                            _ -> Nothing+                                in Just (rule, examples)+                        _ -> Nothing+                    results = for rules $ \(rule, examples) ->+                        case parseSoundChanges rule of+                            Left err -> Left $ errorBundlePretty err+                            Right scs ->+                                case expandSoundChanges scs of+                                    Left err -> Left $ show err+                                    Right scs' -> for examples $ \(i, o) ->+                                        case withFirstCategoriesDecl tokeniseWord scs' i of+                                            Left err -> Left $ errorBundlePretty err+                                            Right i' ->+                                                let o' = mapMaybe getOutput $ applyChanges scs' i'+                                                    o'' =+                                                        if null o'+                                                        then "(deleted)"+                                                        else intercalate "/" $ concatWithBoundary <$> o'+                                                in if o == o''+                                                      then Right ("" :: String)+                                                      else Left $+                                                               "expected " ++ i ++ "→" ++ o +++                                                               ", got " ++ o'' +++                                                               "\nfor sound change:\n" ++ rule+                in case results of+                    Left err -> testFailed err+                    Right _ -> testPassed ""

@@ -5,6 +5,7 @@ import Conduit import Control.Category ((>>>)) import Control.Monad.Trans.Except (runExceptT, throwE)+import Data.Maybe (mapMaybe) import System.IO (IOMode(..), withFile) import Test.Tasty ( defaultMain, testGroup, TestTree ) import Test.Tasty.Golden (goldenVsFile)@@ -13,35 +14,35 @@ import qualified Data.ByteString.UTF8 as B8 import qualified Data.Text as T -import Brassica.SoundChange (applyChanges, splitMultipleResults, applyChangesWithLogs, reportAsText)-import Brassica.SoundChange.Category (expandSoundChanges)+import Brassica.SoundChange (applyChanges, getOutput, splitMultipleResults, reportAsText, GraphemeList)+import Brassica.SoundChange.Expand (expandSoundChanges) import Brassica.SoundChange.Parse (parseSoundChanges, errorBundlePretty) import Brassica.SoundChange.Tokenise (tokeniseWords, detokeniseWords, withFirstCategoriesDecl, Component, getWords)-import Brassica.SoundChange.Types (SoundChanges, PWord, plaintext', Expanded, Grapheme)+import Brassica.SoundChange.Types (SoundChanges, PWord, plaintext', Expanded)  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"+    [ changesTest ((mapMaybe getOutput .) . applyChanges) showWord "changes golden test" "words.out" "words.golden"+    , changesTest                           applyChanges  showLogs "changes golden test with log" "words-log.out" "words-log.golden"     ]   where     showWord = detokeniseWords . concatMap (splitMultipleResults " ")      showLogs logs = unlines $ fmap (reportAsText plaintext') $ concat $ getWords logs -proto21eTest-    :: (SoundChanges Expanded [Grapheme] -> PWord -> [a])+changesTest+    :: (SoundChanges Expanded GraphemeList -> PWord -> [a])     -> ([Component [a]] -> String)     -> String     -> FilePath     -> FilePath     -> TestTree-proto21eTest applyFn showWord testName outName goldenName =+changesTest 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")+            soundChangesData <- B8.toString <$> liftIO (B.readFile "test/changes.bsc")             soundChanges' <- catchEither (parseSoundChanges soundChangesData) $ \err -> do                 liftIO $ putStrLn $                     "Cannot parse the SCA file because:\n" ++@@ -59,7 +60,7 @@                     withFirstCategoriesDecl tokeniseWords soundChanges                     >>> (fmap.fmap.fmap) (applyFn soundChanges)                     >>> either prettyError prettyOutput-            liftIO $ withSourceFile "test/proto21e.in" $ flip connect+            liftIO $ withSourceFile "test/words.in" $ flip connect                 $ decodeUtf8C                 .| linesUnboundedC                 .| mapC (evolve . T.unpack)