brassica 0.0.3 → 0.1.0

raw patch · 12 files changed

+413/−227 lines, 12 filesdep ~textPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: text

API changes (from Hackage documentation)

Files

• ChangeLog.md +11/−1
• LICENSE +1/−1
• README.md +5/−3
• brassica.cabal +6/−6
• cli/Main.hs +18/−15
• src/Brassica/MDF.hs +2/−2
• src/Brassica/Paradigm/Parse.hs +1/−1
• src/Brassica/SoundChange/Apply/Internal.hs +183/−95
• src/Brassica/SoundChange/Frontend/Internal.hs +44/−14
• src/Brassica/SoundChange/Parse.hs +67/−42
• src/Brassica/SoundChange/Tokenise.hs +29/−21
• src/Brassica/SoundChange/Types.hs +46/−26

@@ -1,1 +1,11 @@-# Changelog for brassica+# Brassica changelog++## Unreleased changes++- Allow category backreferencing with `@n` before category+- Allow forcing nondeterminism with `@?` before category+- Add ‘input→output’ format for output words+- Change default output format for MDF input to wordlist in CLI+- Add ‘or environments’ with syntax ‘target / replacement / env1 / env2 / env3 / …’.+  Former rule exceptions with similar syntax have been changed to syntax ‘target / replacement / env // exception’.+- Improve documentation

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

@@ -1,9 +1,11 @@ # Brassica +[![Hackage](https://img.shields.io/hackage/v/brassica.svg?logo=haskell)](https://hackage.haskell.org/package/brassica)+ Brassica is a new sound change applier. Its features include: -- Can be used interactively both [online](http://bradrn.com/brassica/index.html) and as a desktop application, or non-interactively in batch mode on the command-line or as a Haskell library+- Can be used interactively both [online](http://bradrn.com/brassica/index.html) and as a desktop application, or non-interactively in batch mode on the command-line or as a [Haskell library](https://hackage.haskell.org/package/brassica) - Natively supports the MDF dictionary format, also used by tools including [SIL Toolbox](https://software.sil.org/toolbox/) and [Lexique Pro](https://software.sil.org/lexiquepro/) - First-class support for multigraphs - Easy control over rule application: apply sound changes sporadically, right-to-left, and in many more ways@@ -19,7 +21,7 @@  Download Brassica from the [releases page](https://github.com/bradrn/brassica/releases/latest). Alternately, try it online at http://bradrn.com/brassica.-As of the time of writing prebuilt binaries exist only for Windows.+As of the time of writing prebuilt binaries exist for Windows and Linux. Instructions for building from source are available at [`BUILDING.md`](./BUILDING.md). -![Image of Brassica with some example sound changes](https://raw.githubusercontent.com/bradrn/brassica/v0.0.3/gui-interface-example.png)+![Image of Brassica with some example sound changes](https://raw.githubusercontent.com/bradrn/brassica/v0.1.0/gui-interface-example.png)

@@ -1,6 +1,6 @@ cabal-version:      2.0 name:               brassica-version:            0.0.3+version:            0.1.0 synopsis:           Featureful sound change applier description:   The Brassica library for the simulation of sound changes in historical linguistics and language construction.@@ -44,7 +44,7 @@                    base >=4.7 && <5                  , containers >=0.6 && <0.7                  , deepseq >=1.4 && <1.5-                 , megaparsec >=8.0 && <8.1+                 , megaparsec >=8.0 && <9.3                  , mtl >=2.2 && <2.3                  , parser-combinators >=1.2 && <1.3                  , split >=0.2 && <0.3@@ -59,10 +59,10 @@   build-depends:                     base >=4.7 && <5                   , brassica-                  , bytestring ^>=0.10+                  , bytestring >=0.10 && <0.12                   , conduit ^>=1.3                   , optparse-applicative ^>=0.17-                  , text ^>=1.2+                  , text >=1.2 && <2.1    default-language: Haskell2010 @@ -102,8 +102,8 @@                   , brassica                   , tasty ^>=1.4                   , tasty-golden ^>=2.3-                  , bytestring ^>=0.10-                  , text ^>=1.2+                  , bytestring+                  , text >=1.2 && <2.1                   , transformers ^>=0.5                   , conduit ^>=1.3                   , utf8-string ^>=1.0

@@ -7,14 +7,13 @@  import Conduit import qualified Data.ByteString as B-import Data.Text (pack, unpack, Text)+import Data.Text (pack, unpack, snoc, Text) import Data.Text.Encoding (decodeUtf8) import Options.Applicative  import Brassica.SoundChange import Brassica.SoundChange.Frontend.Internal - main :: IO () main = do     Options{..} <- execParser opts@@ -28,7 +27,7 @@             withSinkFileIf outWordsFile $ \outC ->             runConduit $                 inC-                .| processWords (incrFor wordsFormat) rules wordsFormat tokMode outMode+                .| processWords (incrFor wordsFormat) rules wordsFormat outMode                 .| outC    where@@ -39,13 +38,20 @@             (metavar "RULES" <> help "File containing sound changes")         <*> flag Raw MDF             (long "mdf" <> help "Parse input words in MDF format")-        <*> flag Normal AddEtymons-            (long "etymons" <> help "With --mdf, add etymologies to output")-        <*> (flag' ReportRulesApplied+        <*> asum+            [ flag' ReportRulesApplied                 (long "report" <> help "Report rules applied rather than outputting words")-            <|>-            flag (ApplyRules NoHighlight MDFOutput) (ApplyRules NoHighlight WordsOnlyOutput)-                (long "wordlist" <> help "With --mdf, output only a list of the derived words"))+            , flag' (ApplyRules NoHighlight MDFOutput)+                (long "mdf-out" <> help "With --mdf, output MDF dictionary")+            , flag' (ApplyRules NoHighlight MDFOutputWithEtymons)+                (long "etymons" <> help "With --mdf, output MDF dictionary with etymologies")+            , flag' (ApplyRules NoHighlight WordsWithProtoOutput)+                (long "show-input" <> help "Output an input→output wordlist")+            , flag+                (ApplyRules NoHighlight WordsOnlyOutput)+                (ApplyRules NoHighlight WordsOnlyOutput)+                (long "wordlist" <> help "Output only a list of the derived words (default)")+            ]         <*> optional (strOption             (long "in" <> short 'i' <> help "File containing input words (if not specified will read from stdin)"))         <*> optional (strOption@@ -63,7 +69,6 @@ data Options = Options     { rulesFile :: String     , wordsFormat :: InputLexiconFormat-    , tokMode :: TokenisationMode     , outMode :: ApplicationMode     , inWordsFile :: Maybe String     , outWordsFile :: Maybe String@@ -74,18 +79,16 @@     => Bool  -- split into lines?     -> SoundChanges     -> InputLexiconFormat-    -> TokenisationMode     -> ApplicationMode     -> ConduitT B.ByteString B.ByteString m ()-processWords incr rules wordsFormat tokMode outMode =+processWords incr rules wordsFormat outMode =     decodeUtf8C     .| (if incr then linesUnboundedC else mapC id)-    .| mapC (processApplicationOutput . evolve . unpack)+    .| mapC (processApplicationOutput . evolve . unpack . (`snoc` '\n'))     .| throwOnLeft-    .| (if incr then unlinesC else mapC id)     .| encodeUtf8C   where-    evolve ws = parseTokeniseAndApplyRules rules ws wordsFormat tokMode outMode Nothing+    evolve ws = parseTokeniseAndApplyRules rules ws wordsFormat outMode Nothing      throwOnLeft :: (MonadThrow m, Exception e) => ConduitT (Either e r) r m ()     throwOnLeft = awaitForever $ \case

@@ -34,7 +34,7 @@ import Text.Megaparsec.Char
 
 import Brassica.SoundChange.Tokenise
-import Brassica.SoundChange.Types (Grapheme, PWord)
+import Brassica.SoundChange.Types (PWord)
 import Data.Maybe (fromMaybe)
 
 -- | An MDF (Multi-Dictionary Formatter) file, represented as a list
@@ -89,7 +89,7 @@ -- | Parse an MDF file to an 'MDF', parsing the 'Vernacular' fields
 -- into 'Component's in the process.
 parseMDFWithTokenisation
-    :: [Grapheme]
+    :: [String]
     -> String
     -> Either (ParseErrorBundle String Void) (MDF [Component PWord])
 parseMDFWithTokenisation (sortByDescendingLength -> gs) =

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

@@ -31,6 +31,7 @@        -- * Lexeme matching
        , match
        , matchMany
+       , matchMany'
        , mkReplacement
        , exceptionAppliesAtPoint
        , matchRuleAtPoint
@@ -55,6 +56,7 @@        ) where
 
 import Control.Applicative ((<|>))
+import Control.Category ((>>>))
 import Data.Containers.ListUtils (nubOrd)
 import Data.Function ((&))
 import Data.Functor ((<&>))
@@ -120,8 +122,8 @@ modifyMatchedGraphemes :: ([Grapheme] -> [Grapheme]) -> MatchOutput -> MatchOutput
 modifyMatchedGraphemes f MatchOutput{..} = MatchOutput{matchedGraphemes=f matchedGraphemes, ..}
 
-prependGrapheme :: Grapheme -> MatchOutput -> MatchOutput
-prependGrapheme g = modifyMatchedGraphemes (g:)
+appendGrapheme :: MatchOutput -> Grapheme -> MatchOutput
+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)
@@ -130,40 +132,47 @@ -- 'MultiZipper' past the match. For each match found, returns the
 -- 'MatchOutput' tupled with the updated 'MultiZipper'.
 match :: OneOf a 'Target 'Env
-      => Maybe Grapheme       -- ^ The previously-matched grapheme, if any. (Used to match a 'Geminate'.)
+      => MatchOutput          -- ^ The previous 'MatchOutput'
+      -> Maybe Grapheme       -- ^ The previously-matched grapheme, if any. (Used to match a 'Geminate'.)
       -> Lexeme a             -- ^ The lexeme to match.
       -> MultiZipper t Grapheme   -- ^ The 'MultiZipper' to match against.
       -> [(MatchOutput, MultiZipper t Grapheme)]
-      -- ^ The output: a tuple @((i, g), mz)@ as described below.
-match prev (Optional l) mz =
-    (MatchOutput [] [False] [], mz) :
-    (first (MatchOutput [] [True] [] <>) <$> matchMany prev l mz )
-match prev w@(Wildcard l) mz = case match prev l mz of
-    [] -> maybeToList (consume mz) >>= \(g, mz') ->
-        first (prependGrapheme g) <$> match prev w mz'
+      -- ^ 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 prev k@(Kleene l) mz = case match prev l mz of
+match out prev k@(Kleene l) mz = case match out prev l mz of
     [] -> [(MatchOutput [] [] [], mz)]
-    r -> r >>= \(out, mz') -> case match prev k mz' of
+    r -> r >>= \(out', mz') -> case match out' prev k mz' of
         [] -> error "match: Kleene should never fail"
-        r' -> first (out <>) <$> r'
-match _ (Grapheme g) mz = (MatchOutput [] [] [g],) <$> maybeToList (matchGrapheme g mz)
-match _ (Category gs) mz =
+        r' -> r'
+match out _ (Grapheme g) mz = (out <> MatchOutput [] [] [g],) <$> maybeToList (matchGrapheme g mz)
+match out _ (Category gs) mz =
     gs
     -- Attempt to match each option in category...
-    & fmap (\case
-               BoundaryEl -> if atBoundary mz then Just ([], mz) else Nothing
-               GraphemeEl g -> ([g],) <$> matchGrapheme g mz)
+    & fmap (matchCategoryEl mz)
     -- ...get the index of each match...
     & zipWith (\i m -> fmap (i,) m) [0..]
     -- ...and take all matches
     & (>>= maybeToList)
-    & fmap (\(i, (g, mz')) -> (MatchOutput [i] [] g, mz'))
-match _ Boundary mz = if atBoundary mz then [(MatchOutput [] [] [], mz)] else []
-match prev Geminate mz = case prev of
+    & fmap (\(i, (g, mz')) -> (out <> MatchOutput [i] [] g, mz'))
+match out prev Geminate mz = case prev of
     Nothing -> []
-    Just prev' -> (MatchOutput [] [] [prev'],) <$> maybeToList (matchGrapheme prev' mz)
+    Just prev' -> (out <> MatchOutput [] [] [prev'],) <$> maybeToList (matchGrapheme prev' mz)
+match out _prev (Backreference i gs) mz = maybeToList $ do
+    catIx <- matchedCatIxs out !? (i-1)
+    g <- gs !? catIx
+    (matched, mz') <- matchCategoryEl mz g
+    pure (modifyMatchedGraphemes (++matched) out, mz')
 
+matchCategoryEl :: MultiZipper t Grapheme -> Grapheme -> Maybe ([Grapheme], MultiZipper t Grapheme)
+matchCategoryEl mz g = ([g],) <$> matchGrapheme g mz
+
 matchGrapheme :: Grapheme -> MultiZipper t Grapheme -> Maybe (MultiZipper t Grapheme)
 matchGrapheme g = matchGraphemeP (==g)
 
@@ -175,20 +184,61 @@ -- 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
+          -> Maybe Grapheme
+          -> [Lexeme a]
+          -> MultiZipper t Grapheme
+          -> [(MatchOutput, MultiZipper t Grapheme)]
+matchMany out _ [] mz = [(out, mz)]
+matchMany out prev (l:ls) mz =
+    match out prev l mz >>= \(out', mz') ->
+    matchMany  out' (lastMay (matchedGraphemes out') <|> prev) ls mz'
+
+-- | 'matchMany' without any previous match output.
+matchMany' :: OneOf a 'Target 'Env
           => Maybe Grapheme
           -> [Lexeme a]
           -> MultiZipper t Grapheme
           -> [(MatchOutput, MultiZipper t Grapheme)]
-matchMany = go (MatchOutput [] [] [])
-  where
-    go out _ [] mz = [(out, mz)]
-    go out prev (l:ls) mz = match prev l mz >>= \(out', mz') ->
-        go (out <> out') (lastMay (matchedGraphemes out') <|> prev) ls mz'
+matchMany' = matchMany (MatchOutput [] [] [])
 
 -- Small utility function, not exported
 lastMay :: [a] -> Maybe a
 lastMay l = if null l then Nothing else Just (last l)
 
+data ReplacementIndices = ReplacementIndices
+    { ixInCategories :: Int
+    , ixInOptionals :: Int
+    , forcedCategory :: Maybe CategoryNumber
+    } deriving (Show)
+
+data CategoryNumber = CategoryNumber Int | Nondeterministic
+    deriving (Show)
+
+advanceCategory :: ReplacementIndices -> Int -> (CategoryNumber, ReplacementIndices)
+advanceCategory ix cslen =
+    case forcedCategory ix of
+        Just i -> (i, ix { forcedCategory = Nothing })
+        Nothing ->
+            let i = ixInCategories ix in
+                ( if i < cslen then CategoryNumber i else Nondeterministic
+                , ix { ixInCategories = i+1 }
+                )
+
+advanceOptional :: ReplacementIndices -> (Int, ReplacementIndices)
+advanceOptional ix =
+    let i = ixInOptionals ix
+    in (i, ix { ixInOptionals = i+1 })
+
+forceCategory :: CategoryNumber -> ReplacementIndices -> ReplacementIndices
+forceCategory i ixs = ixs { forcedCategory = Just i }
+
+-- | Partially safe list indexing
+(!?) :: [a] -> Int -> Maybe a
+(x:_ ) !? 0 = Just x
+(_:xs) !? n = xs !? (n-1)
+[]     !? _ = Nothing
+
 -- | Given a list of 'Lexeme's specifying a replacement, generate all
 -- possible replacements and apply them to the given input.
 mkReplacement
@@ -196,39 +246,59 @@     -> [Lexeme 'Replacement]    -- ^ The 'Lexeme's specifying the replacement.
     -> MultiZipper t Grapheme
     -> [MultiZipper t Grapheme]
-mkReplacement = \out ls -> fmap (fst . snd) . go out ls . (,Nothing)
+mkReplacement out = \ls -> fmap (fst . snd) . go startIxs ls . (,Nothing)
   where
-    go out []     (mz, prev) = [(out, (mz, prev))]
-    go out (l:ls) (mz, prev) = do
-        (out', (mz', prev')) <- replaceLex out l mz prev
-        go out' ls (mz', prev')
+    startIxs = ReplacementIndices 0 0 Nothing
 
+    go
+        :: ReplacementIndices
+        -> [Lexeme 'Replacement]
+        -> (MultiZipper t Grapheme, Maybe Grapheme)
+        -> [(ReplacementIndices, (MultiZipper t Grapheme, Maybe Grapheme))]
+    go ixs []     (mz, prev) = [(ixs, (mz, prev))]
+    go ixs (l:ls) (mz, prev) = do
+        (ixs', (mz', prev')) <- replaceLex ixs l mz prev
+        go ixs' ls (mz', prev')
+
+    numCatsMatched = length $ matchedCatIxs out
+
     replaceLex
-        :: MatchOutput
+        :: ReplacementIndices
         -> Lexeme 'Replacement
         -> MultiZipper t Grapheme
         -> Maybe Grapheme
-        -> [(MatchOutput, (MultiZipper t Grapheme, Maybe Grapheme))]
-    replaceLex out (Grapheme g) mz _prev = [(out, (insert g mz, Just g))]
-    replaceLex out@MatchOutput{matchedCatIxs=(i:is)} (Category gs) mz _prev =
-        fmap (out{matchedCatIxs=is},) $
-            if i < length gs
-            then case gs !! i of GraphemeEl g -> [(insert g mz, Just g)]
-            else [(insert "\xfffd" mz, Nothing)]  -- Unicode replacement character
-    replaceLex out (Category gs) mz _prev =
-        gs <&> \(GraphemeEl g) -> (out, (insert g mz, Just g))
-    replaceLex MatchOutput{matchedOptionals=(o:os), ..} (Optional ls) mz prev =
-        let out' = MatchOutput{matchedOptionals=os, ..}
-        in if o
-           then go out' ls (mz, prev)
-           else [(out', (mz, Nothing))]
-    replaceLex out (Optional ls) mz prev = (out, (mz, Nothing)) : go out ls (mz, prev)
-    replaceLex out@MatchOutput{matchedGraphemes}     Metathesis  mz _prev =
-        [(out, (flip insertMany mz $ reverse matchedGraphemes, listToMaybe matchedGraphemes))]
-    replaceLex out                                   Geminate    mz prev =
-        [(out, (flip insertMany mz $ maybeToList prev, prev))]
-    replaceLex out@MatchOutput{matchedCatIxs=(_:is)} Discard mz prev = [(out{matchedCatIxs=is}, (mz, prev))]
-    replaceLex out@MatchOutput{matchedCatIxs=[]} Discard mz prev = [(out, (mz, prev))]
+        -> [(ReplacementIndices, (MultiZipper t Grapheme, Maybe Grapheme))]
+    replaceLex ixs (Grapheme g) mz _prev = [(ixs, (insert g mz, Just g))]
+    replaceLex ixs (Category gs) mz _prev =
+        case advanceCategory ixs numCatsMatched of
+            (CategoryNumber ci, ixs') ->
+                let i = matchedCatIxs out !! ci in
+                    case gs !? i of
+                        Just g   -> [(ixs', (insert g mz, Just g))]
+                        Nothing  -> [(ixs', (insert (GMulti "\xfffd") mz, Nothing))]  -- Unicode replacement character
+            (Nondeterministic, ixs') -> gs <&> \g -> (ixs', (insert g mz, Just g))
+    replaceLex ixs (Optional ls) mz prev =
+        let (co, ixs') = advanceOptional ixs in
+            case matchedOptionals out !? co of
+                Just True -> go ixs' ls (mz, prev)
+                Just False -> [(ixs', (mz, Nothing))]
+                Nothing    ->  (ixs', (mz, Nothing)) : go ixs ls (mz, prev)
+    replaceLex ixs Metathesis mz _prev =
+        [( ixs
+         , ( flip insertMany mz $ reverse $ matchedGraphemes out
+           , listToMaybe $ matchedGraphemes out)
+         )]
+    replaceLex ixs Geminate mz prev =
+        [(ixs, (flip insertMany mz $ maybeToList prev, prev))]
+    replaceLex ixs Discard mz prev =
+        let (_, ixs') = advanceCategory ixs numCatsMatched
+        in [(ixs', (mz, prev))]
+    replaceLex ixs (Backreference i c) mz prev =
+        let ixs' = forceCategory (CategoryNumber $ i-1) ixs -- 1-based indexing!
+        in replaceLex ixs' (Category c) mz prev
+    replaceLex ixs (Multiple c) mz prev =
+        let ixs' = forceCategory Nondeterministic ixs
+        in replaceLex ixs' (Category c) mz prev
 
 -- | Given a 'Rule' and a 'MultiZipper', determines whether the
 -- 'exception' of that rule (if any) applies starting at the current
@@ -236,55 +306,66 @@ -- first element of each matching 'target'.
 exceptionAppliesAtPoint :: [Lexeme 'Target] -> Environment -> MultiZipper RuleTag Grapheme -> [Int]
 exceptionAppliesAtPoint target (ex1, ex2) mz = fmap fst $ flip runRuleAp mz $ do
-    _ <- RuleAp $ matchMany Nothing ex1
+    _ <- RuleAp $ matchMany' Nothing ex1
     pos <- gets curPos
-    MatchOutput{matchedGraphemes} <- RuleAp $ matchMany Nothing target
-    _ <- RuleAp $ matchMany (listToMaybe matchedGraphemes) ex2
+    MatchOutput{matchedGraphemes} <- RuleAp $ matchMany' Nothing target
+    _ <- RuleAp $ matchMany' (listToMaybe matchedGraphemes) ex2
     return pos
 
--- | Given a 'Rule', determine if that rule matches. If so, for each
--- match, set the appropriate 'RuleTag's and return a tuple of @(is,
--- gs)@, where @gs@ is a list of matched t'Grapheme's, and @is@ is a
--- list of indices, one for each 'Category' lexeme matched.
+-- | Given a target and environment, determine if they rule
+-- matches. If so, for each match, set the appropriate 'RuleTag's and
+-- return a tuple of @(is, gs)@, where @gs@ is a list of matched
+-- t'Grapheme's, and @is@ is a list of indices, one for each
+-- 'Category' lexeme matched.
 matchRuleAtPoint
-    :: Rule
+    :: [Lexeme 'Target]
+    -> Environment
     -> MultiZipper RuleTag Grapheme
     -> [(MatchOutput, MultiZipper RuleTag Grapheme)]
-matchRuleAtPoint Rule{environment = (env1, env2), ..} mz = flip runRuleAp mz $ do
-    _ <- RuleAp $ matchMany Nothing env1
-    modify $ tag TargetStart
-    matchResult <- RuleAp $ matchMany Nothing target
-    modify $ tag TargetEnd
-    _ <- RuleAp $ matchMany (listToMaybe $ matchedGraphemes matchResult) env2
-    return matchResult
+matchRuleAtPoint target (env1,env2) mz = flip runRuleAp mz $ do
+    _ <- RuleAp $ matchMany' Nothing env1
+    -- start of target needs to be INSIDE 'MultiZipper'!
+    -- otherwise get weird things like /x/#_ resulting in
+    -- #abc#→#xabd#x when it should be #abc#→#xabc#
+    gets atBoundary >>= \case
+        True -> RuleAp $ const []
+        False -> do
+            modify $ tag TargetStart
+            matchResult <- RuleAp $ matchMany' Nothing target
+            modify $ tag TargetEnd
+            _ <- RuleAp $ matchMany' (listToMaybe $ matchedGraphemes matchResult) env2
+            return matchResult
 
 -- | Given a 'Rule', determine if the rule matches at the current
 -- point; if so, apply the rule, adding appropriate tags.
 applyOnce :: Rule -> StateT (MultiZipper RuleTag Grapheme) [] Bool
-applyOnce r@Rule{target, replacement, exception} = do
-    modify $ tag AppStart
-    result <- try (matchRuleAtPoint r)
-    case result of
-        Just out -> do
-            exs <- case exception of
-                Nothing -> pure []
-                Just ex -> gets $ join . toList .
-                    extend' (exceptionAppliesAtPoint target ex)
-            gets (locationOf TargetStart) >>= \p ->
-                if maybe True (`elem` exs) p
-                then return False
-                else do
-                    modifyMay $ modifyBetween (TargetStart, TargetEnd) $ const []
-                    modifyMay $ seek TargetStart
-                    modifyM $ mkReplacement out replacement
-                    return True
-        Nothing -> return False
+applyOnce r@Rule{target, replacement, exception} =
+    modify (tag AppStart) >> go (environment r)
+  where
+    go [] = return False
+    go (env:envs) = do
+        result <- try (matchRuleAtPoint target env)
+        case result of
+            Just out -> do
+                exs <- case exception of
+                    Nothing -> pure []
+                    Just ex -> gets $ join . toList .
+                        extend' (exceptionAppliesAtPoint target ex)
+                gets (locationOf TargetStart) >>= \p ->
+                    if maybe True (`elem` exs) p
+                    then return False
+                    else do
+                        modifyMay $ modifyBetween (TargetStart, TargetEnd) $ const []
+                        modifyMay $ seek TargetStart
+                        modifyM $ mkReplacement out replacement
+                        return True
+            Nothing -> modifyMay (seek AppStart) >> go envs
 
 -- | Remove tags and advance the current index to the next t'Grapheme'
 -- after the rule application.
 setupForNextApplication :: Bool -> Rule -> MultiZipper RuleTag Grapheme -> Maybe (MultiZipper RuleTag Grapheme)
-setupForNextApplication success r@Rule{flags=Flags{applyDirection}} = fmap untag .
-    case applyDirection of
+setupForNextApplication success r@Rule{flags=Flags{applyDirection}} =
+    fmap untag . case applyDirection of
         RTL -> seek AppStart >=> bwd
         LTR ->
             if success
@@ -323,7 +404,9 @@ -- the given 'CategoriesDecl', replacing all unlisted graphemes with
 -- U+FFFD.
 checkGraphemes :: CategoriesDecl -> MultiZipper RuleTag Grapheme -> MultiZipper RuleTag Grapheme
-checkGraphemes (CategoriesDecl gs) = fmap $ \g -> if g `elem` gs then g else "\xfffd"
+checkGraphemes (CategoriesDecl gs) = fmap $ \case
+    GBoundary -> GBoundary
+    g -> if g `elem` gs then g else GMulti "\xfffd"
 
 -- | Apply a 'Statement' to a 'MultiZipper'. This is a simple wrapper
 -- around 'applyRule' and 'checkGraphemes'.
@@ -346,7 +429,12 @@ -- are removed. To keep duplicates, use the lower-level internal
 -- function 'applyStatement' directly.
 applyStatementStr :: Statement -> PWord -> [PWord]
-applyStatementStr st s = nubOrd $ fmap toList $ applyStatement st $ fromListStart s
+applyStatementStr st =
+    addBoundaries
+    >>> fromListStart
+    >>> applyStatement st
+    >>> fmap (toList >>> removeBoundaries)
+    >>> nubOrd
 
 -- | A log item representing a single application of an action. (In
 -- practise this will usually be a 'Statement'.) Specifies the action
@@ -390,12 +478,12 @@ -- +------+---+-------+-------------+ 
 
 reportAsHtmlRows :: (r -> String) -> PWordLog r -> String
-reportAsHtmlRows render item = go (concat $ initialWord item) (derivations item)
+reportAsHtmlRows render item = go (concatWithBoundary $ initialWord item) (derivations item)
   where
     go _ [] = ""
     go cell1 ((output, action) : ds) =
         ("<tr><td>" ++ cell1 ++ "</td><td>&rarr;</td><td>"
-         ++ concat output
+         ++ concatWithBoundary output
          ++ "</td><td>(" ++ render action ++ ")</td></tr>")
         ++ go "" ds
 
@@ -416,10 +504,10 @@ -- >   -> tazh   (V / / _ #)
 reportAsText :: (r -> String) -> PWordLog r -> String
 reportAsText render item = unlines $
-    concat (initialWord item) : fmap toLine (alignWithPadding $ derivations item)
+    concatWithBoundary (initialWord item) : fmap toLine (alignWithPadding $ derivations item)
   where
     alignWithPadding ds =
-        let (fmap concat -> outputs, actions) = unzip ds
+        let (fmap concatWithBoundary -> outputs, actions) = unzip ds
             maxlen = maximum $ length <$> outputs
             padded = outputs <&> \o -> o ++ replicate (maxlen - length o) ' '
         in zip padded actions

@@ -26,7 +26,7 @@ 
 -- | Rule application mode of the SCA.
 data ApplicationMode
-    = ApplyRules HighlightMode MDFOutputMode
+    = ApplyRules HighlightMode OutputMode
     | ReportRulesApplied
     deriving (Show, Eq)
 
@@ -46,15 +46,23 @@     toEnum 2 = DifferentToInput
     toEnum _ = undefined
 
-data MDFOutputMode = MDFOutput | WordsOnlyOutput
+data OutputMode
+    = MDFOutput
+    | WordsOnlyOutput
+    | MDFOutputWithEtymons
+    | WordsWithProtoOutput
     deriving (Show, Eq)
-instance Enum MDFOutputMode where
+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
 
     toEnum 0 = MDFOutput
     toEnum 1 = WordsOnlyOutput
+    toEnum 2 = MDFOutputWithEtymons
+    toEnum 3 = WordsWithProtoOutput
     toEnum _ = undefined
 
 data TokenisationMode = Normal | AddEtymons
@@ -68,6 +76,10 @@     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.
@@ -92,11 +104,21 @@ data ParseOutput a = ParsedRaw [Component a] | ParsedMDF (MDF [Component a])
     deriving (Show, Functor)
 
-componentise :: MDFOutputMode -> ParseOutput a -> [Component a]
-componentise _               (ParsedRaw cs) = cs
-componentise MDFOutput       (ParsedMDF mdf) = componentiseMDF mdf
-componentise WordsOnlyOutput (ParsedMDF mdf) = componentiseMDFWordsOnly mdf
+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
 
+intersperseWords :: [a] -> [Component a] -> [Component a]
+intersperseWords (w:ws) (Word c:cs) =
+    Word w : Separator " → " : Word c : Separator "\n" : intersperseWords ws cs
+intersperseWords ws (_:cs) = intersperseWords ws cs
+intersperseWords [] cs = cs
+intersperseWords _ [] = []
+
 tokeniseAccordingToInputFormat
     :: InputLexiconFormat
     -> TokenisationMode
@@ -112,6 +134,10 @@     . second (duplicateEtymologies $ ('*':) . detokeniseWords)
     . withFirstCategoriesDecl parseMDFWithTokenisation cs
 
+getParsedWords :: ParseOutput a -> [a]
+getParsedWords (ParsedRaw cs) = getWords cs
+getParsedWords (ParsedMDF mdf) = getWords $ componentiseMDF mdf
+
 -- | 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.
@@ -119,30 +145,34 @@     :: SoundChanges -- ^ changes
     -> String       -- ^ words
     -> InputLexiconFormat
-    -> TokenisationMode
     -> ApplicationMode
     -> Maybe [Component PWord]  -- ^ previous results
     -> ApplicationOutput PWord Statement
-parseTokeniseAndApplyRules statements ws intype tmode mode prev =
+parseTokeniseAndApplyRules statements ws intype mode prev =
+    let tmode = tokenisationModeFor mode in
     case tokeniseAccordingToInputFormat intype tmode statements ws of
         Left e -> ParseError e
-        Right toks -> case mode of
+        Right toks
+          | ws' <- getParsedWords toks
+          -> case mode of
             ReportRulesApplied ->
                 AppliedRulesTable $ mapMaybe toPWordLog $ concat $
-                    getWords $ componentise WordsOnlyOutput $
+                    getWords $ componentise WordsOnlyOutput [] $
                         applyChangesWithLog statements <$> toks
             ApplyRules DifferentToLastRun mdfout ->
                 let result = concatMap (splitMultipleResults " ") $
-                      componentise mdfout $ applyChanges statements <$> toks
+                      componentise mdfout (fmap pure ws') $ applyChanges statements <$> toks
                 in HighlightedWords $
                     zipWithComponents result (fromMaybe [] prev) [] $ \thisWord prevWord ->
                         (thisWord, thisWord /= prevWord)
             ApplyRules DifferentToInput mdfout ->
                 HighlightedWords $ concatMap (splitMultipleResults " ") $
-                    componentise mdfout $ applyChangesWithChanges statements <$> toks
+                    componentise mdfout (fmap (pure . (,False)) ws') $
+                        applyChangesWithChanges statements <$> toks
             ApplyRules NoHighlight mdfout ->
                 HighlightedWords $ (fmap.fmap) (,False) $ concatMap (splitMultipleResults " ") $
-                    componentise mdfout $ applyChanges statements <$> toks
+                    componentise mdfout (fmap pure ws') $
+                        applyChanges statements <$> toks
   where
     -- Zips two tokenised input strings. Compared to normal 'zipWith'
     -- this has two special properties:

@@ -1,7 +1,9 @@ {-# LANGUAGE DataKinds        #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures   #-}+{-# LANGUAGE LambdaCase       #-} {-# LANGUAGE RecordWildCards  #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}  module Brassica.SoundChange.Parse@@ -36,7 +38,6 @@  class ParseLexeme (a :: LexemeType) where     parseLexeme :: Parser (Lexeme a)-    parseCategoryElement :: Parser (CategoryElement a)  -- space consumer which does not match newlines sc :: Parser ()@@ -57,18 +58,30 @@ symbol = L.symbol sc  keyChars :: [Char]-keyChars = "#[](){}>\\→/_^%~*"+keyChars = "#[](){}>\\→/_^%~*@" +nonzero :: Parser Int+nonzero = label "nonzero postive number" $ try $ do+    n <- lexeme L.decimal+    guard $ n>0+    pure n+ parseGrapheme :: Parser (Grapheme, Bool)-parseGrapheme = lexeme $ (,) <$> takeWhile1P Nothing (not . ((||) <$> isSpace <*> (`elem` keyChars))) <*> (isJust <$> optional (char '~'))+parseGrapheme = lexeme $ parseBoundary <|> parseMulti+  where+    parseBoundary = (GBoundary,False) <$ char '#' +    parseMulti = (,)+        <$> fmap GMulti (takeWhile1P Nothing (not . ((||) <$> isSpace <*> (`elem` keyChars))))+        <*> (isJust <$> optional (char '~'))+ parseGrapheme' :: Parser Grapheme-parseGrapheme' = lexeme $ takeWhile1P Nothing (not . ((||) <$> isSpace <*> (=='=')))+parseGrapheme' = lexeme $ GMulti <$> takeWhile1P Nothing (not . ((||) <$> isSpace <*> (=='='))) -data CategoryModification a-    = Union     (CategoryElement a)-    | Intersect (CategoryElement a)-    | Subtract  (CategoryElement a)+data CategoryModification+    = Union     Grapheme+    | Intersect Grapheme+    | Subtract  Grapheme  parseGraphemeOrCategory :: ParseLexeme a => Parser (Lexeme a) parseGraphemeOrCategory = do@@ -79,26 +92,26 @@             cats <- gets categories             return $ case C.lookup g cats of                 Nothing -> Grapheme g-                Just c  -> Category $ C.bake $ GraphemeEl <$> c+                Just c  -> Category $ C.bake c  parseCategory :: ParseLexeme a => Parser (Lexeme a)-parseCategory = do+parseCategory = Category <$> parseCategory'++parseCategory' :: Parser [Grapheme]+parseCategory' = do     mods <- symbol "[" *> someTill parseCategoryModification (symbol "]")     cats <- gets categories-    return $ Category $ C.bake $-        C.expand (C.mapCategories GraphemeEl cats) (toCategory mods)+    return $ C.bake $+        C.expand cats (toCategory mods)  parseCategoryStandalone :: Parser (Grapheme, C.Category 'C.Expanded Grapheme) parseCategoryStandalone = do     g <- parseGrapheme'     _ <- symbol "="     -- Use Target here because it only allows graphemes, not boundaries-    mods <- some (parseCategoryModification @'Target)+    mods <- some parseCategoryModification     cats <- gets categories-    return (g, C.expand cats $ toGrapheme <$> toCategory mods)--toGrapheme :: CategoryElement 'Target -> Grapheme-toGrapheme (GraphemeEl g) = g+    return (g, C.expand cats $ toCategory mods)  categoriesDeclParse :: Parser CategoriesDecl categoriesDeclParse = do@@ -115,9 +128,9 @@     parseFeature = do         _ <- symbol "feature"         namePlain <- optional $ try $ parseGrapheme' <* symbol "="-        modsPlain <- some (parseCategoryModification @'Target)+        modsPlain <- some parseCategoryModification         cats <- gets categories-        let plainCat = C.expand cats $ toGrapheme <$> toCategory modsPlain+        let plainCat = C.expand cats $ toCategory modsPlain             plain = C.bake plainCat         modifiedCats <- some (symbol "/" *> parseCategoryStandalone) <* scn         let modified = C.bake . snd <$> modifiedCats@@ -134,15 +147,15 @@         (k, c) <- try parseCategoryStandalone <* scn         modify $ \(Config cs) -> Config (M.insert k c cs) -parseCategoryModification :: ParseLexeme a => Parser (CategoryModification a)-parseCategoryModification = parsePrefix <*> parseCategoryElement+parseCategoryModification :: Parser CategoryModification+parseCategoryModification = parsePrefix <*> (fst <$> parseGrapheme)   where     parsePrefix =         (Intersect <$ char '+')         <|> (Subtract <$ char '-')         <|> pure Union -toCategory :: [CategoryModification a] -> C.Category 'C.Unexpanded (CategoryElement a)+toCategory :: [CategoryModification] -> C.Category 'C.Unexpanded Grapheme toCategory = go C.Empty   where     go c [] = c@@ -162,24 +175,39 @@ parseWildcard :: (ParseLexeme a, OneOf a 'Target 'Env) => Parser (Lexeme a) parseWildcard = Wildcard <$> (symbol "^" *> parseLexeme) -parseBoundary :: Parser ()-parseBoundary = () <$ symbol "#"- parseDiscard :: Parser (Lexeme 'Replacement) parseDiscard = Discard <$ symbol "~"  parseKleene :: OneOf a 'Target 'Env => Lexeme a -> Parser (Lexeme a) parseKleene l = (Kleene l <$ symbol "*") <|> pure l +parseMultiple :: Parser (Lexeme 'Replacement)+parseMultiple = Multiple <$> (symbol "@?" *> parseCategory')++parseBackreference+    :: forall a.+       (OneOf a 'Target 'Replacement, ParseLexeme a)+    => Parser (Lexeme a)+parseBackreference =+    Backreference+    <$> (symbol "@" *> nonzero)+    <*> (parseCategory' <|> parseGraphemeCategory)+  where+    parseGraphemeCategory :: Parser [Grapheme]+    parseGraphemeCategory = label "category" $ try $+        (parseGraphemeOrCategory @a) >>= \case+            Category gs -> pure gs+            _ -> empty+ instance ParseLexeme 'Target where     parseLexeme = asum         [ parseCategory         , parseOptional         , parseGeminate         , parseWildcard+        , parseBackreference         , parseGraphemeOrCategory         ] >>= parseKleene-    parseCategoryElement = GraphemeEl . fst <$> parseGrapheme  instance ParseLexeme 'Replacement where     parseLexeme = asum@@ -188,23 +216,19 @@         , parseMetathesis         , parseDiscard         , parseGeminate+        , parseMultiple+        , parseBackreference         , parseGraphemeOrCategory         ]-    parseCategoryElement = GraphemeEl . fst <$> parseGrapheme  instance ParseLexeme 'Env where     parseLexeme = asum         [ parseCategory-        , Boundary <$ parseBoundary         , parseOptional         , parseGeminate         , parseWildcard         , parseGraphemeOrCategory         ] >>= parseKleene-    parseCategoryElement = asum-        [ BoundaryEl <$ parseBoundary-        , GraphemeEl . fst <$> parseGrapheme-        ]  parseLexemes :: ParseLexeme a => Parser [Lexeme a] parseLexemes = many parseLexeme@@ -229,28 +253,29 @@     _ <- lexeme $ oneOf "/→"     replacement <- parseLexemes -    let parseEnvironment = do-            _ <- symbol "/"-            env1 <- parseLexemes-            _ <- symbol "_"-            env2 <- parseLexemes-            exception <- optional $ (,) <$> (symbol "/" *> parseLexemes) <* symbol "_" <*> parseLexemes-            return (env1, env2, exception)+    envs' <- many $ do+        notFollowedBy $ symbol "//"  -- for exceptions+        _ <- symbol "/"+        env1 <- parseLexemes+        _ <- symbol "_"+        env2 <- parseLexemes+        return (env1, env2)+    let envs = if null envs' then [([], [])] else envs' -    (env1, env2, exception) <- parseEnvironment <|> pure ([], [], Nothing)+    exception <- optional $ (,) <$> (symbol "//" *> parseLexemes) <* symbol "_" <*> parseLexemes      _ <- optional scn   -- consume newline after rule if present      o' <- getOffset     let plaintext = takeWhile notNewline $ (fst . fromJust) (takeN_ (o' - o) s)-    return Rule{environment=(env1,env2), ..}+    return Rule{environment=envs, ..}   where     notNewline c = (c /= '\n') && (c /= '\r')  -- | Parse a 'String' in Brassica sound change syntax into a -- 'Rule'. Returns 'Left' if the input string is malformed. ----- For details on the syntax, refer to <https://github.com/bradrn/brassica/blob/v0.0.3/Documentation.md#basic-rule-syntax>.+-- For details on the syntax, refer to <https://github.com/bradrn/brassica/blob/v0.1.0/Documentation.md#basic-rule-syntax>. parseRule :: String -> Either (ParseErrorBundle String Void) Rule parseRule = parseRuleWithCategories M.empty 

@@ -16,6 +16,7 @@        , tokeniseWords        , detokeniseWords'        , detokeniseWords+       , concatWithBoundary        , findFirstCategoriesDecl        , withFirstCategoriesDecl        -- * Lower-level functions@@ -74,12 +75,16 @@ -- 'wordParser' itself is only really useful in unusual situations -- (e.g. as part of a larger parser). The first parameter gives a list -- of characters (aside from whitespace) which should be excluded from--- words, i.e. the parser will stop if any of them are found.+-- words, i.e. the parser will stop if any of them are found. The second+-- gives a list of multigraphs which might be expected. -- -- Note: the second parameter __must__ be 'sortByDescendingLength'-ed;--- otherwise digraphs will not be parsed correctly.-wordParser :: [Char] -> [Grapheme] -> ParsecT Void String Identity PWord-wordParser excludes gs = some $ choice (chunk <$> gs) <|> (pure <$> satisfy (not . exclude))+-- otherwise multigraphs will not be parsed correctly.+wordParser :: [Char] -> [String] -> ParsecT Void String Identity PWord+wordParser excludes gs = some $+    (GBoundary <$ single '#')+    <|> choice (fmap GMulti . chunk <$> gs)+    <|> (GMulti . pure <$> satisfy (not . exclude))   where     exclude = (||) <$> isSpace <*> (`elem` excludes) @@ -105,34 +110,34 @@ sortByDescendingLength = sortBy (compare `on` Down . length)  -- | Tokenise a 'String' input word into a 'PWord' by splitting it up--- into t'Grapheme's. A list of available t'Grapheme's is supplied as--- an argument.+-- into t'Grapheme's. A list of available multigraphs is supplied as+-- the first argument. -- -- Note that this tokeniser is greedy: if one of the given--- t'Grapheme's is a prefix of another, the tokeniser will prefer the--- longest if possible. If there are no matching t'Grapheme's starting+-- multigraphs is a prefix of another, the tokeniser will prefer the+-- longest if possible. If there are no matching multigraphs starting -- at a particular character in the 'String', 'tokeniseWord' will -- treat that character as its own t'Grapheme'. For instance: -- -- >>> tokeniseWord [] "cherish"--- Right ["c","h","e","r","i","s","h"]+-- Right [GMulti "c",GMulti "h",GMulti "e",GMulti "r",GMulti "i",GMulti "s",GMulti "h"] --  -- >>> tokeniseWord ["e","h","i","r","s","sh"] "cherish"--- Right ["c","h","e","r","i","sh"]+-- Right [GMulti "c",GMulti "h",GMulti "e",GMulti "r",GMulti "i",GMulti "sh"] --  -- >>> tokeniseWord ["c","ch","e","h","i","r","s","sh"] "cherish"--- Right ["ch","e","r","i","sh"]-tokeniseWord :: [Grapheme] -> String -> Either (ParseErrorBundle String Void) PWord+-- Right [GMulti "ch",GMulti "e",GMulti "r",GMulti "i",GMulti "sh"]+tokeniseWord :: [String] -> String -> Either (ParseErrorBundle String Void) PWord tokeniseWord (sortByDescendingLength -> gs) = parse (wordParser "[" gs) "" --- | Given a list of available t'Grapheme's, tokenise an input string+-- | Given a list of available multigraphs, tokenise an input string -- into a list of words and other 'Component's. This uses the same -- tokenisation strategy as 'tokeniseWords', but also recognises -- 'Gloss'es (in square brackets) and 'Separator's (in the form of -- whitespace).-tokeniseWords :: [Grapheme] -> String -> Either (ParseErrorBundle String Void) [Component PWord]+tokeniseWords :: [String] -> String -> Either (ParseErrorBundle String Void) [Component PWord] tokeniseWords (sortByDescendingLength -> gs) =-    parse (componentsParser $ wordParser "[" gs) ""+        parse (componentsParser $ wordParser "[" gs) ""  -- | Given a function to convert 'Word's to strings, converts a list -- of 'Component's to strings.@@ -143,14 +148,17 @@     Gloss g -> '[':(g ++ "]")  -- | Specialisation of 'detokeniseWords'' for 'PWord's, converting--- words to strings using 'concat'.+-- words to strings using 'concatWithBoundary'. detokeniseWords :: [Component PWord] -> String-detokeniseWords = detokeniseWords' concat+detokeniseWords = detokeniseWords' concatWithBoundary --- | Given a list of sound changes, extract the list of graphemes+-- | Given a list of sound changes, extract the list of multigraphs -- defined in the first categories declaration of the 'SoundChange's.-findFirstCategoriesDecl :: SoundChanges -> [Grapheme]-findFirstCategoriesDecl (CategoriesDeclS (CategoriesDecl gs):_) = gs+findFirstCategoriesDecl :: SoundChanges -> [String]+findFirstCategoriesDecl (CategoriesDeclS (CategoriesDecl gs):_) =+    mapMaybe+        (\case GBoundary -> Nothing; GMulti m -> Just m)+        gs findFirstCategoriesDecl (_:ss) = findFirstCategoriesDecl ss findFirstCategoriesDecl [] = [] @@ -158,5 +166,5 @@ -- like @'withFirstCategoriesDecl' 'tokeniseWords' changes words@ (to -- tokenise using the graphemes from the first categories declaration) -- and so on.-withFirstCategoriesDecl :: ([Grapheme] -> t) -> SoundChanges -> t+withFirstCategoriesDecl :: ([String] -> t) -> SoundChanges -> t withFirstCategoriesDecl tok ss = tok (findFirstCategoriesDecl ss)

@@ -6,8 +6,10 @@ {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE GADTs                 #-}+{-# LANGUAGE LambdaCase            #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE PatternSynonyms       #-} {-# LANGUAGE RankNTypes            #-} {-# LANGUAGE StandaloneDeriving    #-} {-# LANGUAGE TypeFamilies          #-}@@ -17,11 +19,14 @@ module Brassica.SoundChange.Types        (        -- * Words and graphemes-         Grapheme+         Grapheme(..)        , PWord+       , addBoundaries+       , removeBoundaries+       , concatWithBoundary        -- * Lexemes        , Lexeme(..)-       , CategoryElement(..)+       , pattern Boundary        , LexemeType(..)        -- * Rules        , Rule(..)@@ -41,6 +46,7 @@ import Control.DeepSeq (NFData(..)) import Data.Kind (Constraint) 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@.@@ -60,9 +66,11 @@                      ':<>: 'Text " or "                      ':<>: 'ShowType c)) --- | The type of graphemes, or more accurately multigraphs: for--- instance, @"a", "ch", "c̓" :: t'Grapheme'@.-type Grapheme = [Char]+-- | The type of graphemes within a word.+data Grapheme+    = GMulti [Char]  -- ^ A multigraph: for instance @GMulti "a", GMulti "ch", GMulti "c̓" :: t'Grapheme'@.+    | GBoundary      -- ^ A non-letter element representing a word boundary which sound changes can manipulate+    deriving (Eq, Ord, Show, Generic, NFData)  -- | A word (or a subsequence of one) can be viewed as a list of -- @Grapheme@s: e.g. Portuguese "filha" becomes@@ -73,6 +81,24 @@ -- with @Prelude.'Prelude.Word'@.) type PWord = [Grapheme] +-- Add a 'GBoundary' at the beginning and end of the 'PWord'.+addBoundaries :: PWord -> PWord+addBoundaries w = GBoundary : w ++ [GBoundary]++-- Remove 'GBoundary's from the beginning and end of the 'PWord'.+removeBoundaries :: PWord -> PWord+removeBoundaries = dropWhile (==GBoundary) . dropWhileEnd (==GBoundary)++-- | Render a 'PWord' as a 'String'. Very much like 'concat', but+-- treating 'GBoundary's specially. Word-external boundaries are+-- deleted, while word-internal boundaries are converted to @"#"@.+concatWithBoundary :: PWord -> String+concatWithBoundary = go . removeBoundaries+  where+    go = concatMap $ \case+        GMulti g -> g+        GBoundary -> "#"+ -- | The part of a 'Rule' in which a 'Lexeme' may occur: either the -- target, the replacement or the environment. data LexemeType = Target | Replacement | Env@@ -82,12 +108,11 @@ -- variable specifies where each different variety of 'Lexeme' may -- occur. data Lexeme (a :: LexemeType) where-    -- | In Brassica sound-change syntax, one or more letters without intervening whitespace+    -- | In Brassica sound-change syntax, one or more letters without intervening whitespace,+    -- or a word boundary specified as @#@     Grapheme :: Grapheme -> Lexeme a     -- | In Brassica sound-change syntax, delimited by square brackets-    Category :: [CategoryElement a] -> Lexeme a-    -- | In Brassica sound-change syntax, specified as @#@-    Boundary :: Lexeme 'Env+    Category :: [Grapheme] -> Lexeme a     -- | In Brassica sound-change syntax, delimited by parentheses     Optional :: [Lexeme a] -> Lexeme a     -- | In Brassica sound-change syntax, specified as @\@@@ -100,33 +125,28 @@     Kleene   :: OneOf a 'Target 'Env => Lexeme a -> Lexeme a     -- | In Brassica sound-change syntax, specified as @~@     Discard  :: Lexeme 'Replacement+    -- | In Brassica sound-change syntax, specified as \@i before a category+    Backreference :: OneOf a 'Target 'Replacement => Int -> [Grapheme] -> Lexeme a+    -- | In Brassica sound-change syntax, specified as \@? before a category+    Multiple :: [Grapheme] -> Lexeme 'Replacement +-- | A 'Lexeme' matching a single word boundary, specified as @#@ in Brassica syntax.+pattern Boundary :: Lexeme a+pattern Boundary = Grapheme GBoundary+ deriving instance Show (Lexeme a)  instance NFData (Lexeme a) where     rnf (Grapheme g) = rnf g     rnf (Category cs) = rnf cs-    rnf Boundary = ()     rnf (Optional ls) = rnf ls     rnf Metathesis = ()     rnf Geminate = ()     rnf (Wildcard l) = rnf l     rnf (Kleene l) = rnf l     rnf Discard = ()---- | The elements allowed in a 'Category': currently, only--- t'Grapheme's and word boundaries.-data CategoryElement (a :: LexemeType) where-    GraphemeEl :: Grapheme -> CategoryElement a-    BoundaryEl :: CategoryElement 'Env--deriving instance Show (CategoryElement a)-deriving instance Eq (CategoryElement a)-deriving instance Ord (CategoryElement a)--instance NFData (CategoryElement a) where-    rnf (GraphemeEl a) = rnf a-    rnf BoundaryEl = ()+    rnf (Backreference i l) = seq i $ rnf l+    rnf (Multiple l) = rnf l  -- | An 'Environment' is a tuple of @(before, after)@ components, -- corresponding to a ‘/ before _ after’ component of a sound change.@@ -170,12 +190,12 @@     }  -- | A single sound change rule: in Brassica sound-change syntax with all elements specified,--- @-flags target / replacement \/ environment \/ exception@.+-- @-flags target / replacement \/ environment1 | environment2 | … \/ exception@. -- (And usually the 'plaintext' of the rule will contain a 'String' resembling that pattern.) data Rule = Rule   { target      :: [Lexeme 'Target]   , replacement :: [Lexeme 'Replacement]-  , environment :: Environment+  , environment :: [Environment]   , exception   :: Maybe Environment   , flags       :: Flags   , plaintext   :: String