brassica 1.0.0 → 1.1.0

raw patch · 19 files changed

+626/−396 lines, 19 filesdep ~aesondep ~fast-myers-diffdep ~file-embedPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, fast-myers-diff, file-embed, megaparsec, optparse-applicative, pandoc, parallel, parser-combinators, tasty

API changes (from Hackage documentation)

Files

• ChangeLog.md +57/−0
• LICENSE +1/−1
• brassica.cabal +18/−16
• cli-pb/Main.hs +2/−2
• cli/Main.hs +13/−7
• cli/Server.hs +7/−131
• src/Brassica/Paradigm.hs +2/−0
• src/Brassica/Paradigm/Apply.hs +34/−19
• src/Brassica/Paradigm/Parse.hs +35/−15
• src/Brassica/Paradigm/Types.hs +14/−13
• src/Brassica/SoundChange.hs +1/−1
• src/Brassica/SoundChange/Apply.hs +2/−0
• src/Brassica/SoundChange/Apply/Internal.hs +93/−47
• src/Brassica/SoundChange/Expand.hs +49/−23
• src/Brassica/SoundChange/Frontend/Internal.hs +199/−51
• src/Brassica/SoundChange/Parse.hs +33/−15
• src/Brassica/SoundChange/Tokenise.hs +4/−0
• src/Brassica/SoundChange/Types.hs +16/−8
• test/DocTests.hs +46/−47

@@ -1,5 +1,62 @@ # Brassica changelog +## 1.1.0++### Behaviour++- Bugfixes:+  - The first element of categories is now treated consistently+      accross both category blocks and inline categories.+  - Combining optional elements with the Kleene star no longer causes an infinite loop+  - Highlighting ‘any rule applied’ with ‘input→output’ format now works correctly+- Improvements to paradigm builder:+  - Stem alternations are now supported with new `~n` syntax+  - Paradigm classes can be specified for individual words with new `#paradigm` syntax+  - Feature mappings and `when` conditions can now include multiple alternatives+  - Blank lines are now allowed in paradigm specifications+- Kleene star can now produce multiple results, no longer restricted to greedy matching (resolving https://github.com/bradrn/brassica/issues/7)+- Epenthesis rules with environments matching replacements no longer yield an infinite loop (resolving https://github.com/bradrn/brassica/issues/10)+- New option to highlight only words affected by specific rules, selected with new flag `-h`+- New flag `-pstart <name>` to create persistent rules, disabled with new directive `pstop <name>`+- Allow specifying multiple exceptions in a single rule+- New checkbox / command-line option to highlight unused rules in the rules editor+- ‘Input→output’ format and ‘Report rules applied’ both now show unchanged words explicitly+- Syntax errors are now highlighted in the rules editor+- In live mode, output box is greyed out rather than being interrupted with error messages+- On desktop and web, results are now computed asynchronously (i.e. without causing the UI to freeze)++### Code++- New flag `highlightSpecificRule` added to `Brassica.SoundChanges.Types.Flags`+- `Brassica.SoundChanges.Apply.getChangedOutputs` and `Brassica.SoundChanges.Apply.getChangedReports`+    now take an extra parameter of new type `Brassica.SoundChanges.Apply.HighlightMode`,+    as does the constructor `Brassica.SoundChange.Frontend.Internal.DifferentToInput`+- New function `Brassica.SoundChanges.Apply.rulesNotApplied`+- Method of reporting rules to frontend is now selected by new type `Brassica.SoundChange.Frontend.Internal.ReportMode`,+    with corresponding changes in `Brassica.SoundChange.Frontend.Internal.ApplicationMode`+    and `Brassica.SoundChange.Frontend.Internal.ApplicationOutput`+- Changed `Brassica.SoundChange.Types.Rule` to admit multiple exceptions+- New field for line number in `Brassica.SoundChange.Types.Rule`,+    `Brassica.SoundChange.Types.Filter`, `Brassica.SoundChanges.Types.Directive`+- Persistent rules:+  new flag `persistent` in `Brassica.SoundChange.Types.Flags`,+  and new directive `DisablePersistent` in same module+- Changes to paradigm builder:+  - New constructors `Stem` and `Class` in `Brassica.Paradigm.Types`+  - New type `Brassica.Paradigm.Expr`, now used in `Statement` and `Feature` in the same module+  - Constructor `Brassica.Paradigm.Always` removed (it can be replaced by `All []`)+  - `Brassica.Paradigm.Feature` now takes a `String` rather than a `FeatureName`+  - `Brassica.Paradigm.applyParadigm` now takes a list of stems with paradigm specification+      rather than a single root+  - New function `Brassica.Paradigm.parseStems` to parse stems with paradigm specifications+- New field in constructor `Brassica.SoundChange.Apply.Internal.SuccessEpenthesis`+- Web communication protocol now uses JSON as with desktop:+  - `ToJSON` and `FromJSON` instances added for `Brassica.SoundChange.Tokenise.Component`+  - `Enum` instances removed from types in `Brassica.SoundChange.Frontend.Internal` as now unnecessary+  - JSON server implementation moved from CLI to `Brassica.SoundChange.Frontend.Internal`;+      CLI `Server` and web `BrassicaInterop` modules are both now just a thin wrapper over this module++ ## 1.0.0  ### Behaviour

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

@@ -1,16 +1,16 @@ cabal-version:      2.0 name:               brassica-version:            1.0.0+version:            1.1.0 synopsis:           Featureful sound change applier description:   This is the Brassica library for the simulation of sound changes in historical linguistics and language construction.   .-  For an introduction to library usage, see the documentation of [Brassica.SoundChange](https://hackage.haskell.org/package/brassica-1.0.0/candidate/docs/Brassica-SoundChange.html).+  For an introduction to library usage, see the documentation of [Brassica.SoundChange](https://hackage.haskell.org/package/brassica-1.1.0/candidate/docs/Brassica-SoundChange.html).   .-  For further details on Brassica’s design and usage, please refer to the README below or at <https://github.com/bradrn/brassica/blob/v1.0.0#readme>.+  For further details on Brassica’s design and usage, please refer to the README below or at <https://github.com/bradrn/brassica/blob/v1.1.0#readme>.  category:           Linguistics-homepage:           https://github.com/bradrn/brassica#readme+homepage:           https://bradrn.com/brassica bug-reports:        https://github.com/bradrn/brassica/issues author:             Brad Neimann maintainer:         Brad Neimann@@ -46,13 +46,16 @@   ghc-options:      -Wall   build-depends:                    base >=4.7 && <5+                 , aeson >=2.2 && <2.4                  , containers >=0.6 && <0.7                  , deepseq >=1.4 && <1.6-                 , fast-myers-diff ==0.0.0-                 , megaparsec >=8.0 && <9.7+                 , fast-myers-diff >=0.0.0 && <0.1+                 , megaparsec >=8.0 && <9.9                  , mtl >=2.2 && <2.4-                 , parser-combinators >=1.2 && <1.3+                 , parallel >=3.2 && <3.4+                 , parser-combinators >=1.2 && <1.4                  , split >=0.2 && <0.3+                 , text >=1.2 && <2.3                  , transformers >=0.5 && <0.7                  , vector >=0.13 && <0.14 @@ -66,14 +69,13 @@   build-depends:                     base >=4.7 && <5                   , brassica-                  , aeson >=2.2 && <2.3+                  , aeson >=2.2 && <2.4                   , attoparsec-aeson ^>=2.2                   , bytestring >=0.10 && <0.13                   , conduit ^>=1.3                   , conduit-extra ^>=1.3                   , deepseq >=1.4 && <1.6-                  , optparse-applicative ^>=0.17.1 || ^>=0.18-                  , parallel ^>= 3.2+                  , optparse-applicative >=0.17.1 && <0.20                   , text >=1.2 && <2.3    default-language: Haskell2010@@ -87,7 +89,7 @@                   , brassica                   , bytestring >=0.10 && <0.13                   , conduit ^>=1.3-                  , optparse-applicative ^>=0.17.1 || ^>=0.18+                  , optparse-applicative >=0.17.1 && <0.20                   , text >=1.2 && <2.3    default-language: Haskell2010@@ -101,8 +103,8 @@                     base >=4.7 && <5                   , brassica                   , criterion >=1.5 && <1.7-                  , file-embed >=0.0.15 && <0.0.16-                  , parallel ^>= 3.2+                  , file-embed >=0.0.15 && <0.0.17+                  , parallel >=3.2 && <3.4                   , text >=1.2 && <2.3    default-language: Haskell2010@@ -127,7 +129,7 @@   build-depends:                     base >=4.7 && <5                   , brassica-                  , tasty ^>=1.4+                  , tasty >=1.4 && <1.6                   , tasty-golden ^>=2.3                   , bytestring                   , text >=1.2 && <2.3@@ -145,10 +147,10 @@   build-depends:                     base >=4.7 && <5                   , brassica-                  , tasty ^>=1.4+                  , tasty >=1.4 && <1.6                   , bytestring                   , text >=1.2 && <2.3-                  , pandoc >=3.3 && <3.4+                  , pandoc >=3.3 && <3.13                   , pandoc-types >=1.23 && <1.24    default-language: Haskell2010

@@ -34,7 +34,7 @@                 .| encodeUtf8C                 .| outC   where-    opts = info (args <**> helper <**> simpleVersioner "v1.0.0") fullDesc+    opts = info (args <**> helper <**> simpleVersioner "v1.1.0") fullDesc      args = Options         <$> asum@@ -58,7 +58,7 @@      processRoot :: Bool -> Paradigm -> Text -> Text     processRoot nestedOutput p r =-        let output = applyParadigm p $ unpack r+        let output = uncurry (applyParadigm p) $ parseStems $ unpack r         in if nestedOutput             then addSpaces output $ pack $ formatNested id output             else T.unlines $ pack <$> toList output

@@ -29,7 +29,7 @@                 putStrLn $ errorBundlePretty err             Right scs ->                 case expandSoundChanges scs of-                    Left err -> putStrLn $ case err of+                    Left (_, err) -> putStrLn $ case err of                         (NotFound s) -> "Could not find category: " ++ s                         InvalidBaseValue -> "Invalid value used as base grapheme in feature definition"                         InvalidDerivedValue -> "Invalid value used as derived grapheme in autosegment"@@ -39,11 +39,11 @@                         withSinkFileIf outWordsFile $ \outC ->                         runConduit $                             inC-                            .| processWords (incrFor wordsFormat) rules' wordsFormat outMode+                            .| processWords (incrFor wordsFormat outMode) rules' wordsFormat outMode                             .| outC    where-    opts = info (args <**> helper <**> simpleVersioner "v1.0.0") fullDesc+    opts = info (args <**> helper <**> simpleVersioner "v1.1.0") fullDesc      args = batchArgs <|> serverArgs     serverArgs = flag' Server (long "server" <> help "Run server (for internal use only)")@@ -61,16 +61,20 @@                 (long "mdf-alt" <> help "Parse input words in MDF format (alternate hierarchy)")             ]         <*> (asum-                [ flag' (const ReportRulesApplied)+                [ flag' (const $ ReportRules ReportApplied)                     (long "report" <> help "Report rules applied rather than outputting words")+                , flag' (const $ ReportRules ReportNotApplied)+                    (long "report-not" <> help "Report rules which didn't apply rather than outputting words")                 , flag' (ApplyRules NoHighlight MDFOutput)                     (long "mdf-out" <> help "With --mdf, output MDF dictionary")                 , flag' (ApplyRules NoHighlight MDFOutputWithEtymons)                     (long "etymons" <> help "With --mdf, output MDF dictionary with etymologies")                 , flag' (ApplyRules NoHighlight WordsWithProtoOutput)                     (long "show-input" <> help "Output an input→output wordlist")-                , flag' (ApplyRules DifferentToInput WordsOnlyOutput)+                , flag' (ApplyRules (DifferentToInput AllChanged) WordsOnlyOutput)                     (long "show-changed" <> help "Add [+] after all words different to input")+                , flag' (ApplyRules (DifferentToInput SpecificRule) WordsOnlyOutput)+                    (long "show-changed-h" <> help "Add [+] after all words affected by rules with -h")                 , flag                     (ApplyRules NoHighlight WordsOnlyOutput)                     (ApplyRules NoHighlight WordsOnlyOutput)@@ -83,8 +87,9 @@         <*> optional (strOption             (long "out" <> short 'o' <> help "File to which output words should be written (if not specified will write to stdout)")) -    incrFor Raw = True-    incrFor (MDF _) = False+    incrFor (MDF _) _ = False+    incrFor Raw (ReportRules ReportNotApplied) = False+    incrFor Raw _ = True      -- duplicated in paradigm builder CLI     withSourceFileIf :: Maybe FilePath -> (ConduitM i B.ByteString IO () -> IO a) -> IO a@@ -130,6 +135,7 @@     processApplicationOutput :: ApplicationOutput PWord (Statement Expanded GraphemeList) -> Either ParseException Text     processApplicationOutput (HighlightedWords cs) = Right $ ensureNewline $ pack $ detokeniseWords' highlight cs     processApplicationOutput (AppliedRulesTable is) = Right $ pack $ unlines $ reportAsText plaintext' <$> is+    processApplicationOutput (NotAppliedRulesList is) = Right $ pack $ unlines $ plaintext <$> is     processApplicationOutput (ParseError e) = Left $ ParseException $ errorBundlePretty e      ensureNewline t = case unsnoc t of

@@ -1,83 +1,18 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}-{-# OPTIONS_GHC -Wno-orphans #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -module Server (serve, parFmap) where+module Server (serve) where +import Data.Aeson (Result(..), encode, fromJSON) import Conduit (runConduit, (.|), stdinC, stdoutC, mapMC)-import Control.DeepSeq (force, NFData)+import Control.DeepSeq (force) import Control.Exception (evaluate)-import Control.Parallel.Strategies (withStrategy, parTraversable, rseq)-import Data.Aeson (Result(..), encode, FromJSON(..), ToJSON(..), Value (..), fromJSON) import Data.Aeson.Parser (json')-import Data.Aeson.TH (deriveJSON, defaultOptions, defaultTaggedObject, constructorTagModifier, sumEncoding, tagFieldName)-import Data.Aeson.Types (prependFailure, typeMismatch) import Data.ByteString (toStrict) import Data.Conduit.Attoparsec (conduitParser)-import Data.Foldable (toList)-import Data.Text (unpack)-import GHC.Generics (Generic) import System.IO (hSetBuffering, stdin, stdout, BufferMode(NoBuffering)) import System.Timeout -import Brassica.SoundChange-import Brassica.SoundChange.Frontend.Internal-import Brassica.Paradigm (applyParadigm, parseParadigm, formatNested, ResultsTree (..))--data Request-    = ReqRules-        { changes :: String-        , input :: String-        , report :: Bool-        , inFmt :: InputLexiconFormat-        , hlMode :: HighlightMode-        , outMode :: OutputMode-        , prev :: Maybe [Component PWord]-        , sep :: String-        }-    | ReqParadigm-        { pText :: String-        , input :: String-        , separateLines :: Bool-        }-    deriving (Show)--data Response-    = RespRules-        { prev :: Maybe [Component PWord]-        , output :: String-        }-    | RespParadigm-        { output :: String-        }-    | RespError String-    deriving (Show, Generic, NFData)--instance ToJSON InputLexiconFormat where-    toJSON Raw = "Raw"-    toJSON (MDF Standard) = "MDFStandard"-    toJSON (MDF Alternate) = "MDFAlternate"--instance FromJSON InputLexiconFormat where-    parseJSON (String "Raw") = pure Raw-    parseJSON (String "MDFStandard") = pure $ MDF Standard-    parseJSON (String "MDFAlternate") = pure $ MDF Alternate-    parseJSON (String s) = fail $ "Unknown InputLexiconFormat: " ++ unpack s-    parseJSON invalid = prependFailure "parsing InputLexiconFormat failed: " $-        typeMismatch "String" invalid--$(deriveJSON defaultOptions ''Component)-$(deriveJSON defaultOptions ''HighlightMode)-$(deriveJSON defaultOptions ''OutputMode)--$(deriveJSON defaultOptions{constructorTagModifier=drop 3, sumEncoding=defaultTaggedObject{tagFieldName="method"}} ''Request)-$(deriveJSON defaultOptions{constructorTagModifier=drop 4, sumEncoding=defaultTaggedObject{tagFieldName="method"}} ''Response)+import Brassica.SoundChange.Frontend.Internal (dispatch, Response(RespError), reqTimeout)  serve :: IO () serve = do@@ -91,71 +26,12 @@   where     action req' = fmap ((<> "\ETB") . toStrict . encode) $         case fromJSON req' of-            Error e -> pure $ RespError e+            Error e -> pure $ RespError [] e             Success req -> do                 result <--                    timeout 5000000 $  -- 5 s+                    timeout (reqTimeout req) $                     evaluate $ force $                     dispatch req                 pure $ case result of-                    Nothing -> RespError "&lt;timeout&gt;"+                    Nothing -> RespError [] "&lt;timeout&gt;"                     Just resp -> resp--dispatch :: Request -> Response-dispatch r@(ReqRules{}) = parseTokeniseAndApplyRulesWrapper r-dispatch r@(ReqParadigm{}) = parseAndBuildParadigmWrapper r--parseTokeniseAndApplyRulesWrapper-    :: Request-    -> Response-parseTokeniseAndApplyRulesWrapper ReqRules{..} =-    let mode =-            if report-            then ReportRulesApplied-            else ApplyRules hlMode outMode sep-    in case parseSoundChanges changes of-        Left e -> RespError $ "<pre>" ++ errorBundlePretty e ++ "</pre>"-        Right statements ->-            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"-                    InvalidDerivedValue -> "Invalid value used as derived grapheme in autosegment"-                    MismatchedLengths -> "Mismatched lengths in feature definition"-                Right statements' ->-                    let result' = parseTokeniseAndApplyRules parFmap statements' input inFmt mode prev-                    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 $-                            concatMap (surroundTable . reportAsHtmlRows plaintext') items-  where-    highlightWord (s, False) = concatWithBoundary s-    highlightWord (s, True) = "<b>" ++ concatWithBoundary s ++ "</b>"--    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{..} =-    case parseParadigm pText of-        Left e -> RespError $ "<pre>" ++ errorBundlePretty e ++ "</pre>"-        Right p -> RespParadigm $ escape $-            (if separateLines-                then unlines . toList-                else formatNested id)-            $ Node $ applyParadigm p <$> lines input-parseAndBuildParadigmWrapper _ = error "parseAndBuildParadigmWrapper: unexpected request!"--escape :: String -> String-escape = concatMap $ \case-    '\n' -> "<br/>"-    -- '\t' -> "&#9;"  -- this doesn't seem to do anything - keeping it here in case I eventually figure out how to do tabs in Qt-    c    -> pure c

@@ -14,12 +14,14 @@        , Grammeme(..)        , AbstractGrammeme(..)        , Condition(..)+       , Expr(..)        , Feature(..)        , FeatureName(..)        , Statement(..)        , Paradigm        -- * Parsing and pretty-printing        , parseParadigm+       , parseStems        , formatNested        -- * Paradigm application        , applyParadigm

@@ -12,7 +12,7 @@ import Brassica.Paradigm.Types  import Data.Functor ((<&>))-import Data.List (sortOn, foldl', intercalate)+import Data.List (sortOn, foldl', intercalate, nub) import Data.Maybe (mapMaybe) import Data.Ord (Down(Down)) @@ -21,8 +21,11 @@ data ResultsTree a = Node [ResultsTree a] | Result a     deriving (Show, Functor, Foldable) -addLevel :: (a -> [a]) -> ResultsTree a -> ResultsTree a-addLevel f (Result r) = Node $ Result <$> f r+addLevel :: (a -> [b]) -> ResultsTree a -> ResultsTree b+addLevel f (Result r) =+    case f r of+        [r'] -> Result r'+        r' -> Node $ Result <$> r' addLevel f (Node rs) = Node $ addLevel f <$> rs  -- | Depth of a 'ResultsTree': i.e. how many levels of 'Node's it@@ -50,11 +53,11 @@  -- | Apply the given 'Paradigm' to a root, to produce all possible -- derived forms.-applyParadigm :: Paradigm -> String -> ResultsTree String-applyParadigm p w =+applyParadigm :: Paradigm -> Maybe String -> [String] -> ResultsTree String+applyParadigm p pclass ws =     let fs = mapMaybe getFeature p         ms = mapMaybe getMapping p-    in applyTo w . expand ms <$> combinations fs+    in addLevel (applyTo ws . expand ms) $ combinations pclass fs   where     getFeature (NewFeature f) = Just f     getFeature _ = Nothing@@ -62,17 +65,25 @@     getMapping (NewMapping k v) = Just (k,v)     getMapping _ = Nothing -combinations :: [Feature] -> ResultsTree [Grammeme]-combinations =-    (fmap.fmap) snd . foldl' go (Result [])+evalExpr :: (a -> Bool) -> Expr a -> Bool+evalExpr p (Any xs) = any (evalExpr p) xs+evalExpr p (All xs) = all (evalExpr p) xs+evalExpr p (Pred a) = p a++combinations :: Maybe String -> [Feature] -> ResultsTree [Grammeme]+combinations pclass =+    let initGrammemes = case pclass of+            Just p -> [(Just Class, Abstract (AbstractGrammeme p))]+            _ -> []+    in (fmap.fmap) snd . foldl' go (Result initGrammemes)   where     addFeature         :: Feature         -> [(Maybe FeatureName, Grammeme)]         -> [[(Maybe FeatureName, Grammeme)]]     addFeature (Feature c n gs) acc-        | satisfied (flip lookup acc . Just) c-        = gs <&> \g -> (n, g):acc+        | evalExpr (satisfied (flip lookup acc . Just)) c+        = gs <&> \g -> (FeatureName <$> n, g):acc         | otherwise         = [acc] @@ -85,7 +96,6 @@         :: (FeatureName -> Maybe Grammeme)         -> Condition         -> Bool-    satisfied _ Always = True     satisfied l (Is n g) = case l n of         Just g' -> g == g'         Nothing -> False@@ -93,7 +103,7 @@         Just g' -> g /= g'         Nothing -> True -expand :: [([AbstractGrammeme], Affix)] -> [Grammeme] -> [Process]+expand :: [(Expr AbstractGrammeme, Affix)] -> [Grammeme] -> [Process] expand ms = concat . ((++) <$> concretes <*> (replace . filterAbstract))   where     concretes :: [Grammeme] -> [Affix]@@ -109,20 +119,25 @@     replace :: [AbstractGrammeme] -> [Affix]     replace gs = do         (condition, replacement) <- ms-        if condition `subsetOf` gs+        if evalExpr (`elem` gs) condition            then return replacement            else [] -    xs `subsetOf` ys = all (`elem` ys) xs--applyTo :: String -> [Process] -> String-applyTo w is =+applyTo :: [String] -> [Process] -> [String]+applyTo ws is =     let ps = concatMap snd $ sortOn (Down . fst) $ mapMaybe getPrefix is         ss = concatMap snd $ sortOn         fst  $ mapMaybe getSuffix is-    in ps ++ w ++ ss+        stems = case nub (mapMaybe getStem is) of+            [] | [_] <- ws -> ws+            [s] | s >= 1 && s <= length ws -> [ws !! (s-1)]+            s -> [show s]+    in stems <&> \stem -> ps ++ stem ++ ss   where     getPrefix (Prefix s i) = Just (s,i)     getPrefix _ = Nothing      getSuffix (Suffix s i) = Just (s,i)     getSuffix _ = Nothing++    getStem (Stem i) = Just i+    getStem _ = Nothing

@@ -1,5 +1,8 @@-module Brassica.Paradigm.Parse (parseParadigm) where
+{-# LANGUAGE LambdaCase #-}
+module Brassica.Paradigm.Parse (parseParadigm, parseStems) where
 
+import Control.Category ((>>>))
+import Data.Maybe (fromMaybe)
 import Control.Monad (void)
 import Data.Char (isSpace)
 import Data.Void (Void)
@@ -9,7 +12,6 @@ import qualified Text.Megaparsec.Char.Lexer as L
 
 import Brassica.Paradigm.Types
-import Data.Maybe (fromMaybe)
 
 type Parser = Parsec Void String
 
@@ -21,6 +23,9 @@ sc :: Parser ()
 sc = L.space space1' (L.skipLineComment "*") empty
 
+eolf :: Parser ()
+eolf = void (some eol) <|> eof
+
 lexeme :: Parser a -> Parser a
 lexeme = L.lexeme sc
 
@@ -39,7 +44,9 @@ morphValue = lexeme (takeWhile1P (Just "letter") $ (&&) <$> (not.isSpace) <*> (/=')'))
 
 process :: Parser Process
-process = slot <* char '.' <*> morphValue
+process =
+    Stem <$> lexeme (char '~' *> L.decimal)
+    <|> (try (slot <* char '.') <*> morphValue)
 
 oneOrMany :: Parser p -> Parser [p]
 oneOrMany p = between (symbol "(") (symbol ")") (many p) <|> fmap pure p
@@ -52,31 +59,39 @@     Concrete <$> affix
     <|> Abstract . AbstractGrammeme <$> name
 
-condition :: Parser Condition
+parseExpr :: Parser a -> Parser (Expr a)
+parseExpr p = Any <$> ((All <$> some atom) `sepBy1` symbol "/")
+  where
+    atom = (Pred <$> p)
+        <|> between (symbol "(") (symbol ")") (parseExpr p)
+
+condition :: Parser (Expr Condition)
 condition = do
     _ <- symbol "when"
-    between (symbol "(") (symbol ")") $
-        try (Is . FeatureName <$> name <* symbol "is" <*> grammeme)
-        <|> Not . FeatureName <$> name <* symbol "not" <*> grammeme
+    parseExpr $ between (symbol "(") (symbol ")") $
+        try (Is <$> featureName <* symbol "is" <*> grammeme)
+        <|> Not <$> featureName <* symbol "not" <*> grammeme
+  where
+    featureName = (Class <$ lexeme (char '#')) <|> (FeatureName <$> name)
 
 feature :: Parser Feature
 feature = do
-    c <- fromMaybe Always <$> optional condition
+    c <- fromMaybe (All []) <$> optional condition
     globalSlot <- optional $ try $ slot <* space1'
     case globalSlot of
         Nothing -> do
             n <- optional $ try $ name <* symbol "="
             gs <- some grammeme
-            _ <- optional eol
-            return $ Feature c (FeatureName <$> n) gs
+            eolf
+            return $ Feature c n gs
         Just globalSlot' -> do
             n <- optional $ try $ name <* symbol "="
             gs <- some $ oneOrMany $ process <|> (globalSlot' <$> morphValue)
-            _ <- optional eol
-            return $ Feature c (FeatureName <$> n) (Concrete <$> gs)
+            eolf
+            return $ Feature c n (Concrete <$> gs)
 
-mapping :: Parser ([AbstractGrammeme], Affix)
-mapping = (,) <$> manyTill (AbstractGrammeme <$> name) (symbol ">") <*> affix <* optional eol
+mapping :: Parser (Expr AbstractGrammeme, Affix)
+mapping = (,) <$> parseExpr (AbstractGrammeme <$> name) <* symbol ">" <*> some process <* eolf
 
 statement :: Parser Statement
 statement = sc *>
@@ -86,6 +101,11 @@ -- | 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/v1.0.0/docs/Paradigm-Builder.md>.
+-- For details on the syntax, refer to <https://github.com/bradrn/brassica/blob/v1.1.0/docs/Paradigm-Builder.md>.
 parseParadigm :: String -> Either (ParseErrorBundle String Void) Paradigm
 parseParadigm = runParser (many statement) ""
+
+parseStems :: String -> (Maybe String, [String])
+parseStems = words >>> \case
+    ('#':p):ws -> (Just p, ws)
+    ws -> (Nothing, ws)

@@ -5,12 +5,11 @@  import Data.String (IsString) --- | Represents a single morphophonological process: currently, either--- prefixation or suffixation of a 'String'. The 'Int' gives the--- distance of the affix from the root.+-- | Represents a single morphophonological process. data Process-    = Prefix Int String-    | Suffix Int String+    = Prefix Int String  -- ^ Prefixation at some distance from the root+    | Suffix Int String  -- ^ Suffixation at some distance from the root+    | Stem Int           -- ^ Select stem by number     deriving (Show, Eq)  -- | A single affix (using the term in a wide sense) can be thought of@@ -37,9 +36,7 @@ -- | A condition which must be satisfied for a 'Feature' to be -- included in a word. data Condition-    = Always-    -- ^ Condition which is always satisfied-    | Is FeatureName Grammeme+    = Is FeatureName Grammeme     -- ^ Satisfied when the specified feature has been assigned to the     -- specified 'Grammeme'     | Not FeatureName Grammeme@@ -47,22 +44,26 @@     -- to the specified 'Grammeme'     deriving (Show, Eq) +-- | An expression built up from 'Pred'icates, combined with logical+-- and ('All') or logical or ('Any').+data Expr a = Any [Expr a] | All [Expr a] | Pred a+    deriving (Show, Eq)+ -- | A grammatical feature, which may be realised by one of a -- selection of 'Grammeme's. A feature may be given a descriptive -- name, as well as a condition which must be satisfied for the -- 'Feature' to be included in a word.-data Feature = Feature Condition (Maybe FeatureName) [Grammeme]+data Feature = Feature (Expr Condition) (Maybe String) [Grammeme]     deriving (Show, Eq) --- | Name to identify a specific 'Feature'.-newtype FeatureName = FeatureName String+-- | Name to identify a specific 'Feature', or the paradigm 'Class'.+data FeatureName = FeatureName String | Class     deriving stock (Show, Eq)-    deriving newtype (IsString)  -- | Each statement in a paradigm description specifies either a new -- 'Feature', or a new mapping from a set of abstract grammemes to -- their realisation.-data Statement = NewFeature Feature | NewMapping [AbstractGrammeme] Affix+data Statement = NewFeature Feature | NewMapping (Expr AbstractGrammeme) Affix     deriving (Show, Eq)  -- | A paradigm is specified as a list of 'Statement's. The order is

@@ -6,7 +6,7 @@ --
 -- The modules below provide Brassica’s support for sound changes.
 -- For further details on their syntax and processing, refer to the
--- [reference guide](https://github.com/bradrn/brassica/blob/v1.0.0/docs/Reference.md),
+-- [reference guide](https://github.com/bradrn/brassica/blob/v1.1.0/docs/Reference.md),
 -- and the documentation of individual modules.
 --
 -- In brief, a sound changes file passes through the following phases:

@@ -22,9 +22,11 @@        , applyChanges        , Log(..)        , LogItem(..)+       , rulesNotApplied        -- * Reporting results        , getOutput        , getReports+       , HighlightMode(..)        , getChangedOutputs        , getChangedReports        , reportAsText

@@ -85,8 +85,10 @@        , applyChanges
        , getOutput
        , getReports
+       , HighlightMode(..)
        , getChangedOutputs
        , getChangedReports
+       , rulesNotApplied
        ) where
 
 import Control.Applicative ((<|>))
@@ -323,12 +325,19 @@     -> [(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'
+    go !n out prev l mz =
+        ( insertAtKleene (length $ matchedKleenes origOut) n out
+        , mz
+        ) : case match out prev l mz of
+        [] -> []
+        r -> r >>= \case
+            (out', mz')
+                | curPos mz == curPos mz' ->
+                    -- cursor didn't advance, avoid infinite loop!
+                    [( insertAtKleene (length $ matchedKleenes origOut) n out
+                     , mz
+                    )]
+                | otherwise -> go (n+1) out' prev l mz'
 
 matchWildcard
     :: MatchOutput
@@ -634,7 +643,9 @@ -- | Status of a rule application at a single location.
 data RuleStatus
     = SuccessNormal      -- ^ Rule was successful, with no need for special handling
-    | SuccessEpenthesis  -- ^ Rule was successful, but cursor was not advanced (need to avoid infinite loop)
+    | SuccessEpenthesis Bool
+    -- ^ Rule was successful, but cursor was not advanced (need to avoid infinite loop);
+    -- also report whether any graphemes were matched before the replacement
     | Failure            -- ^ Rule failed
     deriving (Eq, Show)
 
@@ -650,12 +661,13 @@         case result of
             Just out -> do
                 exs <- case exception of
-                    Nothing -> pure []
-                    Just ex -> gets $ join . toList .
-                        extend' (exceptionAppliesAtPoint target ex)
+                    [] -> pure []
+                    exEnvs -> gets $ \mz ->
+                        join . toList . flip extend' mz . exceptionAppliesAtPoint target =<< exEnvs
                 originalWord <- get
                 let pMay = locationOf TargetStart originalWord
                     pMay' = locationOf PrevEnd originalWord
+                    noneMatchedBeforeReplacement = pMay == locationOf AppStart originalWord
                 case pMay of
                     Nothing -> error "applyOnce: start of target was not tagged"
                     Just p
@@ -676,10 +688,8 @@                         -- but not TargetStart, so restore its old position
                         modifyMay $ tagAt TargetStart p
                         return $
-                            -- An epenthesis rule will cause an infinite loop
-                            -- if it matched no graphemes before the replacement
-                            if null (matchedGraphemes out) && null (fst env)
-                                then SuccessEpenthesis
+                            if null (matchedGraphemes out)
+                                then SuccessEpenthesis noneMatchedBeforeReplacement
                                 else SuccessNormal
             Nothing -> modifyMay (seek AppStart) >> go envs
 
@@ -694,8 +704,13 @@     resetTags <=< case status of
         SuccessNormal ->
             seek (if nonOverlappingTarget then TargetEnd else TargetStart)
-        SuccessEpenthesis ->
-            -- need to move forward if applying an epenthesis rule to avoid an infinite loop
+        SuccessEpenthesis False ->
+            -- treat as 'nonOverlappingTarget' to avoid possible infinite loops
+            -- (when the replacement would also match the first part of the target)
+            seek TargetEnd
+        SuccessEpenthesis True ->
+            -- matched no graphemes before replacement, so environment still matches:
+            -- move forward to avoid infinite loop
             seek TargetEnd >=> fwd
         Failure -> seek AppStart >=> fwd
   where
@@ -733,6 +748,7 @@             , exception = reverseEnv <$> exception r
             , flags = flags r
             , plaintext = plaintext r
+            , loc = loc r
             }
 
     reverseEnv (e1, e2) = (reverse e2, reverse e1)
@@ -747,7 +763,7 @@ 
 -- | Check if a 'MultiZipper' matches a 'Filter'.
 filterMatches :: Filter Expanded -> MultiZipper RuleTag Grapheme -> Bool
-filterMatches (Filter _ ls) = go . toBeginning
+filterMatches (Filter _ _ ls) = go . toBeginning
   where
     go mz =
         let mzs = matchMany initialOutput Nothing ls mz
@@ -805,6 +821,8 @@     = ActionApplied r (Maybe PWord)
     -- ^ The word was modified: gives the output word, or 'Nothing' if
     -- the wordwas deleted
+    | ActionNotApplied r PWord
+    -- ^ The word was not modified by the given rule
     | ReportWord PWord
     -- ^ Corresponds to 'ReportS', giving the intermediate form to report
     deriving (Show, Functor, Generic, NFData)
@@ -813,8 +831,13 @@ -- action (ActionApplied r _ _) = Just r
 -- action (ReportWord _) = Nothing
 
+noApplication :: LogItem r -> Bool
+noApplication (ActionNotApplied _ _) = True
+noApplication _ = False
+
 logOutput :: LogItem r -> Maybe PWord
 logOutput (ActionApplied _ o) = o
+logOutput (ActionNotApplied _ o) = Just o
 logOutput (ReportWord o) = Just o
 
 -- | Logs the evolution of a word as it undergoes sound changes and
@@ -844,14 +867,20 @@ reportAsHtmlRows
     :: (r -> String)  -- ^ Specifies how to pretty-print actions as text
     -> Log r -> String
-reportAsHtmlRows render item = go (concatWithBoundary $ inputWord item) (derivations item)
+reportAsHtmlRows render item
+    | all noApplication (derivations item) =
+        "<tr><td>" ++ input ++ "</td><td></td><td></td><td>(no change)</td>"
+    | otherwise = go input (derivations item)
   where
+    input = concatWithBoundary $ inputWord item
+
     go _ [] = ""
     go cell1 (ActionApplied action output : ds) =
         ("<tr><td>" ++ cell1 ++ "</td><td>&rarr;</td><td>"
          ++ maybe "<i>deleted</i>" concatWithBoundary output
          ++ "</td><td>(" ++ render action ++ ")</td></tr>")
         ++ go "" ds
+    go cell1 (ActionNotApplied _ _ : ds) = go cell1 ds
     go cell1 (ReportWord w : ds) =
         ("<tr><td>" ++ cell1 ++ "</td><td>&rarr;</td><td>"
          ++ concatWithBoundary w
@@ -878,11 +907,14 @@ reportAsText
     :: (r -> String)  -- ^ Specifies how to pretty-print actions as text
     -> Log r -> String
-reportAsText render item = unlines $
-    concatWithBoundary (inputWord item) : fmap toLine (alignWithPadding $ derivations item)
+reportAsText render item
+    | all noApplication (derivations item) = input ++ " (no change)"
+    | otherwise = unlines $ input : fmap toLine (alignWithPadding $ derivations item)
   where
+    input = concatWithBoundary (inputWord item)
+
     alignWithPadding ds =
-        let (rawOutputs, actions) = unzip $ toPrintable <$> ds
+        let (rawOutputs, actions) = unzip $ mapMaybe toPrintable ds
             outputs = maybe "(deleted)" concatWithBoundary <$> rawOutputs
             maxlen = maximum $ length <$> outputs
             padded = outputs <&> \o -> o ++ replicate (maxlen - length o) ' '
@@ -890,8 +922,9 @@ 
     toLine (output, action) = "  -> " ++ output ++ "  (" ++ action ++ ")"
 
-    toPrintable (ActionApplied a o) = (o, render a)
-    toPrintable (ReportWord w) = (Just w, "report")
+    toPrintable (ActionApplied a o) = Just (o, render a)
+    toPrintable (ActionNotApplied _ _) = Nothing
+    toPrintable (ReportWord w) = Just (Just w, "report")
 
 -- | Apply a single 'Statement' to a word. Returns a 'LogItem' for
 -- each possible result, or @[]@ if the rule does not apply and the
@@ -903,7 +936,7 @@ applyStatement ReportS w = [ReportWord w]
 applyStatement st w = case applyStatementStr st w of
     [] -> [ActionApplied st Nothing]
-    [w'] | w' == w -> []
+    [w'] | w' == w -> [ActionNotApplied st w']
     r -> ActionApplied st . Just <$> r
 
 -- | Apply a set of 'SoundChanges' to a word, returning a log of which
@@ -927,7 +960,15 @@                     Just w'' -> (l :) <$> go sts w''
                     -- apply no further changes to a deleted word
                     Nothing -> [[l]]
+                l@(ActionNotApplied _ w'') -> (l :) <$> go sts w''
 
+-- | Returns the list of sound changes which did /not/ apply in the
+-- given sound change log.
+rulesNotApplied :: Log r -> [r]
+rulesNotApplied =
+    mapMaybe (\case ActionNotApplied r _ -> Just r; _ -> Nothing)
+    . derivations
+
 -- | Returns the final output from a sound change log.
 getOutput :: Log r -> Maybe PWord
 getOutput l = case derivations l of
@@ -937,46 +978,51 @@ -- | Returns, in order: the input word, any intermediate results from
 -- 'ReportS', and then the final output.
 getReports :: Log r -> [PWord]
-getReports l = inputWord l : go (derivations l)
+getReports l = inputWord l : go Nothing (derivations l)
   where
-    go [] = []
-    go [ActionApplied _ (Just w')] = [w']
-    go (ReportWord w':ls) = w' : go ls
-    go (_:ls) = go ls
+    go w [] = maybeToList w
+    go _ (ActionApplied    _ w' : ls) = go w' ls
+    go _ (ActionNotApplied _ w' : ls) = go (Just w') ls
+    go _ (ReportWord w':ls) = w' : go (Just w') ls
 
+data HighlightMode = AllChanged | SpecificRule
+    deriving (Show, Eq)
+
+-- | Based on its flags, should this rule be highlighted in the given 'HighlightMode'?
+needsHighlight :: HighlightMode -> Rule c -> Bool
+needsHighlight m rule = case m of
+    AllChanged -> highlightChanges $ flags rule
+    SpecificRule -> highlightSpecificRule $ flags rule
+
 -- | Returns the final output from a sound change log, as well as an
 -- indication of whether any sound changes have applied to it
--- (accounting for 'highlightChanges' flags).
-getChangedOutputs :: Log (Statement c d) -> Maybe (PWord, Bool)
-getChangedOutputs l = case derivations l of
+-- (accounting for highlighting flags).
+getChangedOutputs :: HighlightMode -> Log (Statement c d) -> Maybe (PWord, Bool)
+getChangedOutputs m l = case derivations l of
     [] -> Just (inputWord l, False)
     logs -> case logOutput (last logs) of
         Just out -> Just (out, hasChanged logs)
         Nothing -> Nothing
   where
     hasChanged = any $ \case
-        ActionApplied (RuleS rule) _ -> highlightChanges $ flags rule
+        ActionApplied (RuleS rule) _ -> needsHighlight m rule
         ActionApplied (FilterS _) _ -> False  -- cannot highlight nonexistent word
         ActionApplied (DeclS _) _ -> True
         ActionApplied ReportS _ -> False  -- reporting a word yields no change
+        ActionNotApplied _ _ -> False
         ReportWord _ -> False
 
--- | A combination of 'getOutput' and 'getChangedOutputs': returns all
+-- | A combination of 'getReports' and 'getChangedOutputs': returns all
 -- intermediate results, as well as whether each has undergone any
 -- sound changes.
-getChangedReports :: Log (Statement c d) -> [(PWord, Bool)]
-getChangedReports l = (inputWord l, False) : case derivations l of
-    [] -> []
-    ls -> go False ls
+getChangedReports :: HighlightMode -> Log (Statement c d) -> [(PWord, Bool)]
+getChangedReports m l = (inputWord l, False) : go False Nothing (derivations l)
   where
-    go _ [] = []
-    go hasChanged (ActionApplied action _:ls) =
+    go hasChanged w [] = maybeToList $ w <&> (,hasChanged)
+    go hasChanged _ (ActionApplied action w':ls) =
         let hasChanged' = case action of
-                RuleS rule -> hasChanged || highlightChanges (flags rule)
+                RuleS rule -> hasChanged || needsHighlight m rule
                 _ -> hasChanged
-        in go hasChanged' ls
-    go hasChanged (ReportWord w':ls) = (w', hasChanged) : go hasChanged ls
-
--- | Apply a set of 'SoundChanges' to a word, returning the final
--- output word(s) as well as any intermediate results from 'ReportS',
--- each with a boolean marking changed results (as with 'applyChangesWithChanges').
+        in go hasChanged' w' ls
+    go hasChanged _ (ActionNotApplied _ w':ls) = go hasChanged (Just w') ls
+    go hasChanged _ (ReportWord w':ls) = (w', hasChanged) : go hasChanged (Just w') ls

@@ -4,6 +4,7 @@ {-# LANGUAGE GADTs #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TupleSections #-}
 
 -- |
@@ -43,11 +44,11 @@ import Prelude hiding (lookup)
 import Control.DeepSeq (NFData)
 import Control.Monad (foldM, unless)
-import Control.Monad.State.Strict (StateT, evalStateT, lift, get, put, gets)
+import Control.Monad.State.Strict (StateT, evalStateT, lift, get, gets, modify)
 import Data.Bifunctor (first, second)
 import Data.Containers.ListUtils (nubOrd)
 import Data.List (transpose, foldl', stripPrefix)
-import Data.Maybe (mapMaybe, catMaybes)
+import Data.Maybe (mapMaybe)
 import Data.Traversable (for)
 import GHC.Generics (Generic)
 
@@ -259,13 +260,14 @@     <*> traverse expandEnvironment (exception r)
     <*> pure (flags r)
     <*> pure (plaintext r)
+    <*> pure (loc r)
   where
     expandEnvironment (e1, e2) = (,)
         <$> traverse (expandLexeme cs) e1
         <*> traverse (expandLexeme cs) e2
 
 expandFilter :: Categories -> Filter CategorySpec -> Either ExpandError (Filter Expanded)
-expandFilter cs (Filter p f) = Filter p <$> traverse (expandLexeme cs) f
+expandFilter cs (Filter p l f) = Filter p l <$> traverse (expandLexeme cs) f
 
 -- | Extend a set of previously defined t'Categories' to give the
 -- resulting state after a v'Categories' directive.
@@ -321,6 +323,12 @@     mkAuto :: String -> String -> [String] -> (String, Either (Expanded 'AnyPart) AutosegmentDef)
     mkAuto f g gs = (g, Right $ AutosegmentDef f gs)
 
+data ExpansionState = ExpansionState
+    { categories :: Categories
+    , extras :: [String]
+    , persistents :: [(String, Rule Expanded)]
+    } deriving (Show)
+
 -- | Expand a set of 'SoundChanges'. Expansion proceeds from beginning
 -- to end as follows:
 --
@@ -337,37 +345,55 @@ --       currently defined graphemes. They are replaced with a
 --       'GraphemeList' only if no categories are defined in the
 --       'SoundChanges'.
+--
+-- On an error, returns the appropriate 'ExpandError' together with
+-- the line number of the offending statement (if it has one).
 expandSoundChanges
     :: SoundChanges CategorySpec Directive
-    -> Either ExpandError (SoundChanges Expanded GraphemeList)
-expandSoundChanges scs = fmap catMaybes $ flip evalStateT (M.empty, []) $ traverse go scs
+    -> Either (Maybe Int, ExpandError) (SoundChanges Expanded GraphemeList)
+expandSoundChanges scs = fmap concat $ flip evalStateT initState $ traverse go scs
   where
     noCategories = any (\case DeclS (Categories {}) -> True; _ -> False) scs
 
+    initState = ExpansionState M.empty [] []
+
     go  :: Statement CategorySpec Directive
         -> StateT
-            (Categories, [String])
-            (Either ExpandError)
-            (Maybe (Statement Expanded GraphemeList))
+            ExpansionState
+            (Either (Maybe Int, ExpandError))
+            [Statement Expanded GraphemeList]
     go (RuleS r) = do
-        cs <- gets fst
-        lift $ Just . RuleS <$> expandRule cs r
-    go (FilterS f) = do
-        cs <- gets fst
-        lift $ Just . FilterS <$> expandFilter cs f
-    go ReportS = pure (Just ReportS)
+        ExpansionState{..} <- get
+        st <- lift $ first (Just $ loc r,) (expandRule categories r)
+        case persistent (flags st) of
+            Nothing -> pure ()
+            Just label ->
+                modify $ \s -> s
+                    { persistents = (label, st) : persistents
+                    }
+        -- NB. 'persistents' here doesn't contain current rule
+        pure $ RuleS <$> (st : reverse (snd <$> persistents))
+    go (FilterS f@(Filter _ l _)) = do
+        cs <- gets categories
+        lift $ pure . FilterS <$> first (Just l,) (expandFilter cs f)
+    go ReportS = pure [ReportS]
     go (DeclS (ExtraGraphemes extra)) = do
-        (cs, _) <- get
-        put (cs, extra)
+        modify $ \s -> s { extras = extra }
         pure $
             if noCategories
-            then Just $ DeclS $ GraphemeList True extra
-            else Nothing
-    go (DeclS (Categories overwrite noreplace defs)) = do
-        (cs, extra) <- get
-        cs' <- lift $ extendCategories cs (overwrite, defs)
-        put (cs', extra)
-        pure $ Just $ DeclS $ GraphemeList noreplace $ extra ++ mapMaybe grapheme (values cs')
+            then [DeclS $ GraphemeList True extra]
+            else []
+    go (DeclS (Categories l overwrite noreplace defs)) = do
+        ExpansionState{..} <- get
+        cs' <- lift $ first (Just l,) (extendCategories categories (overwrite, defs))
+        modify $ \s -> s
+            { categories = cs'
+            , persistents = []  -- invalidate persistent rules if categories change
+            }
+        pure $ pure $ DeclS $ GraphemeList noreplace $ extras ++ mapMaybe grapheme (values cs')
+    go (DeclS (DisablePersistent label)) = do
+        modify $ \s -> s { persistents = filter ((/=label) . fst) (persistents s) }
+        pure []
 
     grapheme [Grapheme g] = Just g
     grapheme _ = Nothing

@@ -1,9 +1,15 @@ {-# LANGUAGE DeriveAnyClass  #-}
 {-# LANGUAGE DeriveGeneric   #-}
 {-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE LambdaCase      #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RankNTypes      #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections   #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 
 -- |
 -- Module      : Brassica.SoundChange.Frontend.Internal
@@ -23,55 +29,63 @@ module Brassica.SoundChange.Frontend.Internal where
 
 import Control.Monad ((<=<))
+import Control.Parallel.Strategies (withStrategy, parTraversable, rseq)
+import Data.Aeson (FromJSON(..), ToJSON(..), Value (..))
+import Data.Aeson.TH (deriveJSON, defaultOptions, defaultTaggedObject, constructorTagModifier, sumEncoding, tagFieldName)
+import Data.Aeson.Types (prependFailure, typeMismatch)
 import Data.Containers.ListUtils (nubOrd)
-import Data.List (transpose, intersperse)
-import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Foldable (toList)
+import Data.List (transpose, intersperse, intersectBy)
+import qualified Data.List.NonEmpty as NE
+import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
 import Data.Void (Void)
+import Data.Text (unpack)
 import GHC.Generics (Generic)
 import Myers.Diff (getDiff, PolyDiff(..))
 
 import Control.DeepSeq (NFData)
-import Text.Megaparsec (ParseErrorBundle)
+import Text.Megaparsec (reachOffsetNoLine, errorOffset, PosState (..), SourcePos (..), unPos)
+import Text.Megaparsec.Error (ParseErrorBundle(..))
 
 import Brassica.SFM.MDF
 import Brassica.SFM.SFM
-import Brassica.SoundChange.Apply
+import Brassica.SoundChange (ExpandError(..), parseSoundChanges, errorBundlePretty, expandSoundChanges)
+import Brassica.SoundChange.Apply hiding (HighlightMode)
+import qualified Brassica.SoundChange.Apply as A
 import Brassica.SoundChange.Tokenise
 import Brassica.SoundChange.Types
+import Brassica.Paradigm (parseParadigm, parseStems, formatNested, ResultsTree (..), applyParadigm)
 
 -- | Rule application mode of the SCA.
 data ApplicationMode
     = ApplyRules HighlightMode OutputMode String
     -- ^ Apply sound changes as normal, with the given modes and
     -- separator
-    | ReportRulesApplied
-    -- ^ Apply reporting the rules which were applied (as HTML)
+    | ReportRules ReportMode
+    -- ^ Apply reporting rules (as HTML)
     deriving (Show, Eq)
 
+data ReportMode
+    = ReportApplied
+    -- ^ Report the rules which were applied
+    | ReportNotApplied
+    -- ^ Report the rules which were not applied
+    deriving (Show, Eq)
+
 -- | Get the 'OutputMode' if one is set, otherwise default to
 -- 'WordsOnlyOutput'.
 getOutputMode :: ApplicationMode -> OutputMode
 getOutputMode (ApplyRules _ o _) = o
-getOutputMode ReportRulesApplied = WordsOnlyOutput
+getOutputMode (ReportRules _) = WordsOnlyOutput
 
 -- | Mode for highlighting output words
 data HighlightMode
     = NoHighlight
     | DifferentToLastRun
-    | DifferentToInput
+    | DifferentToInput A.HighlightMode
     -- ^ NB. now labeled ‘any rule applied’ in GUI
     deriving (Show, Eq)
-instance Enum HighlightMode where
-    -- used for conversion to and from C, so want control over values
-    fromEnum NoHighlight = 0
-    fromEnum DifferentToLastRun = 1
-    fromEnum DifferentToInput = 2
 
-    toEnum 0 = NoHighlight
-    toEnum 1 = DifferentToLastRun
-    toEnum 2 = DifferentToInput
-    toEnum _ = undefined
-
 -- | Mode for reporting output words (and sometimes intermediate and
 -- input words too)
 data OutputMode
@@ -81,27 +95,14 @@     | WordsWithProtoOutput
     | WordsWithProtoOutputPreserve
     deriving (Show, Eq)
-instance Enum OutputMode where
-    -- used for conversion to and from C, so want control over values
-    fromEnum MDFOutput = 0
-    fromEnum WordsOnlyOutput = 1
-    fromEnum MDFOutputWithEtymons = 2
-    fromEnum WordsWithProtoOutput = 3
-    fromEnum WordsWithProtoOutputPreserve = 4
 
-    toEnum 0 = MDFOutput
-    toEnum 1 = WordsOnlyOutput
-    toEnum 2 = MDFOutputWithEtymons
-    toEnum 3 = WordsWithProtoOutput
-    toEnum 4 = WordsWithProtoOutputPreserve
-    toEnum _ = undefined
-
 -- | Output of a single application of rules to a wordlist: either a
 -- list of possibly highlighted words, an applied rules table, or a
 -- parse error.
 data ApplicationOutput a r
     = HighlightedWords [Component (a, Bool)]
     | AppliedRulesTable [Log r]
+    | NotAppliedRulesList [Rule Expanded]
     | ParseError (ParseErrorBundle String Void)
     deriving (Show, Generic, NFData)
 
@@ -112,17 +113,7 @@ -- | Kind of input: either a raw wordlist, or an MDF file.
 data InputLexiconFormat = Raw | MDF MDFHierarchy
     deriving (Show, Eq)
-instance Enum InputLexiconFormat where
-    -- used for conversion to and from C, so want control over values
-    fromEnum Raw = 0
-    fromEnum (MDF Standard) = 1
-    fromEnum (MDF Alternate) = 2
 
-    toEnum 0 = Raw
-    toEnum 1 = MDF Standard
-    toEnum 2 = MDF Alternate
-    toEnum _ = undefined
-
 -- | Either a list of 'Component's for a Brassica wordlist file, or a
 -- list of 'SFM' fields for an MDF file
 data ParseOutput a = ParsedRaw [Component a] | ParsedMDF SFM
@@ -171,9 +162,14 @@     case tokeniseAccordingToInputFormat intype (getOutputMode mode) statements ws of
         Left e -> ParseError e
         Right toks -> case mode of
-            ReportRulesApplied ->
+            ReportRules ReportApplied ->
                 AppliedRulesTable $ concat $
                     getWords $ parFmap (applyChanges statements) toks
+            ReportRules ReportNotApplied ->
+                let ws' = getWords $ parFmap (applyChanges statements) toks
+                    na = mapMaybe tagLOC . rulesNotApplied <$> concat ws'
+                in NotAppliedRulesList $ intersectByTag na
+                -- let is = intersect' $ getWords $ parFmap (rulesNotApplied statements) toks
             ApplyRules DifferentToLastRun mdfout sep ->
                 let result = concatMap (splitMultipleResults sep) $
                         joinComponents' mdfout $ parFmap (doApply mdfout statements) toks
@@ -181,9 +177,9 @@                     mapMaybe polyDiffToHighlight $ getDiff (fromMaybe [] prev) result
                     -- zipWithComponents result (fromMaybe [] prev) [] $ \thisWord prevWord ->
                     --     (thisWord, thisWord /= prevWord)
-            ApplyRules DifferentToInput mdfout sep ->
+            ApplyRules (DifferentToInput m) mdfout sep ->
                 HighlightedWords $ concatMap (splitMultipleResults sep) $
-                        joinComponents' mdfout $ parFmap (doApplyWithChanges mdfout statements) toks
+                        joinComponents' mdfout $ parFmap (doApplyWithChanges m mdfout statements) toks
             ApplyRules NoHighlight mdfout sep ->
                 HighlightedWords $ (fmap.fmap) (,False) $ concatMap (splitMultipleResults sep) $
                     joinComponents' mdfout $ parFmap (doApply mdfout statements) toks
@@ -201,6 +197,14 @@     unsafeCastComponent (Separator s) = Separator s
     unsafeCastComponent (Gloss s) = Gloss s
 
+    intersectByTag :: Eq a => [[(a, b)]] -> [b]
+    intersectByTag [] = []
+    intersectByTag xs = snd <$> foldr1 (intersectBy (\x y -> fst x == fst y)) xs
+
+    tagLOC :: Statement Expanded GraphemeList -> Maybe (Int, Rule Expanded)
+    tagLOC (RuleS r) = Just (loc r, r)
+    tagLOC _ = Nothing
+
     doApply :: OutputMode -> SoundChanges Expanded GraphemeList -> PWord -> [Component [PWord]]
     doApply WordsWithProtoOutput scs w = doApplyWithProto scs w
     doApply WordsWithProtoOutputPreserve scs w = doApplyWithProto scs w
@@ -211,14 +215,14 @@             intermediates = fmap nubOrd $ transpose $ getReports <$> applyChanges scs w
         in intersperse (Separator " → ") (fmap Word intermediates)
 
-    doApplyWithChanges :: OutputMode -> SoundChanges Expanded GraphemeList -> PWord -> [Component [(PWord, Bool)]]
-    doApplyWithChanges WordsWithProtoOutput scs w = doApplyWithChangesWithProto scs w
-    doApplyWithChanges WordsWithProtoOutputPreserve scs w = doApplyWithChangesWithProto scs w
-    doApplyWithChanges _ scs w = [Word $ mapMaybe getChangedOutputs $ applyChanges scs w]
+    doApplyWithChanges :: A.HighlightMode -> OutputMode -> SoundChanges Expanded GraphemeList -> PWord -> [Component [(PWord, Bool)]]
+    doApplyWithChanges m WordsWithProtoOutput scs w = doApplyWithChangesWithProto m scs w
+    doApplyWithChanges m WordsWithProtoOutputPreserve scs w = doApplyWithChangesWithProto m scs w
+    doApplyWithChanges m _ scs w = [Word $ mapMaybe (getChangedOutputs m) $ applyChanges scs w]
 
-    doApplyWithChangesWithProto scs w =
+    doApplyWithChangesWithProto m scs w =
         let intermediates :: [[(PWord, Bool)]]
-            intermediates = fmap nubOrd $ transpose $ getChangedReports <$> applyChanges scs w
+            intermediates = fmap nubOrd $ transpose $ getChangedReports m <$> applyChanges scs w
         in intersperse (Separator " → ") (fmap Word intermediates)
 
     joinComponents' WordsWithProtoOutput =
@@ -234,3 +238,147 @@     linespace (c:cs@(Separator _:_)) = c : linespace cs
     linespace (c:cs) = c : Separator "\n" : linespace cs
     linespace [] = []
+
+getErrorLocs :: ParseErrorBundle String Void -> [Int]
+getErrorLocs ParseErrorBundle { bundleErrors, bundlePosState } =
+    go (NE.toList bundleErrors) bundlePosState
+  where
+    -- based on Text.Megaparsec.Error.errorBundlePrettyWith
+    go (e:es) pst =
+        let pst' = reachOffsetNoLine (errorOffset e) pst
+            l = unPos $ sourceLine $ pstateSourcePos pst'
+        in l : go es pst'
+    go [] _ = []
+
+
+-------- JSON server
+
+
+data Request
+    = ReqRules
+        { changes :: String
+        , input :: String
+        , report :: Maybe ReportMode
+        , inFmt :: InputLexiconFormat
+        , hlMode :: HighlightMode
+        , outMode :: OutputMode
+        , prev :: Maybe [Component PWord]
+        , sep :: String
+        , reqTimeout :: Int   -- ^ microseconds
+        }
+    | ReqParadigm
+        { pText :: String
+        , input :: String
+        , separateLines :: Bool
+        , reqTimeout :: Int  -- ^ microseconds
+        }
+    deriving (Show)
+
+data Response
+    = RespRules
+        { prev :: Maybe [Component PWord]
+        , output :: String
+        }
+    | RespParadigm
+        { output :: String
+        }
+    | RespNotApplied
+        { highlights :: [Int]
+        }
+    | RespError
+        { highlights :: [Int]
+        , message :: String
+        }
+    deriving (Show, Generic, NFData)
+
+instance ToJSON InputLexiconFormat where
+    toJSON Raw = "Raw"
+    toJSON (MDF Standard) = "MDFStandard"
+    toJSON (MDF Alternate) = "MDFAlternate"
+
+instance FromJSON InputLexiconFormat where
+    parseJSON (String "Raw") = pure Raw
+    parseJSON (String "MDFStandard") = pure $ MDF Standard
+    parseJSON (String "MDFAlternate") = pure $ MDF Alternate
+    parseJSON (String s) = fail $ "Unknown InputLexiconFormat: " ++ unpack s
+    parseJSON invalid = prependFailure "parsing InputLexiconFormat failed: " $
+        typeMismatch "String" invalid
+
+instance FromJSON HighlightMode where
+    parseJSON (String "NoHighlight") = pure NoHighlight
+    parseJSON (String "DifferentToLastRun") = pure DifferentToLastRun
+    parseJSON (String "DifferentToInputAllChanged") = pure $ DifferentToInput AllChanged
+    parseJSON (String "DifferentToInputSpecificRule") = pure $ DifferentToInput SpecificRule
+    parseJSON invalid = prependFailure "parsing HighlightMode failed: " $
+        typeMismatch "String" invalid
+
+instance ToJSON HighlightMode where
+    toJSON NoHighlight = "NoHighlight"
+    toJSON DifferentToLastRun = "DifferentToLastRun"
+    toJSON (DifferentToInput AllChanged) = "DifferentToInputAllChanged"
+    toJSON (DifferentToInput SpecificRule) = "DifferentToInputSpecificRule"
+
+$(deriveJSON defaultOptions ''OutputMode)
+$(deriveJSON defaultOptions ''ReportMode)
+
+$(deriveJSON defaultOptions{constructorTagModifier=drop 3, sumEncoding=defaultTaggedObject{tagFieldName="method"}} ''Request)
+$(deriveJSON defaultOptions{constructorTagModifier=drop 4, sumEncoding=defaultTaggedObject{tagFieldName="method"}} ''Response)
+
+
+dispatch :: Request -> Response
+dispatch r = case r of
+    ReqRules{} -> parseTokeniseAndApplyRulesWrapper r
+    ReqParadigm{} -> parseAndBuildParadigmWrapper r
+  where
+    parseTokeniseAndApplyRulesWrapper
+        :: Request
+        -> Response
+    parseTokeniseAndApplyRulesWrapper ReqRules{..} =
+        let mode = maybe (ApplyRules hlMode outMode sep) ReportRules report
+        in case parseSoundChanges changes of
+            Left e -> RespError (getErrorLocs e) $ "<pre>" ++ errorBundlePretty e ++ "</pre>"
+            Right statements ->
+                case expandSoundChanges statements of
+                    Left (loc, err) -> RespError (maybeToList loc) $ ("<pre>"++) $ (++"</pre>") $ case err of
+                        (NotFound s) -> "Could not find category: " ++ s
+                        InvalidBaseValue -> "Invalid value used as base grapheme in feature definition"
+                        InvalidDerivedValue -> "Invalid value used as derived grapheme in autosegment"
+                        MismatchedLengths -> "Mismatched lengths in feature definition"
+                    Right statements' ->
+                        let result' = parseTokeniseAndApplyRules parFmap statements' input inFmt mode prev
+                        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 $
+                                concatMap (surroundTable . reportAsHtmlRows plaintext') items
+                            NotAppliedRulesList items -> RespNotApplied $ loc <$> items
+      where
+        highlightWord (s, False) = concatWithBoundary s
+        highlightWord (s, True) = "<b>" ++ concatWithBoundary s ++ "</b>"
+
+        surroundTable :: String -> String
+        surroundTable s = "<table>" ++ s ++ "</table>"
+    parseTokeniseAndApplyRulesWrapper _ = error "parseTokeniseAndApplyRulesWrapper: unexpected request!"
+
+    parseAndBuildParadigmWrapper :: Request -> Response
+    parseAndBuildParadigmWrapper ReqParadigm{..} =
+        case parseParadigm pText of
+            Left e -> RespError [] $ "<pre>" ++ errorBundlePretty e ++ "</pre>"
+            Right p -> RespParadigm $ escape $
+                (if separateLines
+                    then unlines . toList
+                    else formatNested id)
+                $ Node $ uncurry (applyParadigm p) . parseStems <$> lines input
+    parseAndBuildParadigmWrapper _ = error "parseAndBuildParadigmWrapper: unexpected request!"
+
+    escape :: String -> String
+    escape = concatMap $ \case
+        '\n' -> "<br/>"
+        -- '\t' -> "&#9;"  -- this doesn't seem to do anything - keeping it here in case I eventually figure out how to do tabs in Qt
+        c    -> pure c
+
+parFmap :: (a -> b) -> [Component a] -> [Component b]
+parFmap f = withStrategy (parTraversable rseq) . fmap (fmap f)

@@ -13,7 +13,7 @@ -- -- Functions to parse sound changes in Brassica syntax. (For details -- on the syntax, refer to the--- [reference guide](https://github.com/bradrn/brassica/blob/v1.0.0/docs/Reference.md).)+-- [reference guide](https://github.com/bradrn/brassica/blob/v1.1.0/docs/Reference.md).) module Brassica.SoundChange.Parse     ( parseRule     , parseSoundChanges@@ -21,10 +21,10 @@     , module Text.Megaparsec.Error     ) where -import Data.Char (isSpace)+import Data.Char (isSpace, isAlphaNum) import Data.Foldable (asum) import Data.List (dropWhileEnd)-import Data.Maybe (isNothing, isJust, fromJust, fromMaybe)+import Data.Maybe (isJust, fromJust, fromMaybe) import Data.Void (Void)  import Control.Applicative.Permutations@@ -110,7 +110,9 @@ parseCategoryStandalone = do     g <- parseGrapheme' True     _ <- symbol "="-    mods <- some (parseCategoryModification False)+    mods <- (:)+        <$> parseCategoryModification True+        <*> many (parseCategoryModification False)     return (g, CategorySpec mods)  parseFeature :: Parser FeatureSpec@@ -142,12 +144,13 @@         <|> pure Union  parseDirective :: Parser Directive-parseDirective = parseCategoriesDirective <|> parseExtraDirective+parseDirective = parseCategoriesDirective <|> parseExtraDirective <|> parsePStop   where     parseExtraDirective = fmap ExtraGraphemes $         symbol "extra" *> many (parseGrapheme' False) <* scn      parseCategoriesDirective = do+        loc <- unPos . sourceLine <$> getSourcePos         overwrite <- isJust <$> optional (symbol "new")         _ <- symbol "categories"         noreplace <- isJust <$> optional (symbol "noreplace")@@ -157,8 +160,11 @@             DefineAuto <$> parseAuto <|>             uncurry DefineCategory <$> (try parseCategoryStandalone <* scn)         _ <- symbol "end" <* scn-        pure $ Categories overwrite noreplace cs+        pure $ Categories loc overwrite noreplace cs +    parsePStop = fmap DisablePersistent $+        symbol "pstop" *> takeWhile1P (Just "alphanumeric character") isAlphaNum <* scn+ parseOptional :: ParseLexeme a => Parser (Lexeme CategorySpec a) parseOptional = Optional <$> between (symbol "(") (symbol ")") (some parseLexeme) @@ -242,12 +248,15 @@  parseFlags :: Parser Flags parseFlags = runPermutation $ Flags-    <$> toPermutation (isNothing <$> optional (symbol "-x"))+    <$> toPermutationWithDefault True (False <$ symbol "-x")+    <*> toPermutationWithDefault False (True <$ symbol "-h")     <*> toPermutationWithDefault LTR ((LTR <$ symbol "-ltr") <|> (RTL <$ symbol "-rtl"))-    <*> toPermutation (isJust <$> optional (symbol "-1"))+    <*> toPermutationWithDefault False (True <$ symbol "-1")     <*> toPermutationWithDefault ApplyAlways         ((PerApplication <$ symbol "-??") <|> (PerWord <$ symbol "-?"))-    <*> toPermutation (isJust <$> optional (symbol "-no"))+    <*> toPermutationWithDefault False (True <$ symbol "-no")+    <*> toPermutationWithDefault Nothing+        (fmap Just $ symbol "-pstart" *> lexeme (takeWhile1P (Just "alphanumeric character") isAlphaNum))  ruleParser :: Parser (Rule CategorySpec) ruleParser = do@@ -256,6 +265,7 @@     -- to wrap multiple parsers rather than just one     o <- getOffset     s <- getInput+    loc <- unPos . sourceLine <$> getSourcePos      flags <- parseFlags     target <- manyTill parseLexeme $ lexeme $ choice@@ -268,13 +278,12 @@     envs' <- many $ do         notFollowedBy $ symbol "//"  -- for exceptions         _ <- symbol "/"-        env1 <- parseLexemes-        _ <- symbol "_"-        env2 <- parseLexemes-        return (env1, env2)+        parseEnv     let envs = if null envs' then [([], [])] else envs' -    exception <- optional $ (,) <$> (symbol "//" *> parseLexemes) <* symbol "_" <*> parseLexemes+    exception <-+        (symbol "//" *> ((:) <$> parseEnv <*> many (symbol "/" *> parseEnv)))+        <|> pure []      o' <- getOffset @@ -283,9 +292,18 @@     let plaintext = dropWhile isSpace $ dropWhileEnd isSpace $             (fst . fromJust) (takeN_ (o' - o) s)     return Rule{environment=envs, ..}+  where+    parseEnv = do+        env1 <- parseLexemes+        _ <- symbol "_"+        env2 <- parseLexemes+        return (env1, env2)  filterParser :: Parser (Filter CategorySpec)-filterParser = fmap (uncurry Filter) $ match $ symbol "filter" *> parseLexemes <* optional scn+filterParser = do+    loc <- unPos . sourceLine <$> getSourcePos+    (p, f) <- match $ symbol "filter" *> parseLexemes <* optional scn+    pure $ Filter p loc f  -- Space handline is a little complex here: we want to make sure that -- 'report' is always on its own line, but can have as much or as

@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric     #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE TemplateHaskell   #-} {-# LANGUAGE TypeFamilies      #-} {-# LANGUAGE ViewPatterns      #-} @@ -34,6 +35,7 @@        , sortByDescendingLength        ) where +import Data.Aeson.TH (deriveJSON, defaultOptions) import Data.Char (isSpace) import Data.Function (on) import Data.Functor.Identity@@ -56,6 +58,8 @@     | Separator String  -- ^ A separator, e.g. whitespace     | Gloss String      -- ^ A gloss (in Brassica syntax, between square brackets)     deriving (Eq, Show, Functor, Foldable, Traversable, Generic, NFData)++$(deriveJSON defaultOptions ''Component)  -- | Flatten a nested list of 'Component's. joinComponents :: [Component [Component a]] -> [Component a]

@@ -33,7 +33,7 @@ --     * Each word is a sequence of t'Grapheme's -- -- For more details on the syntax and semantics of sound changes,--- refer to the [reference guide](https://github.com/bradrn/brassica/blob/v1.0.0/docs/Reference.md).+-- refer to the [reference guide](https://github.com/bradrn/brassica/blob/v1.1.0/docs/Reference.md). module Brassica.SoundChange.Types        (        -- * Words and graphemes@@ -121,7 +121,7 @@ -- to 'Matched' or 'Replacement' positions respectively. -- -- For details on the syntax and semantics of each kind of lexeme,--- refer to the [reference guide](https://github.com/bradrn/brassica/blob/v1.0.0/docs/Reference.md).+-- refer to the [reference guide](https://github.com/bradrn/brassica/blob/v1.1.0/docs/Reference.md). data Lexeme category (a :: LexemeType) where     Grapheme :: Grapheme -> Lexeme category a     Category :: category a -> Lexeme category a@@ -275,10 +275,12 @@ -- change how it is applied. data Flags = Flags   { highlightChanges :: Bool         -- ^ Whether results from this sound change can be highlighted in a GUI+  , highlightSpecificRule :: Bool     -- ^ Whether to highlight words changed by this rule in particular (when the appropriate option is set)   , applyDirection   :: Direction    -- ^ Direction in which to apply the rule   , applyOnceOnly    :: Bool         -- ^ Whether to apply the rule only once to a word   , sporadic         :: Sporadicity  -- ^ Whether the rule should be applied sporadically, and if so, how   , nonOverlappingTarget :: Bool     -- ^ Whether the rule should apply non-iteratively (avoiding environments which overlap with targets)+  , persistent       :: Maybe String -- ^ Whether to continue applying the rule persistently (with a label to disable the rule eventually)   } deriving (Show, Generic, NFData)  -- | A default selection of flags which are appropriate for most@@ -299,31 +301,35 @@ defFlags :: Flags defFlags = Flags     { highlightChanges = True+    , highlightSpecificRule = False     , applyDirection = LTR     , applyOnceOnly = False     , sporadic = ApplyAlways     , nonOverlappingTarget = False+    , persistent = Nothing     }  -- | A single sound change rule. -- -- In Brassica sound-change syntax with all elements specified, this would be--- @-flags target / replacement \/ environment1 \/ environment2 \/ … \/ exception@.+-- @-flags target / replacement \/ environment1 \/ environment2 \/ … \/\/ exception1 \/ exception2 \/ …@. data Rule c = Rule   { target      :: [Lexeme c 'Matched]   , replacement :: [Lexeme c 'Replacement]   , environment :: [Environment c]-  , exception   :: Maybe (Environment c)+  , exception   :: [Environment c]   , flags       :: Flags   , plaintext   :: String  -- ^ Rule text before parsing (displayed e.g. for debugging purposes)+  , loc         :: Int     -- ^ Line number of rule in original source file (1-indexed!)   } deriving (Generic)  deriving instance (forall a. Show (c a)) => Show (Rule c) deriving instance (forall a. NFData (c a)) => NFData (Rule c) --- | 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]+-- | A filter, constraining the output to not match the given+-- elements.  (The 'String' is the plaintext and the 'Int' is the line+-- number, as with 'Rule'.)+data Filter c = Filter String Int [Lexeme c 'Matched]     deriving (Generic)  deriving instance (forall a. Show (c a)) => Show (Filter c)@@ -350,7 +356,7 @@ -- @"\<declaration\>"@ for all 'DeclS' inputs. plaintext' :: Statement c decl -> String plaintext' (RuleS r) = plaintext r-plaintext' (FilterS (Filter p _)) = p+plaintext' (FilterS (Filter p _ _)) = p plaintext' ReportS = "intermediate result" plaintext' (DeclS _) = "<declaration>" @@ -412,11 +418,13 @@ -- something for later use. data Directive     = Categories  -- ^ Category definition block+        Int   -- ^ Line number         Bool  -- ^ Whether category was introduced with @new@         Bool  -- ^ Whether category was introduced with @noreplace@         [CategoryDefinition]     | ExtraGraphemes [String]       -- ^ Extra graphemes declaration: @extra …@+    | DisablePersistent String     deriving (Show, Eq, Ord, Generic, NFData)  -- | A list of graphemes, replacing v'Categories' in expanded sound

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