brassica 0.2.0 → 0.3.0

raw patch · 18 files changed

+1027/−514 lines, 18 filesdep +fast-myers-diffdep +paralleldep ~optparse-applicativenew-component:exe:brassica-pbPVP ok

version bump matches the API change (PVP)

Dependencies added: fast-myers-diff, parallel

Dependency ranges changed: optparse-applicative

API changes (from Hackage documentation)

Files

• ChangeLog.md +58/−0
• bench/Changes.hs +14/−6
• bench/Paradigm.hs +3/−1
• brassica.cabal +21/−3
• cli-pb/Main.hs +80/−0
• cli/Main.hs +37/−19
• cli/Server.hs +17/−11
• src/Brassica/MDF.hs +0/−220
• src/Brassica/Paradigm.hs +1/−0
• src/Brassica/Paradigm/Apply.hs +9/−4
• src/Brassica/Paradigm/Parse.hs +1/−1
• src/Brassica/SFM/MDF.hs +233/−0
• src/Brassica/SFM/SFM.hs +184/−0
• src/Brassica/SoundChange/Apply/Internal.hs +187/−79
• src/Brassica/SoundChange/Category.hs +32/−14
• src/Brassica/SoundChange/Frontend/Internal.hs +70/−94
• src/Brassica/SoundChange/Parse.hs +32/−25
• src/Brassica/SoundChange/Types.hs +48/−37

@@ -1,5 +1,63 @@ # Brassica changelog +## 0.3.0++### Behaviour++- Bugfix: nested categories are now matched up correctly between target and replacement+- Bugfix: Brassica no longer freezes with rules where the target is entirely optional+- Bugfix: Brassica no longer crashes when a rule refers to nonexistent categories+- Wildcard symbols can now be used in the replacement of a rule+- Brassica now applies sound changes to words in parallel, giving a significant speedup on multi-core machines (though not in a webpage)+- New `extra` directive allows specifying characters which should never be replaced through all category redefinitions+- Improved placement of etymologies in MDF output+- Target and replacement can now be separated by `->`+- New `filter` directive allows removing unwanted results+- An improved heuristic for avoiding infinite loops in epenthesis rules,+    such that e.g. `/h/a_a` yields `aaaa`→`ahahaha` rather than previous unexpected *`ahaaha`+- New `-??` flag to allow for per-occurrence sporadicity+- `categories` directive can now be specified `noreplace`+    to prevent replacement of unknown graphemes with U+FFFD (�)+- Improved method for highlighting words ‘different to last run’+    (now using the Myers diff algorithm)+- Added syntax highlighting for flags+- Sound change rules can now be specified on the command-line using new `--eval` or `-e` flag+- Add CLI option to highlight words different to input+- Currently open files shown in title of desktop window+- Desktop application warns when closing with unsaved changes+- Improve user interface for file management in desktop paradigm builder+- New CLI for paradigm builder: program name `brassica-pb`++### Code++- `optparse-applicative` lower bound tightened to 0.17.1+- Bugfix: `Brassica.SoundChange.Apply.applyRuleStr` is no longer seriously broken+- `Brassica.SoundChange.Apply.Internal.applyOnce` now returns a `RuleStatus` value with more detailed information about the rule application, which is now used by `Brassica.SoundChange.Apply.Internal.setupForNextApplication`+- `Wildcard` and `Kleene` no longer have `OneOf 'Target 'Env` constraint+- `OneOf` type family is no longer used and has been removed+- `Target` and `Environment` `LexemeType`s have been unified as `Matched`+- `Brassica.SoundChange.Frontend.Internal.parseTokeniseAndApplyRules` now takes another argument specifying how to map over the parse output,+    allowing it to be run both on a single core and in parallel depending on the provided function+- `Brassica.SoundChange.Types.Directive` has a new constructor `ExtraGraphemes` for the `extra` directive, with corresponding changes in parsing and expansion+- `Brassica.SoundChange.Category.extend` has been renamed to `extendCategories`, and now requires pattern-matching on a `Categories` directive before use+- `Brassica.SoundChange.Frontend.Internal.parseTokeniseAndApplyRules` no longer implements rule expansion,+   allowing it to take place only once without needing to be repeated for each rule application.+- MDF support has been comprehensively rewritten:+  - `Brassica.MDF` has been removed+  - New module `Brassica.SFM.SFM` implements generic support for SIL Standard Field Marker hierarchies+  - New module `Brassica.SFM.MDF` describes the standard and alternate MDF hierarchies,+    and other necessary utilities for working with MDF documents+  - Some rewrites to `Brassica.SoundChange.Frontend.Internal` to account for the new architecture+- New type `Brassica.SoundChange.Types.Filter`, resulting in other changes:+  - New `FilterS` constructor added to `Brassica.SoundChange.Types.Statement`+  - `LogItem` and `PWordLog` (in `Brassica.SoundChange.Apply.Internal`) now use `Maybe PWord`+    to show cases where a word was deleted+  - Corresponding changes to parsing, expansion and application+- Rule sporadicity is now represented by a dedicated type, `Brassica.SoundChange.Types.Sporadicity`+- `Categories` constructor (in `Brassica.SoundChange.Types.Directive`)+    now has an extra field for `noreplace` directive+- Add useful function `Brassica.Paradigm.Apply.depth`+ ## v0.2.0  - Allow grapheme to begin with star

@@ -3,6 +3,7 @@ 
 module Main where
 
+import Control.Parallel.Strategies (withStrategy, parTraversable, rseq)
 import Criterion.Main (defaultMain, bench, nf, bgroup, Benchmark)
 import Data.FileEmbed (embedFile)
 import Data.Text (unpack)
@@ -35,12 +36,16 @@       [ bench "parse" $ nf parseSoundChanges manyChanges
       , bench "parseRun" $ case parseSoundChanges manyChanges of
             Left _ -> error "invalid changes file"
-            Right cs -> nf (parseTokeniseAndApplyRules
-                    cs
-                    manyWords
-                    Raw
-                    (ApplyRules NoHighlight WordsOnlyOutput "/"))
-                    Nothing
+            Right statements ->
+                case expandSoundChanges statements of
+                    Left _ -> error "invalid changes file"
+                    Right cs -> nf (parseTokeniseAndApplyRules
+                        (fmap . fmap)
+                        cs
+                        manyWords
+                        Raw
+                        (ApplyRules NoHighlight WordsOnlyOutput "/"))
+                        Nothing
       ]
     ]
   where
@@ -84,3 +89,6 @@ 
 manyWords :: String
 manyWords = unpack $ decodeUtf8 $(embedFile "bench/sample-words.lex")
+
+parFmap :: (a -> b) -> ParseOutput a -> ParseOutput b
+parFmap f = withStrategy (parTraversable rseq) . fmap f

@@ -3,6 +3,7 @@ module Main where  import Criterion.Main (bench, nf, defaultMain)+import Data.Foldable (toList)  import Brassica.Paradigm @@ -14,7 +15,8 @@     , bench "large" $ nf (build largeParadigm) largeWords     ]   where-    build = concatMap . applyParadigm+    build :: Paradigm -> [String] -> [String]+    build p = concatMap $ (toList .) $ applyParadigm p  smallParadigm :: Paradigm smallParadigm =

@@ -1,6 +1,6 @@ cabal-version:      2.0 name:               brassica-version:            0.2.0+version:            0.3.0 synopsis:           Featureful sound change applier description:   The Brassica library for the simulation of sound changes in historical linguistics and language construction.@@ -33,7 +33,8 @@                  , Brassica.SoundChange.Parse                  , Brassica.SoundChange.Tokenise                  , Brassica.SoundChange.Types-                 , Brassica.MDF+                 , Brassica.SFM.MDF+                 , Brassica.SFM.SFM                  , Brassica.Paradigm   other-modules:   Brassica.Paradigm.Apply                  , Brassica.Paradigm.Parse@@ -44,6 +45,7 @@                    base >=4.7 && <5                  , containers >=0.6 && <0.7                  , deepseq >=1.4 && <1.6+                 , fast-myers-diff ==0.0.0                  , megaparsec >=8.0 && <9.7                  , mtl >=2.2 && <2.4                  , parser-combinators >=1.2 && <1.3@@ -67,11 +69,26 @@                   , conduit ^>=1.3                   , conduit-extra ^>=1.3                   , deepseq >=1.4 && <1.6-                  , optparse-applicative ^>=0.17 || ^>=0.18+                  , optparse-applicative ^>=0.17.1 || ^>=0.18+                  , parallel ^>= 3.2                   , text >=1.2 && <2.2    default-language: Haskell2010 +executable brassica-pb+  main-is:          Main.hs+  hs-source-dirs:   cli-pb+  ghc-options:      -threaded -rtsopts -with-rtsopts=-N -Wall+  build-depends:+                    base >=4.7 && <5+                  , brassica+                  , bytestring >=0.10 && <0.13+                  , conduit ^>=1.3+                  , optparse-applicative ^>=0.17.1 || ^>=0.18+                  , text >=1.2 && <2.2++  default-language: Haskell2010+ benchmark changes-bench   type:             exitcode-stdio-1.0   main-is:          Changes.hs@@ -82,6 +99,7 @@                   , brassica                   , criterion >=1.5 && <1.7                   , file-embed >=0.0.15 && <0.0.16+                  , parallel ^>= 3.2                   , text >=1.2 && <1.3    default-language: Haskell2010

@@ -0,0 +1,80 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Main where++import Conduit+import qualified Data.ByteString as B+import Data.Foldable (toList)+import qualified Data.Text as T+import Data.Text (unpack, pack, Text)+import Data.Text.Encoding (decodeUtf8)+import Options.Applicative++import Brassica.Paradigm++main :: IO ()+main = execParser opts >>= \Options{..} -> do+    paradigmText <-+        case paradigm of+            FromFile paradigmFile -> unpack . decodeUtf8 <$> B.readFile paradigmFile+            FromEval s -> pure s++    case parseParadigm paradigmText of+        Left e -> putStrLn $ errorBundlePretty e+        Right p ->+            withSourceFileIf inRootsFile $ \inC ->+            withSinkFileIf outWordsFile $ \outC ->+            runConduit $+                inC+                .| decodeUtf8C+                .| linesUnboundedC+                .| mapC (processRoot nestedOutput p)+                .| unlinesC+                .| encodeUtf8C+                .| outC+  where+    opts = info (args <**> helper <**> simpleVersioner "v0.3.0") fullDesc++    args = Options+        <$> asum+            [ FromEval <$> strOption+                (long "eval" <> short 'e' <> help "Literal paradigm to run through (newline-separated, as in paradigm file)")+            , FromFile <$> strArgument+                (metavar "PARADIGM" <> help "File containing paradigm")+            ]+        <*> switch (long "nest" <> short 'n' <> help "Print output in nested format")+        <*> optional (strOption+            (long "in" <> short 'i' <> help "File containing input roots (if not specified will read from stdin)"))+        <*> optional (strOption+            (long "out" <> short 'o' <> help "File to which output words should be written (if not specified will write to stdout)"))++    -- duplicated from main CLI+    withSourceFileIf :: Maybe FilePath -> (ConduitM i B.ByteString IO () -> IO a) -> IO a+    withSourceFileIf = maybe ($ stdinC) withSourceFile++    withSinkFileIf :: Maybe FilePath -> (ConduitM B.ByteString o IO () -> IO a) -> IO a+    withSinkFileIf = maybe ($ stdoutC) withSinkFile++    processRoot :: Bool -> Paradigm -> Text -> Text+    processRoot nestedOutput p r =+        let output = applyParadigm p $ unpack r+        in if nestedOutput+            then addSpaces output $ pack $ formatNested id output+            else T.unlines $ pack <$> toList output++    -- careful: need to add spaces to the end of each item if making nested output+    -- so that adjacent items don’t run together!+    addSpaces :: ResultsTree a -> Text -> Text+    addSpaces t = flip T.append $ T.replicate (depth t) "\n"++data ParadigmInput = FromFile String | FromEval String+    deriving (Show)++data Options = Options+    { paradigm :: ParadigmInput+    , nestedOutput :: Bool+    , inRootsFile :: Maybe String+    , outWordsFile :: Maybe String+    }+    deriving (Show)

@@ -19,27 +19,40 @@ main = execParser opts >>= \case     Server -> serve     Options{..} -> do-        changesText <- unpack . decodeUtf8 <$> B.readFile rulesFile+        changesText <-+            case rules of+                FromFile rulesFile -> unpack . decodeUtf8 <$> B.readFile rulesFile+                FromEval s -> pure s          case parseSoundChanges changesText of             Left err ->                 putStrLn $ errorBundlePretty err-            Right rules ->-                withSourceFileIf inWordsFile $ \inC ->-                withSinkFileIf outWordsFile $ \outC ->-                runConduit $-                    inC-                    .| processWords (incrFor wordsFormat) rules wordsFormat outMode-                    .| outC+            Right scs ->+                case expandSoundChanges scs of+                    Left err -> putStrLn $ case err of+                        (NotFound s) -> "Could not find category: " ++ s+                        InvalidBaseValue -> "Invalid value used as base grapheme in feature definition"+                        MismatchedLengths -> "Mismatched lengths in feature definition"+                    Right rules' ->+                        withSourceFileIf inWordsFile $ \inC ->+                        withSinkFileIf outWordsFile $ \outC ->+                        runConduit $+                            inC+                            .| processWords (incrFor wordsFormat) rules' wordsFormat outMode+                            .| outC    where-    opts = info (args <**> helper <**> simpleVersioner "v0.2.0") fullDesc+    opts = info (args <**> helper <**> simpleVersioner "v0.3.0") fullDesc      args = batchArgs <|> serverArgs     serverArgs = flag' Server (long "server" <> help "Run server (for internal use only)")     batchArgs = Options-        <$> strArgument-            (metavar "RULES" <> help "File containing sound changes")+        <$> asum+            [ FromEval <$> strOption+                (long "eval" <> short 'e' <> help "Literal sound change(s) to evaluate (newline-separated, as in rules file)")+            , FromFile <$> strArgument+                (metavar "RULES" <> help "File containing sound changes")+            ]         <*> flag Raw MDF             (long "mdf" <> help "Parse input words in MDF format")         <*> (asum@@ -51,6 +64,8 @@                     (long "etymons" <> help "With --mdf, output MDF dictionary with etymologies")                 , flag' (ApplyRules NoHighlight WordsWithProtoOutput)                     (long "show-input" <> help "Output an input→output wordlist")+                , flag' (ApplyRules DifferentToInput WordsOnlyOutput)+                    (long "show-changed" <> help "Add [+] after all words different to input")                 , flag                     (ApplyRules NoHighlight WordsOnlyOutput)                     (ApplyRules NoHighlight WordsOnlyOutput)@@ -66,14 +81,18 @@     incrFor Raw = True     incrFor MDF = False +    -- duplicated in paradigm builder CLI     withSourceFileIf :: Maybe FilePath -> (ConduitM i B.ByteString IO () -> IO a) -> IO a     withSourceFileIf = maybe ($ stdinC) withSourceFile      withSinkFileIf :: Maybe FilePath -> (ConduitM B.ByteString o IO () -> IO a) -> IO a     withSinkFileIf = maybe ($ stdoutC) withSinkFile +data Rules = FromFile String | FromEval String+    deriving (Show)+ data Options = Options-    { rulesFile :: String+    { rules :: Rules     , wordsFormat :: InputLexiconFormat     , outMode :: ApplicationMode     , inWordsFile :: Maybe String@@ -85,7 +104,7 @@ processWords     :: (MonadIO m, MonadThrow m)     => Bool  -- split into lines?-    -> SoundChanges CategorySpec Directive+    -> SoundChanges Expanded [Grapheme]     -> InputLexiconFormat     -> ApplicationMode     -> ConduitT B.ByteString B.ByteString m ()@@ -96,7 +115,7 @@     .| throwOnLeft     .| encodeUtf8C   where-    evolve ws = parseTokeniseAndApplyRules rules ws wordsFormat outMode Nothing+    evolve ws = parseTokeniseAndApplyRules parFmap rules ws wordsFormat outMode Nothing      throwOnLeft :: (MonadThrow m, Exception e) => ConduitT (Either e r) r m ()     throwOnLeft = awaitForever $ \case@@ -104,13 +123,12 @@         Right r -> yield r      processApplicationOutput :: ApplicationOutput PWord (Statement Expanded [Grapheme]) -> Either ParseException Text-    processApplicationOutput (HighlightedWords cs) = Right $ pack $ detokeniseWords $ (fmap.fmap) fst cs+    processApplicationOutput (HighlightedWords cs) = Right $ pack $ detokeniseWords' highlight cs     processApplicationOutput (AppliedRulesTable is) = Right $ pack $ unlines $ reportAsText plaintext' <$> is     processApplicationOutput (ParseError e) = Left $ ParseException $ errorBundlePretty e-    processApplicationOutput (ExpandError e) = Left $ ParseException $ case e of-        (NotFound s) -> "Could not find category: " ++ s-        InvalidBaseValue -> "Invalid value used as base grapheme in feature definition"-        MismatchedLengths -> "Mismatched lengths in feature definition"++    highlight (w, False) = concatWithBoundary w+    highlight (w, True) = concatWithBoundary w ++ " [+]"  newtype ParseException = ParseException String     deriving Show

@@ -8,11 +8,12 @@ {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -module Server (serve) where+module Server (serve, parFmap) where  import Conduit (runConduit, (.|), stdinC, stdoutC, mapMC) 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.Parser (json') import Data.Aeson.TH (deriveJSON, defaultOptions, defaultTaggedObject, constructorTagModifier, sumEncoding, tagFieldName)@@ -102,19 +103,21 @@     in case parseSoundChanges changes of         Left e -> RespError $ "<pre>" ++ errorBundlePretty e ++ "</pre>"         Right statements ->-            let result' = parseTokeniseAndApplyRules statements input inFmt mode prev-            in case result' of-                ParseError e -> RespError $-                    "<pre>" ++ errorBundlePretty e ++ "</pre>"-                HighlightedWords result -> RespRules-                    (Just $ (fmap.fmap) fst result)-                    (escape $ detokeniseWords' highlightWord result)-                AppliedRulesTable items -> RespRules Nothing $-                    surroundTable $ concatMap (reportAsHtmlRows plaintext') items-                ExpandError err -> RespError $ ("<pre>"++) $ (++"</pre>") $ case err of+            case expandSoundChanges statements of+                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"                     MismatchedLengths -> "Mismatched lengths in feature definition"+                Right statements' ->+                    let result' = parseTokeniseAndApplyRules parFmap statements' input inFmt mode prev+                    in case result' of+                        ParseError e -> RespError $+                            "<pre>" ++ errorBundlePretty e ++ "</pre>"+                        HighlightedWords result -> RespRules+                            (Just $ (fmap.fmap) fst result)+                            (escape $ detokeniseWords' highlightWord result)+                        AppliedRulesTable items -> RespRules Nothing $+                            surroundTable $ concatMap (reportAsHtmlRows plaintext') items   where     highlightWord (s, False) = concatWithBoundary s     highlightWord (s, True) = "<b>" ++ concatWithBoundary s ++ "</b>"@@ -122,6 +125,9 @@     surroundTable :: String -> String     surroundTable s = "<table>" ++ s ++ "</table>" parseTokeniseAndApplyRulesWrapper _ = error "parseTokeniseAndApplyRulesWrapper: unexpected request!"++parFmap :: (a -> b) -> [Component a] -> [Component b]+parFmap f = withStrategy (parTraversable rseq) . fmap (fmap f)  parseAndBuildParadigmWrapper :: Request -> Response parseAndBuildParadigmWrapper ReqParadigm{..} =

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

@@ -10,6 +10,7 @@        , Statement(..)        , Paradigm        , ResultsTree(..)+       , depth        , applyParadigm        , parseParadigm        , formatNested

@@ -6,6 +6,7 @@        ( ResultsTree(..)        , applyParadigm        , formatNested+       , depth        ) where  import Brassica.Paradigm.Types@@ -22,6 +23,10 @@ addLevel f (Result r) = Node $ Result <$> f r addLevel f (Node rs) = Node $ addLevel f <$> rs +depth :: ResultsTree a -> Int+depth (Node ts) = maximum $ (1+) . depth <$> ts+depth (Result _) = 0+ -- | Formats a 'ResultsTree' in a nested way, where the lowest-level -- elements are separated by one space, the second-lowest are -- separated by one newline, the third-lowest by two newlines, and so@@ -32,12 +37,12 @@     go (Result a) = (0, f a)     go (Node rts) =         let (depths, formatted) = unzip $ go <$> rts-            depth = maximum depths+            depth' = maximum depths             separator =-                if depth == 0+                if depth' == 0                 then " "-                else replicate depth '\n'-        in (1+depth, intercalate separator formatted)+                else replicate depth' '\n'+        in (1+depth', intercalate separator formatted)  -- | Apply the given 'Paradigm' to a root, to produce all possible -- derived forms.

@@ -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.2.0/Documentation.md#paradigm-builder>.
+-- For details on the syntax, refer to <https://github.com/bradrn/brassica/blob/v0.3.0/Documentation.md#paradigm-builder>.
 parseParadigm :: String -> Either (ParseErrorBundle String Void) Paradigm
 parseParadigm = runParser (many statement) ""

@@ -0,0 +1,233 @@+{-# 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 where++import Brassica.SFM.SFM++import qualified Data.Map as M+import Brassica.SoundChange.Tokenise+import Brassica.SoundChange.Types (PWord)+import Text.Megaparsec (State(..), PosState (..), ParseErrorBundle, runParser')+import Text.Megaparsec.State (initialPosState)+import Data.Void (Void)+import Data.Char (isSpace)+import Data.List (dropWhileEnd)++-- | The designated language of an MDF field.+data MDFLanguage = English | National | Regional | Vernacular | Other+    deriving (Eq, Show)++-- | A 'M.Map' from the most common field markers to the language of+-- their values.+--+-- (Note: This is currently hardcoded in the source code, based on the+-- values in the MDF definitions from SIL Toolbox. The exception is+-- @\et@, which is assigned as 'Other' rather than+-- 'Vernacular'. There’s probably a more principled way of defining+-- this, but hardcoding should suffice for now.)+fieldLangs :: M.Map String MDFLanguage+fieldLangs = M.fromList+    [ ("1d" , Vernacular) , ("1e" , Vernacular) , ("1i" , Vernacular)+    , ("1p" , Vernacular) , ("1s" , Vernacular) , ("2d" , Vernacular)+    , ("2p" , Vernacular) , ("2s" , Vernacular) , ("3d" , Vernacular)+    , ("3p" , Vernacular) , ("3s" , Vernacular) , ("4d" , Vernacular)+    , ("4p" , Vernacular) , ("4s" , Vernacular) , ("a"  , Vernacular)+    , ("an" , Vernacular) , ("bb" , English)    , ("bw" , English)+    , ("ce" , English)    , ("cf" , Vernacular) , ("cn" , National)+    , ("cr" , National)   , ("de" , English)    , ("dn" , National)+    , ("dr" , Regional)   , ("dt" , Other)      , ("dv" , Vernacular)+    , ("ec" , English)    , ("ee" , English)    , ("eg" , English)+    , ("en" , National)   , ("er" , Regional)   , ("es" , English)+    , ("et" , Other)  {- defined as vernacular in SIL Toolbox, but by+                         definition it's really a different language -}+    , ("ev" , Vernacular) , ("ge" , English)+    , ("gn" , National)   , ("gr" , Regional)   , ("gv" , Vernacular)+    , ("hm" , English)    , ("is" , English)    , ("lc" , Vernacular)+    , ("le" , English)    , ("lf" , English)    , ("ln" , National)+    , ("lr" , Regional)   , ("lt" , English)    , ("lv" , Vernacular)+    , ("lx" , Vernacular) , ("mn" , Vernacular) , ("mr" , Vernacular)+    , ("na" , English)    , ("nd" , English)    , ("ng" , English)+    , ("np" , English)    , ("nq" , English)    , ("ns" , English)+    , ("nt" , English)    , ("oe" , English)    , ("on" , National)+    , ("or" , Regional)   , ("ov" , Vernacular) , ("pc" , English)+    , ("pd" , English)    , ("pde", English)    , ("pdl", English)+    , ("pdn", National)   , ("pdr", Regional)   , ("pdv", Vernacular)+    , ("ph" , Other)      , ("pl" , Vernacular) , ("pn" , National)+    , ("ps" , English)    , ("rd" , Vernacular) , ("re" , English)+    , ("rf" , English)    , ("rn" , National)   , ("rr" , Regional)+    , ("sc" , English)    , ("sd" , English)    , ("se" , Vernacular)+    , ("sg" , Vernacular) , ("sn" , English)    , ("so" , English)+    , ("st" , English)    , ("sy" , Vernacular) , ("tb" , English)+    , ("th" , Vernacular) , ("u"  , Vernacular) , ("ue" , English)+    , ("un" , National)   , ("ur" , Regional)   , ("uv" , Vernacular)+    , ("va" , Vernacular) , ("ve" , English)    , ("vn" , National)+    , ("vr" , Regional)   , ("we" , English)    , ("wn" , National)+    , ("wr" , Regional)   , ("xe" , English)    , ("xn" , National)+    , ("xr" , Regional)   , ("xv" , Vernacular)+    ]++-- | Standard MDF hierarchy: with @\lx@ > @\se@ > @\ps@ > @\sn@.+-- Intended for use with 'toTree'.+mdfHierarchy :: Hierarchy+mdfHierarchy = M.fromList+    [ ("1d", "ps"), ("1e", "ps"), ("1i", "ps"), ("1p", "ps"), ("1s", "ps")+    , ("2d", "ps"), ("2p", "ps"), ("2s", "ps"), ("3d", "ps"), ("3p", "ps")+    , ("3s", "ps"), ("4d", "ps"), ("4p", "ps"), ("4s", "ps"), ("a", "lx")+    , ("an", "sn"), ("bb", "sn"), ("bw", "se"), ("ce", "cf"), ("cf", "sn")+    , ("cn", "cf"), ("cr", "cf"), ("de", "sn"), ("dn", "sn"), ("dr", "sn")+    , ("dt", "lx"), ("dv", "sn"), ("ec", "et"), ("ee", "sn"), ("eg", "et")+    , ("en", "sn"), ("er", "sn"), ("es", "et"), ("et", "se"), ("ev", "sn")+    , ("ge", "sn"), ("gn", "sn"), ("gr", "sn"), ("gv", "sn"), ("hm", "lx")+    , ("is", "sn"), ("lc", "lx"), ("le", "lv"), ("lf", "sn"), ("ln", "lv")+    , ("lr", "lv"), ("lt", "sn"), ("lv", "lf"), ("mn", "se"), ("mr", "se")+    , ("na", "sn"), ("nd", "sn"), ("ng", "sn"), ("np", "sn"), ("nq", "sn")+    , ("ns", "sn"), ("nt", "sn"), ("oe", "sn"), ("on", "sn"), ("or", "sn")+    , ("ov", "sn"), ("pc", "sn"), ("pd", "ps"), ("pde", "pdl")+    , ("pdl", "pd"), ("pdn", "pdl"), ("pdr", "pdl"), ("pdv", "pdl")+    , ("ph", "se"), ("pl", "ps"), ("pn", "ps"), ("ps", "se"), ("rd", "ps")+    , ("re", "sn"), ("rf", "sn"), ("rn", "sn"), ("rr", "sn"), ("sc", "sn")+    , ("sd", "sn"), ("se", "lx"), ("sg", "ps"), ("sn", "ps"), ("so", "sn")+    , ("st", "lx"), ("sy", "sn"), ("tb", "sn"), ("th", "sn"), ("u", "lx")+    , ("ue", "sn"), ("un", "sn"), ("ur", "sn"), ("uv", "sn"), ("va", "sn")+    , ("ve", "va"), ("vn", "va"), ("vr", "va"), ("we", "sn"), ("wn", "sn")+    , ("wr", "sn"), ("xe", "xv"), ("xn", "xv"), ("xr", "xv"), ("xv", "rf")+    ]++-- | Alternate MDF hierarchy: with @\lx@ > @\sn@ > @\se@ > @\ps@.+-- Intended for use with 'toTree'.+mdfAlternateHierarchy :: Hierarchy+mdfAlternateHierarchy = M.fromList+    [ ("1d", "ps"), ("1e", "ps"), ("1i", "ps"), ("1p", "ps"), ("1s", "ps")+    , ("2d", "ps"), ("2p", "ps"), ("2s", "ps"), ("3d", "ps"), ("3p", "ps")+    , ("3s", "ps"), ("4d", "ps"), ("4p", "ps"), ("4s", "ps")+    , ("an", "ps"), ("bb", "ps"), ("bw", "se"), ("ce", "cf"), ("cf", "ps")+    , ("cn", "cf"), ("cr", "cf"), ("de", "ps"), ("dn", "ps"), ("dr", "ps")+    , ("dt", "lx"), ("dv", "ps"), ("ec", "et"), ("ee", "ps"), ("eg", "et")+    , ("en", "ps"), ("er", "ps"), ("es", "et"), ("et", "se"), ("ev", "ps")+    , ("ge", "ps"), ("gn", "ps"), ("gr", "ps"), ("gv", "ps"), ("hm", "lx")+    , ("is", "ps"), ("lc", "lx"), ("le", "lv"), ("lf", "ps"), ("ln", "lv")+    , ("lr", "lv"), ("lt", "ps"), ("lv", "lf"), ("mn", "se"), ("mr", "se")+    , ("na", "ps"), ("nd", "ps"), ("ng", "ps"), ("np", "ps"), ("nq", "ps")+    , ("ns", "ps"), ("nt", "ps"), ("oe", "ps"), ("on", "ps"), ("or", "ps")+    , ("ov", "ps"), ("pc", "ps"), ("pd", "ps"), ("pde", "pdl")+    , ("pdl", "pd"), ("pdn", "pdl"), ("pdr", "pdl"), ("pdv", "pdl")+    , ("ph", "se"), ("pl", "ps"), ("pn", "ps"), ("ps", "se"), ("rd", "ps")+    , ("re", "ps"), ("rf", "ps"), ("rn", "ps"), ("rr", "ps"), ("sc", "ps")+    , ("sd", "ps"), ("se", "sn"), ("sg", "ps"), ("sn", "lx"), ("so", "ps")+    , ("st", "lx"), ("sy", "ps"), ("tb", "ps"), ("th", "ps")+    , ("ue", "ps"), ("un", "ps"), ("ur", "ps"), ("uv", "ps"), ("va", "se")+    , ("ve", "va"), ("vn", "va"), ("vr", "va"), ("we", "ps"), ("wn", "ps")+    , ("wr", "ps"), ("xe", "xv"), ("xn", "xv"), ("xr", "xv"), ("xv", "rf")+    ]++-- | Convert an 'SFM' document to a list of 'Component's representing+-- the same textual content. 'Vernacular' field values are tokenised as+-- 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.+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'.+tokeniseField :: [String] -> Field -> Either (ParseErrorBundle String Void) [Component PWord]+tokeniseField gs f = case M.lookup (fieldMarker f) fieldLangs of+    Just Vernacular ->+        let ps = initialPosState "" (fieldValue f)+            s = State+                { stateInput = fieldValue f+                , stateOffset = 0+                , statePosState = case fieldSourcePos f of+                    Nothing -> ps+                    Just sp -> ps { pstateSourcePos = sp }+                , stateParseErrors = []+                }+        in case runParser' (componentsParser $ wordParser "[" gs) s of+            (_, Right cs) -> Right $ Separator ('\\' : fieldMarker f ++ fieldWhitespace f) : cs+            (_, Left err) -> Left err++    _ -> Right [Separator $ '\\' : fieldMarker f ++ fieldWhitespace f ++ fieldValue f]++-- | Add etymological fields to an 'MDF' by duplicating the values in+-- @\lx@, @\se@ and @\ge@ fields. e.g.:+--+-- > \lx kapa+-- > \ps n+-- > \ge parent+-- > \se sakapa+-- > \ge father+--+-- Would become:+--+-- > \lx kapa+-- > \ps n+-- > \ge parent+-- > \et kapa+-- > \eg parent+-- > \se sakapa+-- > \ge father+-- > \et sakapa+-- > \eg father+--+-- This can be helpful when applying sound changes to an MDF file: the+-- vernacular words can be copied as etymologies, and then the sound+-- changes can be applied leaving the etymologies as is.
+duplicateEtymologies+    :: (String -> String)+    -- ^ Transformation to apply to etymologies, e.g. @('*':)@+    -> SFMTree+    -> SFMTree+duplicateEtymologies f = go Nothing Nothing+  where+    -- strategy: find each \se (implicit or explicit) with its \ge+    -- and make an \et under it+    go lx gl (Root ts) = Root $ go lx gl <$> ts+    go _lx gl t@(Filled m@(Field { fieldMarker="lx", fieldValue }) ts) =+        let lx = Just fieldValue+            gl' = case searchField isGloss t of+                gl'':_ -> Just gl''+                _ -> gl+        in Filled m $ go lx gl' <$> ts+    go _lx gl t@(Filled m@(Field { fieldMarker="se", fieldValue }) ts) =+        let lx = Just fieldValue+            gl' = case searchField isGloss t of+                gl'':_ -> Just gl''+                _ -> gl+        in Filled m $ ts ++ mkEt lx gl'+    go lx gl (Filled m ts) = Filled m $ go lx gl <$> ts+    go lx gl (Missing "se" ts) = Missing "se" $ ts ++ mkEt lx gl+    go lx gl (Missing m ts) = Missing m $ go lx gl <$> ts++    isGloss Field{fieldMarker,fieldValue}+        | fieldMarker == "ge" = Just fieldValue+        | otherwise = Nothing++    mkEt :: Maybe String -> Maybe String -> [SFMTree]+    mkEt Nothing _ = []  -- can't make etymology without lexeme+    mkEt (Just lx) gl = pure $+        Filled Field+            { fieldMarker = "et"+            , fieldWhitespace = " "+            , fieldSourcePos = Nothing+            , fieldValue = f $ trim lx+            }+        $ case gl of+              Nothing -> []+              Just gl' ->+                  [ Filled Field+                      { fieldMarker = "eg"+                      , fieldWhitespace = " "+                      , fieldSourcePos = Nothing+                      , fieldValue = gl'+                        -- no need to add newline here because 'gl'+                        -- should already have whitespace+                      } []+                  ]++    trim = dropWhile isSpace . dropWhileEnd isSpace

@@ -0,0 +1,184 @@+{-# 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
+       ( -- * Linear SFM documents
+         Field(..)
+       , SFM
+       , parseSFM
+       , exactPrintField
+       , exactPrintSFM
+       , stripSourcePos
+         -- * Hierarchies
+       , Hierarchy
+       , SFMTree(..)
+       , toTree
+       , fromTree
+       , mapField
+       , searchField
+       ) where
+
+import Data.Char (isSpace)
+import Data.Maybe (fromMaybe)
+import Data.Void (Void)
+
+import Text.Megaparsec
+import Text.Megaparsec.Char
+
+import qualified Data.Map as M
+
+-- | A single field of an SFM file.
+data Field = Field
+    { fieldMarker :: String
+    -- ^ The field marker, ommitting the initial backslash
+    , fieldWhitespace :: String
+    -- ^ Whitespace after the field marker
+    , fieldSourcePos :: Maybe SourcePos
+    -- ^ Optionally, a Megaparsec 'SourcePos' marking the start of the value
+    , fieldValue :: String
+    -- ^ The value of the field, including all whitespace until the next marker
+    } deriving (Show)
+
+-- | An SFM file, being a list of fields.
+type SFM = [Field]
+
+-- | Set the 'fieldSourcePos' of a 'Field' to 'Nothing'. Useful for
+-- making debug output shorter.
+stripSourcePos :: Field -> Field
+stripSourcePos f = f { fieldSourcePos = Nothing }
+
+type Parser = Parsec Void String
+
+sc :: Parser String
+sc = fmap (fromMaybe "") $ optional $
+    takeWhile1P (Just "white space") ((&&) <$> isSpace <*> (/='\n'))
+
+-- | Parse until the next backslash at the beginning of a line.
+parseFieldValue :: Parser String
+parseFieldValue = do
+    val <- takeWhileP Nothing (/= '\n')
+    observing (char '\n') >>= \case
+        Left _ -> val <$ eof
+        Right _ -> do
+            let val' = val++"\n"
+            -- parse more lines if no following backslash
+            (notFollowedBy (char '\\') *> ((val'++) <$> parseFieldValue))
+                <|> pure val'
+
+entry :: Parser (String, String, SourcePos, String)
+entry = do
+    _ <- char '\\'
+    marker <- takeWhile1P (Just "field name") (not . isSpace)
+    s <- sc
+    ps <- getSourcePos
+    value <- parseFieldValue
+    pure (marker, s, ps, value)
+
+-- | Parse an SFM file to an 'SFM'.
+parseSFM
+    :: String  -- ^ Name of source file
+    -> String  -- ^ Input SFM data to parse
+    -> Either (ParseErrorBundle String Void) SFM
+parseSFM = runParser (sc *> many (toField <$> entry) <* eof)
+  where
+    toField (f, s, p, v) = Field f s (Just p) v
+
+-- | Print a single field as 'String'.
+exactPrintField :: Field -> String
+exactPrintField f = '\\' : fieldMarker f ++ fieldWhitespace f ++ fieldValue f
+
+-- | Given an 'SFM', reconstruct the original file. A trivial wrapper
+-- around 'exactPrintField'.
+exactPrintSFM :: SFM -> String
+exactPrintSFM = concatMap exactPrintField
+
+-- | Rose tree describing a hierarchical SFM document.
+data SFMTree
+    = Root [SFMTree]             -- ^ Root node
+    | Filled Field [SFMTree]     -- ^ A 'Field' with zero or more children.
+    | Missing String [SFMTree]
+    -- ^ A missing level of the hierarchy: a marker which is inferred
+    -- from the presence of its children.
+    deriving (Show)
+
+-- | The hierarchy underlying an SFM document, defined as a map from
+-- field names to their parents. Unlisted fields are treated as roots.
+type Hierarchy = M.Map String String
+
+-- | Returns the full hierarchy of a marker, starting with its
+-- immediate parent and finishing with the root.
+hierarchyFor :: Hierarchy -> String -> [String]
+hierarchyFor h = go
+  where
+    go :: String -> [String]
+    go m = case M.lookup m h of
+        Just m' -> m' : go m'
+        Nothing -> []
+
+(<+:>) :: SFMTree -> SFMTree -> SFMTree
+(Root s) <+:> t = Root (s ++ [t])
+(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.
+toTree :: Hierarchy -> SFM -> SFMTree
+toTree h = fst . go (Root [])
+  where
+    go :: SFMTree -> SFM -> (SFMTree, SFM)
+    go t [] = (t, [])
+    go s@(Root _) (f:fs) =
+        let (subtree, fs') = go (Filled f []) fs
+        in go (s <+:> subtree) fs'
+    go s (f:fs) =
+        let parentMarker = case s of
+                Filled (Field{fieldMarker=m}) _ -> m
+                Missing m _ -> m
+            hierarchy = hierarchyFor h (fieldMarker f)
+        in case break (==parentMarker) hierarchy of
+            -- this marker is unrelated to parentMarker, need to
+            -- rewind back up the tree and try again
+            (_, []) -> (s, f:fs)
+
+            -- otherwise this marker belongs somewhere under
+            -- parentMarker
+
+            -- if it is an immediate child, add the subtree directly
+            ([], _) ->
+                let (subtree, fs') = go (Filled f []) fs
+                in go (s <+:> subtree) fs'
+
+            -- otherwise, recurse into the hierarchy
+            (m:_, _) ->
+                let (subtree, fs') = go (Missing m []) (f:fs)
+                in go (s <+:> subtree) fs'
+
+-- | Inverse of 'toTree': convert an 'SFMTree' back into a linear
+-- 'SFM' document.
+fromTree :: SFMTree -> SFM
+fromTree (Root s) = concatMap fromTree s
+fromTree (Filled f s) = f : concatMap fromTree s
+fromTree (Missing _ s) = concatMap fromTree s
+
+-- | Map a function over all the 'Field's in an 'SFMTree'.
+mapField :: (Field -> Field) -> SFMTree -> SFMTree
+mapField g (Root s) = Root $ mapField g <$> s
+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'.
+searchField :: (Field -> Maybe a) -> SFMTree -> [a]
+searchField p (Root ts) = searchField p =<< ts
+searchField p (Filled f ts)
+    | Just a <- p f = a : (searchField p =<< ts)
+    | otherwise     =      searchField p =<< ts
+searchField p (Missing _ ts) = searchField p =<< ts

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns         #-}
 {-# LANGUAGE CPP                  #-}
 {-# LANGUAGE ConstraintKinds       #-}
 {-# LANGUAGE DataKinds             #-}
@@ -18,7 +19,6 @@ {-# LANGUAGE TupleSections         #-}
 {-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE UndecidableInstances  #-}
-{-# LANGUAGE ViewPatterns          #-}
 
 {-| __Warning:__ This module is __internal__, and does __not__ follow
   the Package Versioning Policy. It may be useful for extending
@@ -26,9 +26,11 @@   this module.
 -}
 module Brassica.SoundChange.Apply.Internal
-       ( -- * Types
-         RuleTag(..)
+       (
        -- * Lexeme matching
+         RuleTag(..)
+       , RuleStatus(..)
+       , MatchOutput(..)
        , match
        , matchMany
        , matchMany'
@@ -84,9 +86,9 @@ -- too).
 newtype RuleAp a = RuleAp { runRuleAp :: MultiZipper RuleTag Grapheme -> [(a, MultiZipper RuleTag Grapheme)] }
     deriving (Functor, Applicative, Monad, MonadState (MultiZipper RuleTag Grapheme)
-#if __GLASGOW_HASKELL__ > 806
+
     , MonadFail
-#endif
+
     )
       via (StateT (MultiZipper RuleTag Grapheme) [])
 
@@ -115,6 +117,10 @@       matchedCatIxs    :: [Int]
       -- | For each optional group whether it matched or not
     , matchedOptionals :: [Bool]
+      -- | For each wildcard, the graphemes which it matched
+    , matchedWildcards :: [[Grapheme]]
+      -- | For each Kleene star, how many repititions it matched
+    , matchedKleenes   :: [Int]
       -- | The graphemes which were matched
     , matchedGraphemes :: [Grapheme]
     } deriving (Show)
@@ -126,45 +132,50 @@ appendGrapheme out g = modifyMatchedGraphemes (++[g]) out
 
 instance Semigroup MatchOutput where
-    (MatchOutput a1 b1 c1) <> (MatchOutput a2 b2 c2) = MatchOutput (a1++a2) (b1++b2) (c1++c2)
+    (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
 
+-- Note: see c37afd7028afd4f610d8701799fb6857e2f9b3d9
+-- for motivation for the below functions
+
+insertAt :: Int -> a -> [a] -> [a]
+insertAt n a as = let (xs,ys) = splitAt n as in xs ++ (a:ys)
+
+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 }
+
 -- | Match a single 'Lexeme' against a 'MultiZipper', and advance the
 -- 'MultiZipper' past the match. For each match found, returns the
 -- 'MatchOutput' tupled with the updated 'MultiZipper'.
-match :: forall a t.
-         OneOf a 'Target 'Env
-      => MatchOutput          -- ^ The previous 'MatchOutput'
+match :: MatchOutput          -- ^ The previous 'MatchOutput'
       -> Maybe Grapheme       -- ^ The previously-matched grapheme, if any. (Used to match a 'Geminate'.)
-      -> Lexeme Expanded a    -- ^ The lexeme to match.
+      -> Lexeme Expanded 'Matched  -- ^ The lexeme to match.
       -> MultiZipper t Grapheme   -- ^ The 'MultiZipper' to match against.
       -> [(MatchOutput, MultiZipper t Grapheme)]
       -- ^ The output: a tuple @(g, mz)@ as described below.
 match out prev (Optional l) mz =
-    (out <> MatchOutput [] [False] [], mz) :
-    matchMany (out <> MatchOutput [] [True] []) prev l mz
-match out prev w@(Wildcard l) mz = case match out prev l mz of
-    [] -> maybeToList (consume mz) >>= \case
-        (GBoundary, _) -> []   -- don't continue past word boundary
-        (g, mz') -> match (appendGrapheme out g) prev w mz'
-    r -> r
-match out prev k@(Kleene l) mz = case match out prev l mz of
-    [] -> [(MatchOutput [] [] [], mz)]
-    r -> r >>= \(out', mz') -> case match out' prev k mz' of
-        [] -> error "match: Kleene should never fail"
-        r' -> r'
-match out _ (Grapheme g) mz = (out <> MatchOutput [] [] [g],) <$> maybeToList (matchGrapheme g mz)
+    (out <> MatchOutput [] [False] [] [] [], mz) :
+    matchMany (out <> MatchOutput [] [True] [] [] []) prev l mz
+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 prev (Category (FromElements gs)) mz =
     concat $ zipWith' gs [0..] $ \e i ->
-        first (<> MatchOutput [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
 match out prev Geminate mz = case prev of
     Nothing -> []
-    Just prev' -> (out <> MatchOutput [] [] [prev'],) <$> maybeToList (matchGrapheme prev' mz)
+    Just prev' -> (out <> MatchOutput [] [] [] [] [prev'],) <$> maybeToList (matchGrapheme prev' mz)
 match out prev (Backreference i (FromElements gs)) mz = do
     e <- maybeToList $
         (gs !?) =<< matchedCatIxs out !? (i-1)
@@ -172,6 +183,40 @@         Left  g  -> match out prev (Grapheme g :: Lexeme Expanded a) mz
         Right ls -> matchMany out prev ls mz
 
+matchKleene
+    :: MatchOutput
+    -> Maybe Grapheme
+    -> Lexeme Expanded 'Matched
+    -> MultiZipper t Grapheme
+    -> [(MatchOutput, MultiZipper t Grapheme)]
+matchKleene origOut = go 0 origOut
+  where
+    go !n out prev l mz = case match out prev l mz of
+        [] -> [
+            ( insertAtKleene (length $ matchedKleenes origOut) n out
+            , mz
+            ) ]
+        r -> r >>= \(out', mz') -> go (n+1) out' prev l mz'
+
+matchWildcard
+    :: MatchOutput
+    -> Maybe Grapheme
+    -> Lexeme Expanded 'Matched
+    -> MultiZipper t Grapheme
+    -> [(MatchOutput, MultiZipper t Grapheme)]
+matchWildcard = go []
+  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
+            (g, mz') -> go (g:matched) (appendGrapheme out g) prev l mz'
+        r -> r <&> \(out', mz') ->
+            ( out'
+              { matchedWildcards = matchedWildcards out' ++ [reverse matched]
+              }
+            , mz'
+            )
+
 matchGrapheme :: Grapheme -> MultiZipper t Grapheme -> Maybe (MultiZipper t Grapheme)
 matchGrapheme g = matchGraphemeP (==g)
 
@@ -182,10 +227,9 @@ -- 'MultiZipper'. Arguments and output are the same as with 'match',
 -- though the outputs are given as a list of indices and graphemes
 -- rather than as a single index and grapheme.
-matchMany :: OneOf a 'Target 'Env
-          => MatchOutput
+matchMany :: MatchOutput
           -> Maybe Grapheme
-          -> [Lexeme Expanded a]
+          -> [Lexeme Expanded 'Matched]
           -> MultiZipper t Grapheme
           -> [(MatchOutput, MultiZipper t Grapheme)]
 matchMany out _ [] mz = [(out, mz)]
@@ -194,12 +238,11 @@     matchMany  out' (lastMay (matchedGraphemes out') <|> prev) ls mz'
 
 -- | 'matchMany' without any previous match output.
-matchMany' :: OneOf a 'Target 'Env
-          => Maybe Grapheme
-          -> [Lexeme Expanded a]
+matchMany' :: Maybe Grapheme
+          -> [Lexeme Expanded 'Matched]
           -> MultiZipper t Grapheme
           -> [(MatchOutput, MultiZipper t Grapheme)]
-matchMany' = matchMany (MatchOutput [] [] [])
+matchMany' = matchMany (MatchOutput [] [] [] [] [])
 
 -- Small utility function, not exported
 lastMay :: [a] -> Maybe a
@@ -208,6 +251,8 @@ data ReplacementIndices = ReplacementIndices
     { ixInCategories :: Int
     , ixInOptionals :: Int
+    , ixInWildcards :: Int
+    , ixInKleenes :: Int
     , forcedCategory :: Maybe CategoryNumber
     } deriving (Show)
 
@@ -229,6 +274,16 @@     let i = ixInOptionals ix
     in (i, ix { ixInOptionals = i+1 })
 
+advanceWildcard :: ReplacementIndices -> (Int, ReplacementIndices)
+advanceWildcard ix =
+    let i = ixInWildcards ix
+    in (i, ix { ixInWildcards = i+1 })
+
+advanceKleene :: ReplacementIndices -> (Int, ReplacementIndices)
+advanceKleene ix =
+    let i = ixInKleenes ix
+    in (i, ix { ixInKleenes = i+1 })
+
 forceCategory :: CategoryNumber -> ReplacementIndices -> ReplacementIndices
 forceCategory i ixs = ixs { forcedCategory = Just i }
 
@@ -247,7 +302,7 @@     -> [MultiZipper t Grapheme]
 mkReplacement out = \ls -> fmap (fst . snd) . go startIxs ls . (,Nothing)
   where
-    startIxs = ReplacementIndices 0 0 Nothing
+    startIxs = ReplacementIndices 0 0 0 0 Nothing
 
     go
         :: ReplacementIndices
@@ -271,11 +326,12 @@     replaceLex ixs (Category (FromElements gs)) mz prev =
         case advanceCategory ixs numCatsMatched of
             (CategoryNumber ci, ixs') ->
-                let i = matchedCatIxs out !! ci in
-                    case gs !? i of
-                        Just (Left g) -> [(ixs', (insert g mz, Just g))]
-                        Just (Right ls) -> go ixs' ls (mz, prev)
-                        Nothing  -> [(ixs', (insert (GMulti "\xfffd") mz, Nothing))]  -- Unicode replacement character
+                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
             (Nondeterministic, ixs') -> gs >>= \case
                 Left g -> [(ixs', (insert g mz, Just g))]
                 Right ls -> go ixs' ls (mz, prev)
@@ -301,13 +357,24 @@     replaceLex ixs (Multiple c) mz prev =
         let ixs' = forceCategory Nondeterministic ixs
         in replaceLex ixs' (Category c) mz prev
+    replaceLex ixs (Wildcard l) mz prev =
+        let (i, ixs') = advanceWildcard ixs
+        in case matchedWildcards out !? i of
+            Just w -> go ixs' (fmap Grapheme w ++ [l]) (mz, prev)
+            -- need to add 'l' here too
+            Nothing -> replaceLex ixs' l mz prev
+    replaceLex ixs (Kleene l) mz prev =
+        let (i, ixs') = advanceKleene ixs
+        in case matchedKleenes out !? i of
+            Just n -> go ixs' (replicate n l) (mz, prev)
+            Nothing -> [(ixs', (mz, prev))]
 
 -- | Given a 'Rule' and a 'MultiZipper', determines whether the
 -- 'exception' of that rule (if any) applies starting at the current
 -- position of the 'MultiZipper'; if it does, returns the index of the
 -- first element of each matching 'target'.
 exceptionAppliesAtPoint
-    :: [Lexeme Expanded 'Target]
+    :: [Lexeme Expanded 'Matched]
     -> Environment Expanded
     -> MultiZipper RuleTag Grapheme -> [Int]
 exceptionAppliesAtPoint target (ex1, ex2) mz = fmap fst $ flip runRuleAp mz $ do
@@ -323,7 +390,7 @@ -- t'Grapheme's, and @is@ is a list of indices, one for each
 -- 'Category' lexeme matched.
 matchRuleAtPoint
-    :: [Lexeme Expanded 'Target]
+    :: [Lexeme Expanded 'Matched]
     -> Environment Expanded
     -> MultiZipper RuleTag Grapheme
     -> [(MatchOutput, MultiZipper RuleTag Grapheme)]
@@ -341,13 +408,19 @@             _ <- RuleAp $ matchMany env1Out (listToMaybe $ matchedGraphemes matchResult) env2
             return matchResult
 
+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
+    | 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) [] Bool
+applyOnce :: Rule Expanded -> StateT (MultiZipper RuleTag Grapheme) [] RuleStatus
 applyOnce r@Rule{target, replacement, exception} =
     modify (tag AppStart) >> go (environment r)
   where
-    go [] = return False
+    go [] = return Failure
     go (env:envs) = do
         result <- try (matchRuleAtPoint target env)
         case result of
@@ -358,32 +431,41 @@                         extend' (exceptionAppliesAtPoint target ex)
                 gets (locationOf TargetStart) >>= \p ->
                     if maybe True (`elem` exs) p
-                    then return False
+                    then return Failure
                     else do
+                        originalWord <- get
                         modifyMay $ delete (TargetStart, TargetEnd)
                         modifyMay $ seek TargetStart
-                        modifyM $ mkReplacement out replacement
-                        return True
+                        modifyM $ \w ->
+                            let replacedWords = mkReplacement out replacement w
+                            in case sporadic (flags r) of
+                                -- make sure to re-insert original word
+                                PerApplication -> originalWord : replacedWords
+                                _ -> replacedWords
+                        return $
+                            -- An epenthesis rule will cause an infinite loop
+                            -- if it matched no graphemes before the replacement
+                            if null (matchedGraphemes out) && null (fst env)
+                                then SuccessEpenthesis
+                                else SuccessNormal
             Nothing -> modifyMay (seek AppStart) >> go envs
 
 -- | Remove tags and advance the current index to the next t'Grapheme'
 -- after the rule application.
 setupForNextApplication
-    :: Bool
+    :: RuleStatus
     -> Rule Expanded
     -> MultiZipper RuleTag Grapheme
     -> Maybe (MultiZipper RuleTag Grapheme)
-setupForNextApplication success r@Rule{flags=Flags{applyDirection}} =
+setupForNextApplication status Rule{flags=Flags{applyDirection}} =
     fmap untag . case applyDirection of
         RTL -> seek AppStart >=> bwd
-        LTR ->
-            if success
-            then
-                if null (target r)
-                then -- need to move forward if applying an epenthesis rule to avoid an infinite loop
-                    seek TargetEnd >=> fwd
-                else seek TargetEnd
-            else seek AppStart >=> fwd
+        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
 
 -- | Apply a 'Rule' to a 'MultiZipper'. The application will start at
 -- the beginning of the 'MultiZipper', and will be repeated as many
@@ -394,21 +476,31 @@             LTR -> toBeginning mz
             RTL -> toEnd mz
         result = repeatRule (applyOnce r) startingPos
-    in if sporadic $ flags r
-          then mz : result
-          else result
+    in case sporadic (flags r) of
+        PerWord -> mz : result
+        _ -> result  -- PerApplication handled in 'applyOnce'
   where
     repeatRule
-        :: StateT (MultiZipper RuleTag Grapheme) [] Bool
+        :: StateT (MultiZipper RuleTag Grapheme) [] RuleStatus
         -> MultiZipper RuleTag Grapheme
         -> [MultiZipper RuleTag Grapheme]
-    repeatRule m mz = runStateT m mz >>= \(success, mz') ->
-        if success && applyOnceOnly (flags r)
+    repeatRule m mz = runStateT m mz >>= \(status, mz') ->
+        if (status /= Failure) && applyOnceOnly (flags r)
         then [mz']
-        else case setupForNextApplication success r mz' of
+        else case setupForNextApplication status r mz' of
             Just mz'' -> repeatRule m mz''
             Nothing -> [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
+        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.
@@ -417,13 +509,16 @@     GBoundary -> GBoundary
     g -> if g `elem` gs then g else GMulti "\xfffd"
 
--- | Apply a 'Statement' to a 'MultiZipper'. This is a simple wrapper
--- around 'applyRule' and 'checkGraphemes'.
+-- | Apply a 'Statement' to a 'MultiZipper', returning zero, one or
+-- more results.
 applyStatement
     :: Statement Expanded [Grapheme]
     -> MultiZipper RuleTag Grapheme
     -> [MultiZipper RuleTag Grapheme]
 applyStatement (RuleS r) mz = applyRule r mz
+applyStatement (FilterS f) mz
+    | filterMatches f mz = []
+    | otherwise = [mz]
 applyStatement (DirectiveS gs) mz = [checkGraphemes gs mz]
 
 -- | Apply a single 'Rule' to a word.
@@ -433,7 +528,12 @@ -- directly.
 applyRuleStr :: Rule Expanded -> PWord -> [PWord]
 -- Note: 'fromJust' is safe here as 'apply' should always succeed
-applyRuleStr r s = nubOrd $ fmap toList $ applyRule r $ fromListStart s
+applyRuleStr r =
+    addBoundaries
+    >>> fromListStart
+    >>> applyRule r
+    >>> fmap (toList >>> removeBoundaries)
+    >>> nubOrd
 
 -- | Apply a single 'Statement' to a word.
 --
@@ -454,7 +554,7 @@ data LogItem r = ActionApplied
     { action :: r
     , input :: PWord
-    , output :: PWord
+    , output :: Maybe PWord
     } deriving (Show, Functor, Generic, NFData)
 
 -- | Logs the evolution of a 'PWord' as various actions are applied to
@@ -462,7 +562,7 @@ data PWordLog r = PWordLog
     { initialWord :: PWord
     -- ^ The initial word, before any actions have been applied
-    , derivations :: [(PWord, r)]
+    , 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)
@@ -495,7 +595,7 @@     go _ [] = ""
     go cell1 ((output, action) : ds) =
         ("<tr><td>" ++ cell1 ++ "</td><td>&rarr;</td><td>"
-         ++ concatWithBoundary output
+         ++ maybe "<i>deleted</i>" concatWithBoundary output
          ++ "</td><td>(" ++ render action ++ ")</td></tr>")
         ++ go "" ds
 
@@ -518,8 +618,10 @@ reportAsText render item = unlines $
     concatWithBoundary (initialWord item) : fmap toLine (alignWithPadding $ derivations item)
   where
+    alignWithPadding :: [(Maybe PWord, b)] -> [([Char], b)]
     alignWithPadding ds =
-        let (fmap concatWithBoundary -> outputs, actions) = unzip ds
+        let (rawOutputs, actions) = unzip ds
+            outputs = maybe "(deleted)" concatWithBoundary <$> rawOutputs
             maxlen = maximum $ length <$> outputs
             padded = outputs <&> \o -> o ++ replicate (maxlen - length o) ' '
         in zip padded actions
@@ -534,8 +636,9 @@     -> PWord
     -> [LogItem (Statement Expanded [Grapheme])]
 applyStatementWithLog st w = case applyStatementStr st w of
-    [w'] -> if w' == w then [] else [ActionApplied st w w']
-    r -> ActionApplied st w <$> r
+    [] -> [ActionApplied st w Nothing]
+    [w'] | w' == w -> []
+    r -> ActionApplied st w . Just <$> r
 
 -- | Apply 'SoundChanges' to a word. For each possible result, returns
 -- a 'LogItem' for each 'Statement' which altered the input.
@@ -547,8 +650,11 @@ applyChangesWithLog (st:sts) w =
     case applyStatementWithLog st w of
         [] -> applyChangesWithLog sts w
-        items -> items >>= \l@ActionApplied{output=w'} ->
-            (l :) <$> 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]]
 
 -- | Apply 'SoundChanges' to a word, returning an 'PWordLog'
 -- for each possible result.
@@ -561,20 +667,22 @@ -- | Apply a set of 'SoundChanges' to a word.
 applyChanges :: SoundChanges Expanded [Grapheme] -> PWord -> [PWord]
 applyChanges sts w =
-    lastOutput <$> applyChangesWithLog sts w
+    mapMaybe lastOutput $ applyChangesWithLog sts w
   where
-    lastOutput [] = w
+    -- If no changes were applied, output is same as input
+    lastOutput [] = Just w
     lastOutput ls = output $ last ls
 
 -- | Apply 'SoundChanges' to a word returning the final results, as
 -- well as a boolean value indicating whether the word should be
 -- highlighted in a UI due to changes from its initial value. (Note
 -- that this accounts for 'highlightChanges' values.)
-applyChangesWithChanges :: SoundChanges Expanded [Grapheme] -> PWord -> [(PWord, Bool)]
+applyChangesWithChanges :: SoundChanges Expanded [Grapheme] -> PWord -> [(Maybe PWord, Bool)]
 applyChangesWithChanges sts w = applyChangesWithLog sts w <&> \case
-    [] -> (w, False)
+    [] -> (Just w, False)
     logs -> (output $ last logs, hasChanged logs)
   where
     hasChanged = any $ \case
-        ActionApplied{action=RuleS rule} -> highlightChanges $ flags rule
-        ActionApplied{action=DirectiveS _} -> True
+        ActionApplied (RuleS rule) _ _ -> highlightChanges $ flags rule
+        ActionApplied (FilterS _) _ _ -> False  -- cannot highlight nonexistent word
+        ActionApplied (DirectiveS _) _ _ -> True

@@ -13,17 +13,17 @@        , ExpandError(..)
        , expand
        , expandRule
-       , extend
+       , 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)
+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)
+import Data.Maybe (mapMaybe, catMaybes)
 import GHC.Generics (Generic)
 
 import qualified Data.Map.Strict as M
@@ -115,8 +115,14 @@         <$> traverse (expandLexeme cs) e1
         <*> traverse (expandLexeme cs) e2
 
-extend :: Categories -> Directive -> Either ExpandError Categories
-extend cs' (Categories overwrite defs) =
+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
@@ -146,18 +152,30 @@ expandSoundChanges
     :: SoundChanges CategorySpec Directive
     -> Either ExpandError (SoundChanges Expanded [Grapheme])
-expandSoundChanges = flip evalStateT M.empty . traverse go
+expandSoundChanges = fmap catMaybes . flip evalStateT (M.empty, []) . traverse go
   where
     go  :: Statement CategorySpec Directive
-        -> StateT Categories (Either ExpandError) (Statement Expanded [Grapheme])
+        -> StateT
+            (Categories, [String])
+            (Either ExpandError)
+            (Maybe (Statement Expanded [Grapheme]))
     go (RuleS r) = do
-        cs <- get
-        lift $ RuleS <$> expandRule cs r
-    go (DirectiveS d) = do
-        cs <- get
-        cs' <- lift $ extend cs d
-        put cs'
-        pure $ DirectiveS $ mapMaybe left $ values cs'
+        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

@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass  #-}
-{-# LANGUAGE DeriveFunctor   #-}
 {-# LANGUAGE DeriveGeneric   #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE RankNTypes      #-}
 {-# LANGUAGE TupleSections   #-}
 
 {-| __Warning:__ This module is __internal__, and does __not__ follow
@@ -10,20 +11,22 @@ -}
 module Brassica.SoundChange.Frontend.Internal where
 
-import Data.Bifunctor (second)
+import Control.Monad ((<=<))
 import Data.Maybe (fromMaybe, mapMaybe)
 import Data.Void (Void)
 import GHC.Generics (Generic)
+import Myers.Diff (getDiff, PolyDiff(..))
 
 import Control.DeepSeq (NFData)
 import Text.Megaparsec (ParseErrorBundle)
 
-import Brassica.MDF (MDF, parseMDFWithTokenisation, componentiseMDF, componentiseMDFWordsOnly, duplicateEtymologies)
+import Brassica.SFM.MDF
+import Brassica.SFM.SFM
 import Brassica.SoundChange.Apply
 import Brassica.SoundChange.Apply.Internal (applyChangesWithLog, toPWordLog)
-import Brassica.SoundChange.Category
 import Brassica.SoundChange.Tokenise
 import Brassica.SoundChange.Types
+import Data.Bifunctor (first)
 
 -- | Rule application mode of the SCA.
 data ApplicationMode
@@ -31,6 +34,10 @@     | ReportRulesApplied
     deriving (Show, Eq)
 
+getOutputMode :: ApplicationMode -> OutputMode
+getOutputMode (ApplyRules _ o _) = o
+getOutputMode ReportRulesApplied = WordsOnlyOutput  -- default option
+
 data HighlightMode
     = NoHighlight
     | DifferentToLastRun
@@ -66,21 +73,6 @@     toEnum 3 = WordsWithProtoOutput
     toEnum _ = undefined
 
-data TokenisationMode = Normal | AddEtymons
-    deriving (Show, Eq)
-instance Enum TokenisationMode where
-    -- used for conversion to and from C, so want control over values
-    fromEnum Normal = 0
-    fromEnum AddEtymons = 1
-
-    toEnum 0 = Normal
-    toEnum 1 = AddEtymons
-    toEnum _ = undefined
-
-tokenisationModeFor :: ApplicationMode -> TokenisationMode
-tokenisationModeFor (ApplyRules _ MDFOutputWithEtymons _) = AddEtymons
-tokenisationModeFor _ = Normal
-
 -- | Output of a single application of rules to a wordlist: either a
 -- list of possibly highlighted words, an applied rules table, or a
 -- parse error.
@@ -88,7 +80,6 @@     = HighlightedWords [Component (a, Bool)]
     | AppliedRulesTable [PWordLog r]
     | ParseError (ParseErrorBundle String Void)
-    | ExpandError ExpandError
     deriving (Show, Generic, NFData)
 
 -- | Kind of input: either a raw wordlist, or an MDF file.
@@ -103,16 +94,12 @@     toEnum 1 = MDF
     toEnum _ = undefined
 
-data ParseOutput a = ParsedRaw [Component a] | ParsedMDF (MDF [Component a])
-    deriving (Show, Functor)
+data ParseOutput a = ParsedRaw [Component a] | ParsedMDF SFM
+    deriving (Show, Functor, Foldable, Traversable)
 
-componentise :: OutputMode -> [a] -> ParseOutput a -> [Component a]
-componentise WordsWithProtoOutput ws (ParsedRaw cs) = intersperseWords ws cs
-componentise _                    _ (ParsedRaw cs) = cs
-componentise MDFOutput            _ (ParsedMDF mdf) = componentiseMDF mdf
-componentise MDFOutputWithEtymons _ (ParsedMDF mdf) = componentiseMDF mdf
-componentise WordsOnlyOutput      _ (ParsedMDF mdf) = componentiseMDFWordsOnly mdf
-componentise WordsWithProtoOutput ws (ParsedMDF mdf) = intersperseWords ws $ componentiseMDFWordsOnly mdf
+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) =
@@ -123,87 +110,76 @@ 
 tokeniseAccordingToInputFormat
     :: InputLexiconFormat
-    -> TokenisationMode
+    -> OutputMode
     -> SoundChanges Expanded [Grapheme]
     -> String
-    -> Either (ParseErrorBundle String Void) (ParseOutput PWord)
+    -> Either (ParseErrorBundle String Void) [Component PWord]
 tokeniseAccordingToInputFormat Raw _ cs =
-    fmap ParsedRaw . withFirstCategoriesDecl tokeniseWords cs
-tokeniseAccordingToInputFormat MDF Normal cs =
-    fmap ParsedMDF . withFirstCategoriesDecl parseMDFWithTokenisation cs
-tokeniseAccordingToInputFormat MDF AddEtymons cs =
-    fmap ParsedMDF
-    . second (duplicateEtymologies $ ('*':) . detokeniseWords)
-    . withFirstCategoriesDecl parseMDFWithTokenisation cs
-
-getParsedWords :: ParseOutput a -> [a]
-getParsedWords (ParsedRaw cs) = getWords cs
-getParsedWords (ParsedMDF mdf) = getWords $ componentiseMDF mdf
+    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
+    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
 
 -- | Top-level dispatcher for an interactive frontend: given a textual
 -- wordlist and a list of sound changes, returns the result of running
 -- the changes in the specified mode.
 parseTokeniseAndApplyRules
-    :: SoundChanges CategorySpec Directive -- ^ changes
+    :: (forall a b. (a -> b) -> [Component a] -> [Component b])  -- ^ mapping function to use (for parallelism)
+    -> SoundChanges Expanded [Grapheme] -- ^ changes
     -> String       -- ^ words
     -> InputLexiconFormat
     -> ApplicationMode
     -> Maybe [Component PWord]  -- ^ previous results
     -> ApplicationOutput PWord (Statement Expanded [Grapheme])
-parseTokeniseAndApplyRules statements ws intype mode prev =
-    case expandSoundChanges statements of
-        Left e -> ExpandError e
-        Right statements' ->
-            let tmode = tokenisationModeFor mode in
-            case tokeniseAccordingToInputFormat intype tmode statements' ws of
-                Left e -> ParseError e
-                Right toks
-                  | ws' <- getParsedWords toks
-                  -> case mode of
-                    ReportRulesApplied ->
-                        AppliedRulesTable $ mapMaybe toPWordLog $ concat $
-                            getWords $ componentise WordsOnlyOutput [] $
-                                applyChangesWithLog statements' <$> toks
-                    ApplyRules DifferentToLastRun mdfout sep ->
-                        let result = concatMap (splitMultipleResults sep) $
-                              componentise mdfout (fmap pure ws') $ applyChanges statements' <$> toks
-                        in HighlightedWords $
-                            zipWithComponents result (fromMaybe [] prev) [] $ \thisWord prevWord ->
-                                (thisWord, thisWord /= prevWord)
-                    ApplyRules DifferentToInput mdfout sep ->
-                        HighlightedWords $ concatMap (splitMultipleResults sep) $
-                            componentise mdfout (fmap (pure . (,False)) ws') $
-                                applyChangesWithChanges statements' <$> toks
-                    ApplyRules NoHighlight mdfout sep ->
-                        HighlightedWords $ (fmap.fmap) (,False) $ concatMap (splitMultipleResults sep) $
-                            componentise mdfout (fmap pure ws') $
-                                applyChanges statements' <$> toks
+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
+            ReportRulesApplied ->
+                AppliedRulesTable $ mapMaybe toPWordLog $ concat $
+                    getWords $ componentise WordsOnlyOutput [] $
+                        parFmap (applyChangesWithLog statements) toks
+            ApplyRules DifferentToLastRun mdfout sep ->
+                let result = concatMap (splitMultipleResults sep) $
+                      componentise mdfout (fmap pure ws') $
+                          parFmap (applyChanges 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
+            ApplyRules NoHighlight mdfout sep ->
+                HighlightedWords $ (fmap.fmap) (,False) $ concatMap (splitMultipleResults sep) $
+                    componentise mdfout (fmap pure ws') $
+                        parFmap (applyChanges statements) toks
   where
-    -- Zips two tokenised input strings. Compared to normal 'zipWith'
-    -- this has two special properties:
-    --
-    --   * It only zips v'Word's. Any non-v'Word's in the first argument
-    --     will be passed unaltered to the output; any in the second
-    --     argument will be ignored.
-    --
-    --   * The returned list will have the same number of elements as does
-    --     the first argument. If a v'Word' in the first argument has no
-    --     corresponding v'Word' in the second, the zipping function is
-    --     called using the default @b@ value given as the third argument.
-    --     Such a v'Word' in the second argument will simply be ignored.
-    --
-    -- Note the persistent assymetry in the definition: each 'Component'
-    -- in the first argument will be reflected in the output, but each in
-    -- the second argument may be ignored.
-    zipWithComponents :: [Component a] -> [Component b] -> b -> (a -> b -> c) -> [Component c]
-    zipWithComponents []             _            _  _ = []
-    zipWithComponents as            []            bd f = (fmap.fmap) (`f` bd) as
-    zipWithComponents (Word a:as)   (Word b:bs)   bd f = Word (f a b) : zipWithComponents as bs bd f
-    zipWithComponents as@(Word _:_) (_:bs)        bd f = zipWithComponents as bs bd f
-    zipWithComponents (a:as)        bs@(Word _:_) bd f = unsafeCastComponent a : zipWithComponents as bs bd f
-    zipWithComponents (a:as)        (_:bs)        bd f = unsafeCastComponent a : zipWithComponents as bs bd f
+    -- highlight words in 'Second' but not 'First'
+    polyDiffToHighlight :: PolyDiff (Component a) (Component a) -> Maybe (Component (a, Bool))
+    polyDiffToHighlight (First _) = Nothing
+    polyDiffToHighlight (Second (Word a)) = Just $ Word (a, True)
+    polyDiffToHighlight (Second c) = Just $ unsafeCastComponent c
+    polyDiffToHighlight (Both _ (Word a)) = Just $ Word (a, False)
+    polyDiffToHighlight (Both _ c) = Just $ unsafeCastComponent c
 
     unsafeCastComponent :: Component a -> Component b
     unsafeCastComponent (Word _) = error "unsafeCastComponent: attempted to cast a word!"
     unsafeCastComponent (Separator s) = Separator s
     unsafeCastComponent (Gloss s) = Gloss s
+
+    extractMaybe (Just a, b) = Just (a, b)
+    extractMaybe (Nothing, _) = Nothing

@@ -117,15 +117,22 @@         <|> pure Union  parseDirective :: Parser Directive-parseDirective = do-    overwrite <- isJust <$> optional (symbol "new")-    _ <- symbol "categories" <* scn-    cs <- some $-        DefineFeature <$> parseFeature <|>-        uncurry DefineCategory <$> (try parseCategoryStandalone <* scn)-    _ <- symbol "end" <* scn-    pure $ Categories overwrite cs+parseDirective = parseCategoriesDirective <|> parseExtraDirective+  where+    parseExtraDirective = fmap ExtraGraphemes $+        symbol "extra" *> many parseGrapheme' <* scn +    parseCategoriesDirective = do+        overwrite <- isJust <$> optional (symbol "new")+        _ <- symbol "categories"+        noreplace <- isJust <$> optional (symbol "noreplace")+        scn+        cs <- some $+            DefineFeature <$> parseFeature <|>+            uncurry DefineCategory <$> (try parseCategoryStandalone <* scn)+        _ <- symbol "end" <* scn+        pure $ Categories overwrite noreplace cs+ parseOptional :: ParseLexeme a => Parser (Lexeme CategorySpec a) parseOptional = Optional <$> between (symbol "(") (symbol ")") (some parseLexeme) @@ -135,13 +142,13 @@ parseMetathesis :: Parser (Lexeme CategorySpec 'Replacement) parseMetathesis = Metathesis <$ symbol "\\" -parseWildcard :: (ParseLexeme a, OneOf a 'Target 'Env) => Parser (Lexeme CategorySpec a)+parseWildcard :: ParseLexeme a => Parser (Lexeme CategorySpec a) parseWildcard = Wildcard <$> (symbol "^" *> parseLexeme)  parseDiscard :: Parser (Lexeme CategorySpec 'Replacement) parseDiscard = Discard <$ symbol "~" -parseKleene :: OneOf a 'Target 'Env => Lexeme CategorySpec a -> Parser (Lexeme CategorySpec a)+parseKleene :: Lexeme CategorySpec a -> Parser (Lexeme CategorySpec a) parseKleene l =     try (lexeme $ Kleene l <$ char '*' <* notFollowedBy parseGrapheme')     <|> pure l@@ -152,7 +159,7 @@ parseBackreference :: forall a. ParseLexeme a => Parser (Lexeme CategorySpec a) parseBackreference = Backreference <$> (symbol "@" *> nonzero) <*> parseCategory' -instance ParseLexeme 'Target where+instance ParseLexeme 'Matched where     parseLexeme = asum         [ parseExplicitCategory         , parseOptional@@ -170,15 +177,6 @@         , parseDiscard         , parseGeminate         , parseMultiple-        , parseBackreference-        , Grapheme <$> parseGrapheme-        ]--instance ParseLexeme 'Env where-    parseLexeme = asum-        [ parseExplicitCategory-        , parseOptional-        , parseGeminate         , parseWildcard         , parseBackreference         , Grapheme <$> parseGrapheme@@ -188,8 +186,9 @@     parseLexeme = asum         [ parseExplicitCategory         , parseOptional+        , parseWildcard         , Grapheme <$> parseGrapheme-        ]+        ] >>= parseKleene  parseLexemes :: ParseLexeme a => Parser [Lexeme CategorySpec a] parseLexemes = many parseLexeme@@ -199,7 +198,8 @@     <$> toPermutation (isNothing <$> optional (symbol "-x"))     <*> toPermutationWithDefault LTR ((LTR <$ symbol "-ltr") <|> (RTL <$ symbol "-rtl"))     <*> toPermutation (isJust <$> optional (symbol "-1"))-    <*> toPermutation (isJust <$> optional (symbol "-?"))+    <*> toPermutationWithDefault ApplyAlways+        ((PerApplication <$ symbol "-??") <|> (PerWord <$ symbol "-?"))  ruleParser :: Parser (Rule CategorySpec) ruleParser = do@@ -210,8 +210,11 @@     s <- getInput      flags <- parseFlags-    target <- parseLexemes-    _ <- lexeme $ oneOf "/→"+    target <- manyTill parseLexeme $ lexeme $ choice+        [ string "/"+        , string "→"+        , string "->"+        ]     replacement <- parseLexemes      envs' <- many $ do@@ -233,10 +236,13 @@   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.2.0/Documentation.md#basic-rule-syntax>.+-- For details on the syntax, refer to <https://github.com/bradrn/brassica/blob/v0.3.0/Documentation.md#basic-rule-syntax>. parseRule :: String -> Either (ParseErrorBundle String Void) (Rule CategorySpec) parseRule = runParser (scn *> ruleParser <* eof) "" @@ -246,4 +252,5 @@   where     parser = many $         DirectiveS <$> parseDirective+        <|> FilterS <$> filterParser         <|> RuleS <$> ruleParser

@@ -14,7 +14,6 @@ {-# LANGUAGE RankNTypes            #-} {-# LANGUAGE StandaloneDeriving    #-} {-# LANGUAGE TypeFamilies          #-}-{-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-}  module Brassica.SoundChange.Types@@ -39,9 +38,11 @@        , Rule(..)        , Environment        , Direction(..)+       , Sporadicity(..)        , Flags(..)        , defFlags        -- * Statements+       , Filter(..)        , Statement(..)        , plaintext'        , SoundChanges@@ -51,34 +52,13 @@        , FeatureSpec(..)        , CategoryDefinition(..)        , Directive(..)-       -- * Utility-       , OneOf        ) where  import Control.DeepSeq (NFData(..))-import Data.Kind (Constraint) import Data.String (IsString(..)) import GHC.Generics (Generic) import GHC.OldList (dropWhileEnd)-import GHC.TypeLits --- | The constraint @OneOf a x y@ is satisfied if @a ~ x@ or @a ~ y@.------ (Note: the strange @() ~ Bool@ constraint is just a simple--- unsatisfiable constraint, so as to not give ‘non-exhaustive pattern--- match’ errors everywhere.)-type family OneOf a x y :: Constraint where-    OneOf a a y = ()-    OneOf a x a = ()-    OneOf a b c =-        ( () ~ Bool-        , TypeError ('Text "Couldn't match type "-                     ':<>: 'ShowType a-                     ':<>: 'Text " with "-                     ':<>: 'ShowType b-                     ':<>: 'Text " or "-                     ':<>: 'ShowType c))- -- | The type of graphemes within a word. data Grapheme     = GMulti [Char]  -- ^ A multigraph: for instance @GMulti "a", GMulti "ch", GMulti "c̓" :: t'Grapheme'@.@@ -115,9 +95,10 @@         GMulti g -> g         GBoundary -> "#" --- | The part of a 'Rule' in which a 'Lexeme' may occur: either the--- target, the replacement or the environment, or in any of those.-data LexemeType = Target | Replacement | Env | AnyPart+-- | 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  -- | A 'Lexeme' is the smallest part of a sound change. Both matches -- and replacements are made up of 'Lexeme's: the phantom type@@ -137,9 +118,9 @@     -- | In Brassica sound-change syntax, specified as @>@     Geminate :: Lexeme category a     -- | In Brassica sound-change syntax, specified as @^@ before another 'Lexeme'-    Wildcard :: OneOf a 'Target 'Env => Lexeme category a -> Lexeme category a+    Wildcard :: Lexeme category a -> Lexeme category a     -- | In Brassica sound-change syntax, specified as @*@ after another 'Lexeme'-    Kleene   :: OneOf a 'Target 'Env => Lexeme category a -> Lexeme category a+    Kleene   :: Lexeme category a -> Lexeme category a     -- | In Brassica sound-change syntax, specified as @~@     Discard  :: Lexeme category 'Replacement     -- | In Brassica sound-change syntax, specified as \@i before a category@@ -191,6 +172,8 @@ generalise f (Optional ls) = Optional $ generalise f <$> ls generalise _ Geminate = Geminate 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  generaliseExpanded :: Expanded 'AnyPart -> Expanded a generaliseExpanded = FromElements . (fmap.fmap.fmap) (generalise generaliseExpanded) . elements@@ -219,19 +202,29 @@ -- corresponding to a ‘/ before _ after’ component of a sound change. -- -- Note that an empty environment is just @([], [])@.-type Environment c = ([Lexeme c 'Env], [Lexeme c 'Env])+type Environment c = ([Lexeme c 'Matched], [Lexeme c 'Matched])  -- | 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.+data Sporadicity+    = ApplyAlways+    -- ^ Always apply the rule+    | PerWord+    -- ^ Apply sporadically, either to the whole word or to none of the word+    | PerApplication+    -- ^ Apply sporadically, at each application site+    deriving (Eq, Show, Generic, NFData)+ -- | Flags which can be enabled, disabled or altered on a 'Rule' to -- change how it is applied. data Flags = Flags   { highlightChanges :: Bool   , applyDirection   :: Direction   , applyOnceOnly    :: Bool-  , sporadic         :: Bool+  , sporadic         :: Sporadicity   } deriving (Show, Generic, NFData)  -- | A default selection of flags which are appropriate for most@@ -253,14 +246,14 @@     { highlightChanges = True     , applyDirection = LTR     , applyOnceOnly = False-    , sporadic = False+    , sporadic = ApplyAlways     }  -- | A single sound change rule: in Brassica sound-change syntax with all elements specified, -- @-flags target / replacement \/ environment1 | environment2 | … \/ exception@. -- (And usually the 'plaintext' of the rule will contain a 'String' resembling that pattern.) data Rule c = Rule-  { target      :: [Lexeme c 'Target]+  { target      :: [Lexeme c 'Matched]   , replacement :: [Lexeme c 'Replacement]   , environment :: [Environment c]   , exception   :: Maybe (Environment c)@@ -271,11 +264,22 @@ deriving instance (forall a. Show (c a)) => Show (Rule c) deriving instance (forall a. NFData (c a)) => NFData (Rule c) --- | A 'Statement' can be either a single sound change rule, or a--- directive (e.g. category definition).-data Statement c decl = RuleS (Rule c) | DirectiveS decl+-- | A filter, constraining the output to not match the given elements.+-- (The 'String' is the plaintext, as with 'Rule'.)+data Filter c = Filter String [Lexeme c 'Matched]     deriving (Generic) +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).+data Statement c decl+    = RuleS (Rule c)+    | FilterS (Filter c)+    | DirectiveS decl+    deriving (Generic)+ deriving instance (forall a. Show (c a), Show decl) => Show (Statement c decl) deriving instance (forall a. NFData (c a), NFData decl) => NFData (Statement c decl) @@ -283,6 +287,7 @@ -- @"<directive>"@ for all 'DirectiveS' inputs. plaintext' :: Statement c decl -> String plaintext' (RuleS r) = plaintext r+plaintext' (FilterS (Filter p _)) = p plaintext' (DirectiveS _) = "<directive>"  -- | A set of 'SoundChanges' is simply a list of 'Statement's.@@ -314,7 +319,13 @@     | DefineFeature FeatureSpec     deriving (Show, Eq, Ord, Generic, NFData) --- | A directive used in Brassica sound-change syntax: currently only--- @categories … end@ or @new categories … end@-data Directive = Categories Bool [CategoryDefinition]+-- | A directive used in Brassica sound-change syntax: anything which+-- is not actually a sound change++data Directive+    = Categories Bool Bool [CategoryDefinition]+      -- ^ @categories … end@: first 'Bool' for @new@,+      -- second for @noreplace@+    | ExtraGraphemes [String]+      -- ^ @extra …@     deriving (Show, Eq, Ord, Generic, NFData)