diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,63 @@ # Brassica changelog +## 0.3.0 + +### Behaviour + +- Bugfix: nested categories are now matched up correctly between target and replacement +- Bugfix: Brassica no longer freezes with rules where the target is entirely optional +- Bugfix: Brassica no longer crashes when a rule refers to nonexistent categories +- Wildcard symbols can now be used in the replacement of a rule +- Brassica now applies sound changes to words in parallel, giving a significant speedup on multi-core machines (though not in a webpage) +- New `extra` directive allows specifying characters which should never be replaced through all category redefinitions +- Improved placement of etymologies in MDF output +- Target and replacement can now be separated by `->` +- New `filter` directive allows removing unwanted results +- An improved heuristic for avoiding infinite loops in epenthesis rules, + such that e.g. `/h/a_a` yields `aaaa`→`ahahaha` rather than previous unexpected *`ahaaha` +- New `-??` flag to allow for per-occurrence sporadicity +- `categories` directive can now be specified `noreplace` + to prevent replacement of unknown graphemes with U+FFFD (�) +- Improved method for highlighting words ‘different to last run’ + (now using the Myers diff algorithm) +- Added syntax highlighting for flags +- Sound change rules can now be specified on the command-line using new `--eval` or `-e` flag +- Add CLI option to highlight words different to input +- Currently open files shown in title of desktop window +- Desktop application warns when closing with unsaved changes +- Improve user interface for file management in desktop paradigm builder +- New CLI for paradigm builder: program name `brassica-pb` + +### Code + +- `optparse-applicative` lower bound tightened to 0.17.1 +- Bugfix: `Brassica.SoundChange.Apply.applyRuleStr` is no longer seriously broken +- `Brassica.SoundChange.Apply.Internal.applyOnce` now returns a `RuleStatus` value with more detailed information about the rule application, which is now used by `Brassica.SoundChange.Apply.Internal.setupForNextApplication` +- `Wildcard` and `Kleene` no longer have `OneOf 'Target 'Env` constraint +- `OneOf` type family is no longer used and has been removed +- `Target` and `Environment` `LexemeType`s have been unified as `Matched` +- `Brassica.SoundChange.Frontend.Internal.parseTokeniseAndApplyRules` now takes another argument specifying how to map over the parse output, + allowing it to be run both on a single core and in parallel depending on the provided function +- `Brassica.SoundChange.Types.Directive` has a new constructor `ExtraGraphemes` for the `extra` directive, with corresponding changes in parsing and expansion +- `Brassica.SoundChange.Category.extend` has been renamed to `extendCategories`, and now requires pattern-matching on a `Categories` directive before use +- `Brassica.SoundChange.Frontend.Internal.parseTokeniseAndApplyRules` no longer implements rule expansion, + allowing it to take place only once without needing to be repeated for each rule application. +- MDF support has been comprehensively rewritten: + - `Brassica.MDF` has been removed + - New module `Brassica.SFM.SFM` implements generic support for SIL Standard Field Marker hierarchies + - New module `Brassica.SFM.MDF` describes the standard and alternate MDF hierarchies, + and other necessary utilities for working with MDF documents + - Some rewrites to `Brassica.SoundChange.Frontend.Internal` to account for the new architecture +- New type `Brassica.SoundChange.Types.Filter`, resulting in other changes: + - New `FilterS` constructor added to `Brassica.SoundChange.Types.Statement` + - `LogItem` and `PWordLog` (in `Brassica.SoundChange.Apply.Internal`) now use `Maybe PWord` + to show cases where a word was deleted + - Corresponding changes to parsing, expansion and application +- Rule sporadicity is now represented by a dedicated type, `Brassica.SoundChange.Types.Sporadicity` +- `Categories` constructor (in `Brassica.SoundChange.Types.Directive`) + now has an extra field for `noreplace` directive +- Add useful function `Brassica.Paradigm.Apply.depth` + ## v0.2.0 - Allow grapheme to begin with star diff --git a/bench/Changes.hs b/bench/Changes.hs --- a/bench/Changes.hs +++ b/bench/Changes.hs @@ -3,6 +3,7 @@ module Main where +import Control.Parallel.Strategies (withStrategy, parTraversable, rseq) import Criterion.Main (defaultMain, bench, nf, bgroup, Benchmark) import Data.FileEmbed (embedFile) import Data.Text (unpack) @@ -35,12 +36,16 @@ [ bench "parse" $ nf parseSoundChanges manyChanges , bench "parseRun" $ case parseSoundChanges manyChanges of Left _ -> error "invalid changes file" - Right cs -> nf (parseTokeniseAndApplyRules - cs - manyWords - Raw - (ApplyRules NoHighlight WordsOnlyOutput "/")) - Nothing + Right statements -> + case expandSoundChanges statements of + Left _ -> error "invalid changes file" + Right cs -> nf (parseTokeniseAndApplyRules + (fmap . fmap) + cs + manyWords + Raw + (ApplyRules NoHighlight WordsOnlyOutput "/")) + Nothing ] ] where @@ -84,3 +89,6 @@ manyWords :: String manyWords = unpack $ decodeUtf8 $(embedFile "bench/sample-words.lex") + +parFmap :: (a -> b) -> ParseOutput a -> ParseOutput b +parFmap f = withStrategy (parTraversable rseq) . fmap f diff --git a/bench/Paradigm.hs b/bench/Paradigm.hs --- a/bench/Paradigm.hs +++ b/bench/Paradigm.hs @@ -3,6 +3,7 @@ module Main where import Criterion.Main (bench, nf, defaultMain) +import Data.Foldable (toList) import Brassica.Paradigm @@ -14,7 +15,8 @@ , bench "large" $ nf (build largeParadigm) largeWords ] where - build = concatMap . applyParadigm + build :: Paradigm -> [String] -> [String] + build p = concatMap $ (toList .) $ applyParadigm p smallParadigm :: Paradigm smallParadigm = diff --git a/brassica.cabal b/brassica.cabal --- a/brassica.cabal +++ b/brassica.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: brassica -version: 0.2.0 +version: 0.3.0 synopsis: Featureful sound change applier description: The Brassica library for the simulation of sound changes in historical linguistics and language construction. @@ -33,7 +33,8 @@ , Brassica.SoundChange.Parse , Brassica.SoundChange.Tokenise , Brassica.SoundChange.Types - , Brassica.MDF + , Brassica.SFM.MDF + , Brassica.SFM.SFM , Brassica.Paradigm other-modules: Brassica.Paradigm.Apply , Brassica.Paradigm.Parse @@ -44,6 +45,7 @@ base >=4.7 && <5 , containers >=0.6 && <0.7 , deepseq >=1.4 && <1.6 + , fast-myers-diff ==0.0.0 , megaparsec >=8.0 && <9.7 , mtl >=2.2 && <2.4 , parser-combinators >=1.2 && <1.3 @@ -67,11 +69,26 @@ , conduit ^>=1.3 , conduit-extra ^>=1.3 , deepseq >=1.4 && <1.6 - , optparse-applicative ^>=0.17 || ^>=0.18 + , optparse-applicative ^>=0.17.1 || ^>=0.18 + , parallel ^>= 3.2 , text >=1.2 && <2.2 default-language: Haskell2010 +executable brassica-pb + main-is: Main.hs + hs-source-dirs: cli-pb + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base >=4.7 && <5 + , brassica + , bytestring >=0.10 && <0.13 + , conduit ^>=1.3 + , optparse-applicative ^>=0.17.1 || ^>=0.18 + , text >=1.2 && <2.2 + + default-language: Haskell2010 + benchmark changes-bench type: exitcode-stdio-1.0 main-is: Changes.hs @@ -82,6 +99,7 @@ , brassica , criterion >=1.5 && <1.7 , file-embed >=0.0.15 && <0.0.16 + , parallel ^>= 3.2 , text >=1.2 && <1.3 default-language: Haskell2010 diff --git a/cli-pb/Main.hs b/cli-pb/Main.hs new file mode 100644 --- /dev/null +++ b/cli-pb/Main.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Main where + +import Conduit +import qualified Data.ByteString as B +import Data.Foldable (toList) +import qualified Data.Text as T +import Data.Text (unpack, pack, Text) +import Data.Text.Encoding (decodeUtf8) +import Options.Applicative + +import Brassica.Paradigm + +main :: IO () +main = execParser opts >>= \Options{..} -> do + paradigmText <- + case paradigm of + FromFile paradigmFile -> unpack . decodeUtf8 <$> B.readFile paradigmFile + FromEval s -> pure s + + case parseParadigm paradigmText of + Left e -> putStrLn $ errorBundlePretty e + Right p -> + withSourceFileIf inRootsFile $ \inC -> + withSinkFileIf outWordsFile $ \outC -> + runConduit $ + inC + .| decodeUtf8C + .| linesUnboundedC + .| mapC (processRoot nestedOutput p) + .| unlinesC + .| encodeUtf8C + .| outC + where + opts = info (args <**> helper <**> simpleVersioner "v0.3.0") fullDesc + + args = Options + <$> asum + [ FromEval <$> strOption + (long "eval" <> short 'e' <> help "Literal paradigm to run through (newline-separated, as in paradigm file)") + , FromFile <$> strArgument + (metavar "PARADIGM" <> help "File containing paradigm") + ] + <*> switch (long "nest" <> short 'n' <> help "Print output in nested format") + <*> optional (strOption + (long "in" <> short 'i' <> help "File containing input roots (if not specified will read from stdin)")) + <*> optional (strOption + (long "out" <> short 'o' <> help "File to which output words should be written (if not specified will write to stdout)")) + + -- duplicated from main CLI + withSourceFileIf :: Maybe FilePath -> (ConduitM i B.ByteString IO () -> IO a) -> IO a + withSourceFileIf = maybe ($ stdinC) withSourceFile + + withSinkFileIf :: Maybe FilePath -> (ConduitM B.ByteString o IO () -> IO a) -> IO a + withSinkFileIf = maybe ($ stdoutC) withSinkFile + + processRoot :: Bool -> Paradigm -> Text -> Text + processRoot nestedOutput p r = + let output = applyParadigm p $ unpack r + in if nestedOutput + then addSpaces output $ pack $ formatNested id output + else T.unlines $ pack <$> toList output + + -- careful: need to add spaces to the end of each item if making nested output + -- so that adjacent items don’t run together! + addSpaces :: ResultsTree a -> Text -> Text + addSpaces t = flip T.append $ T.replicate (depth t) "\n" + +data ParadigmInput = FromFile String | FromEval String + deriving (Show) + +data Options = Options + { paradigm :: ParadigmInput + , nestedOutput :: Bool + , inRootsFile :: Maybe String + , outWordsFile :: Maybe String + } + deriving (Show) diff --git a/cli/Main.hs b/cli/Main.hs --- a/cli/Main.hs +++ b/cli/Main.hs @@ -19,27 +19,40 @@ main = execParser opts >>= \case Server -> serve Options{..} -> do - changesText <- unpack . decodeUtf8 <$> B.readFile rulesFile + changesText <- + case rules of + FromFile rulesFile -> unpack . decodeUtf8 <$> B.readFile rulesFile + FromEval s -> pure s case parseSoundChanges changesText of Left err -> putStrLn $ errorBundlePretty err - Right rules -> - withSourceFileIf inWordsFile $ \inC -> - withSinkFileIf outWordsFile $ \outC -> - runConduit $ - inC - .| processWords (incrFor wordsFormat) rules wordsFormat outMode - .| outC + Right scs -> + case expandSoundChanges scs of + Left err -> putStrLn $ case err of + (NotFound s) -> "Could not find category: " ++ s + InvalidBaseValue -> "Invalid value used as base grapheme in feature definition" + MismatchedLengths -> "Mismatched lengths in feature definition" + Right rules' -> + withSourceFileIf inWordsFile $ \inC -> + withSinkFileIf outWordsFile $ \outC -> + runConduit $ + inC + .| processWords (incrFor wordsFormat) rules' wordsFormat outMode + .| outC where - opts = info (args <**> helper <**> simpleVersioner "v0.2.0") fullDesc + opts = info (args <**> helper <**> simpleVersioner "v0.3.0") fullDesc args = batchArgs <|> serverArgs serverArgs = flag' Server (long "server" <> help "Run server (for internal use only)") batchArgs = Options - <$> strArgument - (metavar "RULES" <> help "File containing sound changes") + <$> asum + [ FromEval <$> strOption + (long "eval" <> short 'e' <> help "Literal sound change(s) to evaluate (newline-separated, as in rules file)") + , FromFile <$> strArgument + (metavar "RULES" <> help "File containing sound changes") + ] <*> flag Raw MDF (long "mdf" <> help "Parse input words in MDF format") <*> (asum @@ -51,6 +64,8 @@ (long "etymons" <> help "With --mdf, output MDF dictionary with etymologies") , flag' (ApplyRules NoHighlight WordsWithProtoOutput) (long "show-input" <> help "Output an input→output wordlist") + , flag' (ApplyRules DifferentToInput WordsOnlyOutput) + (long "show-changed" <> help "Add [+] after all words different to input") , flag (ApplyRules NoHighlight WordsOnlyOutput) (ApplyRules NoHighlight WordsOnlyOutput) @@ -66,14 +81,18 @@ incrFor Raw = True incrFor MDF = False + -- duplicated in paradigm builder CLI withSourceFileIf :: Maybe FilePath -> (ConduitM i B.ByteString IO () -> IO a) -> IO a withSourceFileIf = maybe ($ stdinC) withSourceFile withSinkFileIf :: Maybe FilePath -> (ConduitM B.ByteString o IO () -> IO a) -> IO a withSinkFileIf = maybe ($ stdoutC) withSinkFile +data Rules = FromFile String | FromEval String + deriving (Show) + data Options = Options - { rulesFile :: String + { rules :: Rules , wordsFormat :: InputLexiconFormat , outMode :: ApplicationMode , inWordsFile :: Maybe String @@ -85,7 +104,7 @@ processWords :: (MonadIO m, MonadThrow m) => Bool -- split into lines? - -> SoundChanges CategorySpec Directive + -> SoundChanges Expanded [Grapheme] -> InputLexiconFormat -> ApplicationMode -> ConduitT B.ByteString B.ByteString m () @@ -96,7 +115,7 @@ .| throwOnLeft .| encodeUtf8C where - evolve ws = parseTokeniseAndApplyRules rules ws wordsFormat outMode Nothing + evolve ws = parseTokeniseAndApplyRules parFmap rules ws wordsFormat outMode Nothing throwOnLeft :: (MonadThrow m, Exception e) => ConduitT (Either e r) r m () throwOnLeft = awaitForever $ \case @@ -104,13 +123,12 @@ Right r -> yield r processApplicationOutput :: ApplicationOutput PWord (Statement Expanded [Grapheme]) -> Either ParseException Text - processApplicationOutput (HighlightedWords cs) = Right $ pack $ detokeniseWords $ (fmap.fmap) fst cs + processApplicationOutput (HighlightedWords cs) = Right $ pack $ detokeniseWords' highlight cs processApplicationOutput (AppliedRulesTable is) = Right $ pack $ unlines $ reportAsText plaintext' <$> is processApplicationOutput (ParseError e) = Left $ ParseException $ errorBundlePretty e - processApplicationOutput (ExpandError e) = Left $ ParseException $ case e of - (NotFound s) -> "Could not find category: " ++ s - InvalidBaseValue -> "Invalid value used as base grapheme in feature definition" - MismatchedLengths -> "Mismatched lengths in feature definition" + + highlight (w, False) = concatWithBoundary w + highlight (w, True) = concatWithBoundary w ++ " [+]" newtype ParseException = ParseException String deriving Show diff --git a/cli/Server.hs b/cli/Server.hs --- a/cli/Server.hs +++ b/cli/Server.hs @@ -8,11 +8,12 @@ {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -module Server (serve) where +module Server (serve, parFmap) where import Conduit (runConduit, (.|), stdinC, stdoutC, mapMC) import Control.DeepSeq (force, NFData) import Control.Exception (evaluate) +import Control.Parallel.Strategies (withStrategy, parTraversable, rseq) import Data.Aeson (Result(..), encode, fromJSON) import Data.Aeson.Parser (json') import Data.Aeson.TH (deriveJSON, defaultOptions, defaultTaggedObject, constructorTagModifier, sumEncoding, tagFieldName) @@ -102,19 +103,21 @@ in case parseSoundChanges changes of Left e -> RespError $ "
" ++ errorBundlePretty e ++ "
" Right statements -> - let result' = parseTokeniseAndApplyRules statements input inFmt mode prev - in case result' of - ParseError e -> RespError $ - "
" ++ errorBundlePretty e ++ "
" - HighlightedWords result -> RespRules - (Just $ (fmap.fmap) fst result) - (escape $ detokeniseWords' highlightWord result) - AppliedRulesTable items -> RespRules Nothing $ - surroundTable $ concatMap (reportAsHtmlRows plaintext') items - ExpandError err -> RespError $ ("
"++) $ (++"
") $ case err of + case expandSoundChanges statements of + Left err -> RespError $ ("
"++) $ (++"
") $ case err of (NotFound s) -> "Could not find category: " ++ s InvalidBaseValue -> "Invalid value used as base grapheme in feature definition" MismatchedLengths -> "Mismatched lengths in feature definition" + Right statements' -> + let result' = parseTokeniseAndApplyRules parFmap statements' input inFmt mode prev + in case result' of + ParseError e -> RespError $ + "
" ++ errorBundlePretty e ++ "
" + HighlightedWords result -> RespRules + (Just $ (fmap.fmap) fst result) + (escape $ detokeniseWords' highlightWord result) + AppliedRulesTable items -> RespRules Nothing $ + surroundTable $ concatMap (reportAsHtmlRows plaintext') items where highlightWord (s, False) = concatWithBoundary s highlightWord (s, True) = "" ++ concatWithBoundary s ++ "" @@ -122,6 +125,9 @@ surroundTable :: String -> String surroundTable s = "" ++ s ++ "
" 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{..} = diff --git a/src/Brassica/MDF.hs b/src/Brassica/MDF.hs deleted file mode 100644 --- a/src/Brassica/MDF.hs +++ /dev/null @@ -1,220 +0,0 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ViewPatterns #-} - -{-| This module contains types and functions for working with the MDF - dictionary format, used by programs such as [SIL Toolbox](https://software.sil.org/toolbox/). - For more on the MDF format, refer to e.g. - [Coward & Grimes (2000), /Making Dictionaries: A guide to lexicography and the Multi-Dictionary Formatter/](http://downloads.sil.org/legacy/shoebox/MDF_2000.pdf). --} -module Brassica.MDF - ( - -- * MDF files - MDF(..) - , MDFLanguage(..) - , fieldLangs - -- * Parsing - , parseMDFRaw - , parseMDFWithTokenisation - -- ** Re-export - , errorBundlePretty - -- * Conversion - , componentiseMDF - , componentiseMDFWordsOnly - , duplicateEtymologies - ) where - -import Control.Category ((>>>)) -import Data.Char (isSpace) -import Data.Void (Void) - -import qualified Data.Map as M -import Text.Megaparsec -import Text.Megaparsec.Char - -import Brassica.SoundChange.Tokenise -import Brassica.SoundChange.Types (PWord) -import Data.Maybe (fromMaybe) - --- | An MDF (Multi-Dictionary Formatter) file, represented as a list --- of (field marker, whitespace, field value) tuples. The field marker --- is represented excluding its initial slash; whitespace after the --- field marker is also stored, allowing the original MDF file to be --- precisely recovered. Field values should includes all whitespace to --- the next marker. All field values are stored as 'String's, with the --- exception of 'Vernacular' fields, which have type @v@. --- --- For instance, the following MDF file: --- --- > \lx kapa --- > \ps n --- > \ge parent --- > \se sakapa --- > \ge father --- --- Could be stored as: --- --- > MDF [ ("lx", " ", Right "kapa\n") --- > , ("ps", " ", Left "n\n") --- > , ("ge", " ", Left "parent\n") --- > , ("se", " ", Right "sakapa\n") --- > , ("ge", " ", Left "father") --- > ] -newtype MDF v = MDF { unMDF :: [(String, String, Either String v)] } - deriving (Show, Functor) - -type Parser = Parsec Void String - -sc :: Parser String -sc = fmap (fromMaybe "") $ optional $ takeWhile1P (Just "white space") isSpace - -parseToSlash :: Parser String -parseToSlash = takeWhileP (Just "field value") (/= '\\') - -entry :: Parser v -> Parser (String, String, Either String v) -entry pv = do - _ <- char '\\' - marker <- takeWhile1P (Just "field name") (not . isSpace) - s <- sc - value <- case M.lookup marker fieldLangs of - Just Vernacular -> Right <$> pv - _ -> Left <$> parseToSlash - pure (marker, s, value) - --- | Parse an MDF file to an 'MDF', storing the 'Vernacular' fields as 'String's. -parseMDFRaw :: String -> Either (ParseErrorBundle String Void) (MDF String) -parseMDFRaw = runParser (fmap MDF $ sc *> many (entry parseToSlash) <* eof) "" - --- | Parse an MDF file to an 'MDF', parsing the 'Vernacular' fields --- into 'Component's in the process. -parseMDFWithTokenisation - :: [String] - -> String - -> Either (ParseErrorBundle String Void) (MDF [Component PWord]) -parseMDFWithTokenisation (sortByDescendingLength -> gs) = - runParser (fmap MDF $ sc *> p <* eof) "" - where - p = many $ entry $ componentsParser $ wordParser "\\" gs - --- | Convert an 'MDF' to a list of 'Component's representing the same --- textual content. Vernacular field values are left as is; everything --- else is treated as a 'Separator', so that it is not disturbed by --- operations such as rule application or rendering to text. -componentiseMDF :: MDF [Component a] -> [Component a] -componentiseMDF = unMDF >>> concatMap \case - (m, s, Left v) -> [Separator ('\\':m ++ s ++ v)] - (m, s, Right v) -> Separator ('\\':m ++ s) : v - --- | As with 'componentiseMDF', but the resulting 'Component's contain --- the contents of 'Vernacular' fields only; all else is --- discarded. The first parameter specifies the 'Separator' to insert --- after each vernacular field. -componentiseMDFWordsOnly :: MDF [Component a] -> [Component a] -componentiseMDFWordsOnly = unMDF >>> concatMap \case - (_, _, Right v) -> v - _ -> [] - --- | Add etymological fields to an 'MDF' by duplicating the values in --- @\lx@, @\se@ and @\ge@ fields. e.g.: --- --- > \lx kapa --- > \ps n --- > \ge parent --- > \se sakapa --- > \ge father --- --- Would become: --- --- > \lx kapa --- > \ps n --- > \ge parent --- > \et kapa --- > \eg parent --- > \se sakapa --- > \ge father --- > \et sakapa --- > \eg father --- --- This can be helpful when applying sound changes to an MDF file: the --- vernacular words can be copied as etymologies, and then the sound --- changes can be applied leaving the etymologies as is. -duplicateEtymologies - :: (v -> String) - -- ^ Function to convert from vernacular field values to - -- strings. Can also be used to preprocess the value of the - -- resulting @\et@ fields, e.g. by prepending @*@ or similar. - -> MDF v -> MDF v -duplicateEtymologies typeset = MDF . go Nothing Nothing . unMDF - where - mkEt word gloss = word' gloss' - where - word' = case word of - Just et -> (("et", " ", Left $ typeset et) :) - Nothing -> id - gloss' = case gloss of - Just eg -> [("eg", " ", Left eg)] - Nothing -> [] - - go word gloss [] = mkEt word gloss - go word _ (f@("ge", _, Left gloss'):fs) -- store gloss field for future etymology - = f : go word (Just gloss') fs - go word gloss (f@(m, _, Right word'):fs) -- add etymology & store word if word or subentry field reached - | m == "lx" || m == "se" - = mkEt word gloss ++ f : go (Just word') Nothing fs - go word gloss (f@("dt", _, _):fs) -- add etymology if date (usually final field in entry) reached - = mkEt word gloss ++ f : go Nothing Nothing fs - go word gloss (f:fs) = f : go word gloss fs - - --- | The designated language of an MDF field. -data MDFLanguage = English | National | Regional | Vernacular | Other - deriving (Eq, Show) - --- | A 'M.Map' from the most common field markers to the language of --- their values. --- --- (Note: This is currently hardcoded in the source code, based on the --- values in the MDF definitions from SIL Toolbox. There’s probably a --- more principled way of defining this, but hardcoding should suffice --- for now.) -fieldLangs :: M.Map String MDFLanguage -fieldLangs = M.fromList - [ ("1d" , Vernacular) , ("1e" , Vernacular) , ("1i" , Vernacular) - , ("1p" , Vernacular) , ("1s" , Vernacular) , ("2d" , Vernacular) - , ("2p" , Vernacular) , ("2s" , Vernacular) , ("3d" , Vernacular) - , ("3p" , Vernacular) , ("3s" , Vernacular) , ("4d" , Vernacular) - , ("4p" , Vernacular) , ("4s" , Vernacular) , ("a" , Vernacular) - , ("an" , Vernacular) , ("bb" , English) , ("bw" , English) - , ("ce" , English) , ("cf" , Vernacular) , ("cn" , National) - , ("cr" , National) , ("de" , English) , ("dn" , National) - , ("dr" , Regional) , ("dt" , Other) , ("dv" , Vernacular) - , ("ec" , English) , ("ee" , English) , ("eg" , English) - , ("en" , National) , ("er" , Regional) , ("es" , English) - , ("et" , Other) {- defined as vernacular in SIL Toolbox, but by - definition it's really a different language -} - , ("ev" , Vernacular) , ("ge" , English) - , ("gn" , National) , ("gr" , Regional) , ("gv" , Vernacular) - , ("hm" , English) , ("is" , English) , ("lc" , Vernacular) - , ("le" , English) , ("lf" , English) , ("ln" , National) - , ("lr" , Regional) , ("lt" , English) , ("lv" , Vernacular) - , ("lx" , Vernacular) , ("mn" , Vernacular) , ("mr" , Vernacular) - , ("na" , English) , ("nd" , English) , ("ng" , English) - , ("np" , English) , ("nq" , English) , ("ns" , English) - , ("nt" , English) , ("oe" , English) , ("on" , National) - , ("or" , Regional) , ("ov" , Vernacular) , ("pc" , English) - , ("pd" , English) , ("pde", English) , ("pdl", English) - , ("pdn", National) , ("pdr", Regional) , ("pdv", Vernacular) - , ("ph" , Other) , ("pl" , Vernacular) , ("pn" , National) - , ("ps" , English) , ("rd" , Vernacular) , ("re" , English) - , ("rf" , English) , ("rn" , National) , ("rr" , Regional) - , ("sc" , English) , ("sd" , English) , ("se" , Vernacular) - , ("sg" , Vernacular) , ("sn" , English) , ("so" , English) - , ("st" , English) , ("sy" , Vernacular) , ("tb" , English) - , ("th" , Vernacular) , ("u" , Vernacular) , ("ue" , English) - , ("un" , National) , ("ur" , Regional) , ("uv" , Vernacular) - , ("va" , Vernacular) , ("ve" , English) , ("vn" , National) - , ("vr" , Regional) , ("we" , English) , ("wn" , National) - , ("wr" , Regional) , ("xe" , English) , ("xn" , National) - , ("xr" , Regional) , ("xv" , Vernacular) - ] diff --git a/src/Brassica/Paradigm.hs b/src/Brassica/Paradigm.hs --- a/src/Brassica/Paradigm.hs +++ b/src/Brassica/Paradigm.hs @@ -10,6 +10,7 @@ , Statement(..) , Paradigm , ResultsTree(..) + , depth , applyParadigm , parseParadigm , formatNested diff --git a/src/Brassica/Paradigm/Apply.hs b/src/Brassica/Paradigm/Apply.hs --- a/src/Brassica/Paradigm/Apply.hs +++ b/src/Brassica/Paradigm/Apply.hs @@ -6,6 +6,7 @@ ( ResultsTree(..) , applyParadigm , formatNested + , depth ) where import Brassica.Paradigm.Types @@ -22,6 +23,10 @@ addLevel f (Result r) = Node $ Result <$> f r addLevel f (Node rs) = Node $ addLevel f <$> rs +depth :: ResultsTree a -> Int +depth (Node ts) = maximum $ (1+) . depth <$> ts +depth (Result _) = 0 + -- | Formats a 'ResultsTree' in a nested way, where the lowest-level -- elements are separated by one space, the second-lowest are -- separated by one newline, the third-lowest by two newlines, and so @@ -32,12 +37,12 @@ go (Result a) = (0, f a) go (Node rts) = let (depths, formatted) = unzip $ go <$> rts - depth = maximum depths + depth' = maximum depths separator = - if depth == 0 + if depth' == 0 then " " - else replicate depth '\n' - in (1+depth, intercalate separator formatted) + else replicate depth' '\n' + in (1+depth', intercalate separator formatted) -- | Apply the given 'Paradigm' to a root, to produce all possible -- derived forms. diff --git a/src/Brassica/Paradigm/Parse.hs b/src/Brassica/Paradigm/Parse.hs --- a/src/Brassica/Paradigm/Parse.hs +++ b/src/Brassica/Paradigm/Parse.hs @@ -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 . +-- For details on the syntax, refer to . parseParadigm :: String -> Either (ParseErrorBundle String Void) Paradigm parseParadigm = runParser (many statement) "" diff --git a/src/Brassica/SFM/MDF.hs b/src/Brassica/SFM/MDF.hs new file mode 100644 --- /dev/null +++ b/src/Brassica/SFM/MDF.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE NamedFieldPuns #-} + +{-| This module contains types and functions for working with the MDF + dictionary format, used by programs such as [SIL Toolbox](https://software.sil.org/toolbox/). + For more on the MDF format, refer to e.g. + [Coward & Grimes (2000), /Making Dictionaries: A guide to lexicography and the Multi-Dictionary Formatter/](http://downloads.sil.org/legacy/shoebox/MDF_2000.pdf). +-} +module Brassica.SFM.MDF where + +import Brassica.SFM.SFM + +import qualified Data.Map as M +import Brassica.SoundChange.Tokenise +import Brassica.SoundChange.Types (PWord) +import Text.Megaparsec (State(..), PosState (..), ParseErrorBundle, runParser') +import Text.Megaparsec.State (initialPosState) +import Data.Void (Void) +import Data.Char (isSpace) +import Data.List (dropWhileEnd) + +-- | The designated language of an MDF field. +data MDFLanguage = English | National | Regional | Vernacular | Other + deriving (Eq, Show) + +-- | A 'M.Map' from the most common field markers to the language of +-- their values. +-- +-- (Note: This is currently hardcoded in the source code, based on the +-- values in the MDF definitions from SIL Toolbox. The exception is +-- @\et@, which is assigned as 'Other' rather than +-- 'Vernacular'. There’s probably a more principled way of defining +-- this, but hardcoding should suffice for now.) +fieldLangs :: M.Map String MDFLanguage +fieldLangs = M.fromList + [ ("1d" , Vernacular) , ("1e" , Vernacular) , ("1i" , Vernacular) + , ("1p" , Vernacular) , ("1s" , Vernacular) , ("2d" , Vernacular) + , ("2p" , Vernacular) , ("2s" , Vernacular) , ("3d" , Vernacular) + , ("3p" , Vernacular) , ("3s" , Vernacular) , ("4d" , Vernacular) + , ("4p" , Vernacular) , ("4s" , Vernacular) , ("a" , Vernacular) + , ("an" , Vernacular) , ("bb" , English) , ("bw" , English) + , ("ce" , English) , ("cf" , Vernacular) , ("cn" , National) + , ("cr" , National) , ("de" , English) , ("dn" , National) + , ("dr" , Regional) , ("dt" , Other) , ("dv" , Vernacular) + , ("ec" , English) , ("ee" , English) , ("eg" , English) + , ("en" , National) , ("er" , Regional) , ("es" , English) + , ("et" , Other) {- defined as vernacular in SIL Toolbox, but by + definition it's really a different language -} + , ("ev" , Vernacular) , ("ge" , English) + , ("gn" , National) , ("gr" , Regional) , ("gv" , Vernacular) + , ("hm" , English) , ("is" , English) , ("lc" , Vernacular) + , ("le" , English) , ("lf" , English) , ("ln" , National) + , ("lr" , Regional) , ("lt" , English) , ("lv" , Vernacular) + , ("lx" , Vernacular) , ("mn" , Vernacular) , ("mr" , Vernacular) + , ("na" , English) , ("nd" , English) , ("ng" , English) + , ("np" , English) , ("nq" , English) , ("ns" , English) + , ("nt" , English) , ("oe" , English) , ("on" , National) + , ("or" , Regional) , ("ov" , Vernacular) , ("pc" , English) + , ("pd" , English) , ("pde", English) , ("pdl", English) + , ("pdn", National) , ("pdr", Regional) , ("pdv", Vernacular) + , ("ph" , Other) , ("pl" , Vernacular) , ("pn" , National) + , ("ps" , English) , ("rd" , Vernacular) , ("re" , English) + , ("rf" , English) , ("rn" , National) , ("rr" , Regional) + , ("sc" , English) , ("sd" , English) , ("se" , Vernacular) + , ("sg" , Vernacular) , ("sn" , English) , ("so" , English) + , ("st" , English) , ("sy" , Vernacular) , ("tb" , English) + , ("th" , Vernacular) , ("u" , Vernacular) , ("ue" , English) + , ("un" , National) , ("ur" , Regional) , ("uv" , Vernacular) + , ("va" , Vernacular) , ("ve" , English) , ("vn" , National) + , ("vr" , Regional) , ("we" , English) , ("wn" , National) + , ("wr" , Regional) , ("xe" , English) , ("xn" , National) + , ("xr" , Regional) , ("xv" , Vernacular) + ] + +-- | Standard MDF hierarchy: with @\lx@ > @\se@ > @\ps@ > @\sn@. +-- Intended for use with 'toTree'. +mdfHierarchy :: Hierarchy +mdfHierarchy = M.fromList + [ ("1d", "ps"), ("1e", "ps"), ("1i", "ps"), ("1p", "ps"), ("1s", "ps") + , ("2d", "ps"), ("2p", "ps"), ("2s", "ps"), ("3d", "ps"), ("3p", "ps") + , ("3s", "ps"), ("4d", "ps"), ("4p", "ps"), ("4s", "ps"), ("a", "lx") + , ("an", "sn"), ("bb", "sn"), ("bw", "se"), ("ce", "cf"), ("cf", "sn") + , ("cn", "cf"), ("cr", "cf"), ("de", "sn"), ("dn", "sn"), ("dr", "sn") + , ("dt", "lx"), ("dv", "sn"), ("ec", "et"), ("ee", "sn"), ("eg", "et") + , ("en", "sn"), ("er", "sn"), ("es", "et"), ("et", "se"), ("ev", "sn") + , ("ge", "sn"), ("gn", "sn"), ("gr", "sn"), ("gv", "sn"), ("hm", "lx") + , ("is", "sn"), ("lc", "lx"), ("le", "lv"), ("lf", "sn"), ("ln", "lv") + , ("lr", "lv"), ("lt", "sn"), ("lv", "lf"), ("mn", "se"), ("mr", "se") + , ("na", "sn"), ("nd", "sn"), ("ng", "sn"), ("np", "sn"), ("nq", "sn") + , ("ns", "sn"), ("nt", "sn"), ("oe", "sn"), ("on", "sn"), ("or", "sn") + , ("ov", "sn"), ("pc", "sn"), ("pd", "ps"), ("pde", "pdl") + , ("pdl", "pd"), ("pdn", "pdl"), ("pdr", "pdl"), ("pdv", "pdl") + , ("ph", "se"), ("pl", "ps"), ("pn", "ps"), ("ps", "se"), ("rd", "ps") + , ("re", "sn"), ("rf", "sn"), ("rn", "sn"), ("rr", "sn"), ("sc", "sn") + , ("sd", "sn"), ("se", "lx"), ("sg", "ps"), ("sn", "ps"), ("so", "sn") + , ("st", "lx"), ("sy", "sn"), ("tb", "sn"), ("th", "sn"), ("u", "lx") + , ("ue", "sn"), ("un", "sn"), ("ur", "sn"), ("uv", "sn"), ("va", "sn") + , ("ve", "va"), ("vn", "va"), ("vr", "va"), ("we", "sn"), ("wn", "sn") + , ("wr", "sn"), ("xe", "xv"), ("xn", "xv"), ("xr", "xv"), ("xv", "rf") + ] + +-- | Alternate MDF hierarchy: with @\lx@ > @\sn@ > @\se@ > @\ps@. +-- Intended for use with 'toTree'. +mdfAlternateHierarchy :: Hierarchy +mdfAlternateHierarchy = M.fromList + [ ("1d", "ps"), ("1e", "ps"), ("1i", "ps"), ("1p", "ps"), ("1s", "ps") + , ("2d", "ps"), ("2p", "ps"), ("2s", "ps"), ("3d", "ps"), ("3p", "ps") + , ("3s", "ps"), ("4d", "ps"), ("4p", "ps"), ("4s", "ps") + , ("an", "ps"), ("bb", "ps"), ("bw", "se"), ("ce", "cf"), ("cf", "ps") + , ("cn", "cf"), ("cr", "cf"), ("de", "ps"), ("dn", "ps"), ("dr", "ps") + , ("dt", "lx"), ("dv", "ps"), ("ec", "et"), ("ee", "ps"), ("eg", "et") + , ("en", "ps"), ("er", "ps"), ("es", "et"), ("et", "se"), ("ev", "ps") + , ("ge", "ps"), ("gn", "ps"), ("gr", "ps"), ("gv", "ps"), ("hm", "lx") + , ("is", "ps"), ("lc", "lx"), ("le", "lv"), ("lf", "ps"), ("ln", "lv") + , ("lr", "lv"), ("lt", "ps"), ("lv", "lf"), ("mn", "se"), ("mr", "se") + , ("na", "ps"), ("nd", "ps"), ("ng", "ps"), ("np", "ps"), ("nq", "ps") + , ("ns", "ps"), ("nt", "ps"), ("oe", "ps"), ("on", "ps"), ("or", "ps") + , ("ov", "ps"), ("pc", "ps"), ("pd", "ps"), ("pde", "pdl") + , ("pdl", "pd"), ("pdn", "pdl"), ("pdr", "pdl"), ("pdv", "pdl") + , ("ph", "se"), ("pl", "ps"), ("pn", "ps"), ("ps", "se"), ("rd", "ps") + , ("re", "ps"), ("rf", "ps"), ("rn", "ps"), ("rr", "ps"), ("sc", "ps") + , ("sd", "ps"), ("se", "sn"), ("sg", "ps"), ("sn", "lx"), ("so", "ps") + , ("st", "lx"), ("sy", "ps"), ("tb", "ps"), ("th", "ps") + , ("ue", "ps"), ("un", "ps"), ("ur", "ps"), ("uv", "ps"), ("va", "se") + , ("ve", "va"), ("vn", "va"), ("vr", "va"), ("we", "ps"), ("wn", "ps") + , ("wr", "ps"), ("xe", "xv"), ("xn", "xv"), ("xr", "xv"), ("xv", "rf") + ] + +-- | Convert an 'SFM' document to a list of 'Component's representing +-- the same textual content. 'Vernacular' field values are tokenised as +-- if using 'tokeniseWords'; everything else is treated as a +-- 'Separator', so that it is not disturbed by operations such as rule +-- application or rendering to text. +tokeniseMDF + :: [String] -- ^ List of available multigraphs (as with 'tokeniseWord') + -> SFM -> Either (ParseErrorBundle String Void) [Component PWord] +tokeniseMDF gs = fmap concat . traverse (tokeniseField gs) + +-- | Like 'tokeniseMDF', but for a single 'Field'. +tokeniseField :: [String] -> Field -> Either (ParseErrorBundle String Void) [Component PWord] +tokeniseField gs f = case M.lookup (fieldMarker f) fieldLangs of + Just Vernacular -> + let ps = initialPosState "" (fieldValue f) + s = State + { stateInput = fieldValue f + , stateOffset = 0 + , statePosState = case fieldSourcePos f of + Nothing -> ps + Just sp -> ps { pstateSourcePos = sp } + , stateParseErrors = [] + } + in case runParser' (componentsParser $ wordParser "[" gs) s of + (_, Right cs) -> Right $ Separator ('\\' : fieldMarker f ++ fieldWhitespace f) : cs + (_, Left err) -> Left err + + _ -> Right [Separator $ '\\' : fieldMarker f ++ fieldWhitespace f ++ fieldValue f] + +-- | Add etymological fields to an 'MDF' by duplicating the values in +-- @\lx@, @\se@ and @\ge@ fields. e.g.: +-- +-- > \lx kapa +-- > \ps n +-- > \ge parent +-- > \se sakapa +-- > \ge father +-- +-- Would become: +-- +-- > \lx kapa +-- > \ps n +-- > \ge parent +-- > \et kapa +-- > \eg parent +-- > \se sakapa +-- > \ge father +-- > \et sakapa +-- > \eg father +-- +-- This can be helpful when applying sound changes to an MDF file: the +-- vernacular words can be copied as etymologies, and then the sound +-- changes can be applied leaving the etymologies as is. +duplicateEtymologies + :: (String -> String) + -- ^ Transformation to apply to etymologies, e.g. @('*':)@ + -> SFMTree + -> SFMTree +duplicateEtymologies f = go Nothing Nothing + where + -- strategy: find each \se (implicit or explicit) with its \ge + -- and make an \et under it + go lx gl (Root ts) = Root $ go lx gl <$> ts + go _lx gl t@(Filled m@(Field { fieldMarker="lx", fieldValue }) ts) = + let lx = Just fieldValue + gl' = case searchField isGloss t of + gl'':_ -> Just gl'' + _ -> gl + in Filled m $ go lx gl' <$> ts + go _lx gl t@(Filled m@(Field { fieldMarker="se", fieldValue }) ts) = + let lx = Just fieldValue + gl' = case searchField isGloss t of + gl'':_ -> Just gl'' + _ -> gl + in Filled m $ ts ++ mkEt lx gl' + go lx gl (Filled m ts) = Filled m $ go lx gl <$> ts + go lx gl (Missing "se" ts) = Missing "se" $ ts ++ mkEt lx gl + go lx gl (Missing m ts) = Missing m $ go lx gl <$> ts + + isGloss Field{fieldMarker,fieldValue} + | fieldMarker == "ge" = Just fieldValue + | otherwise = Nothing + + mkEt :: Maybe String -> Maybe String -> [SFMTree] + mkEt Nothing _ = [] -- can't make etymology without lexeme + mkEt (Just lx) gl = pure $ + Filled Field + { fieldMarker = "et" + , fieldWhitespace = " " + , fieldSourcePos = Nothing + , fieldValue = f $ trim lx + } + $ case gl of + Nothing -> [] + Just gl' -> + [ Filled Field + { fieldMarker = "eg" + , fieldWhitespace = " " + , fieldSourcePos = Nothing + , fieldValue = gl' + -- no need to add newline here because 'gl' + -- should already have whitespace + } [] + ] + + trim = dropWhile isSpace . dropWhileEnd isSpace diff --git a/src/Brassica/SFM/SFM.hs b/src/Brassica/SFM/SFM.hs new file mode 100644 --- /dev/null +++ b/src/Brassica/SFM/SFM.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} + +{-| This module implements basic support for the SIL Standard Format +Marker (SFM) format, used by dictionary software such as +[FieldWorks](https://software.sil.org/fieldworks/). This format forms +the basis of standards such as Multi-Dictionary Formatter (MDF), +implemented here in 'Brassica.SFM.MDF'. +-} +module Brassica.SFM.SFM + ( -- * Linear SFM documents + Field(..) + , SFM + , parseSFM + , exactPrintField + , exactPrintSFM + , stripSourcePos + -- * Hierarchies + , Hierarchy + , SFMTree(..) + , toTree + , fromTree + , mapField + , searchField + ) where + +import Data.Char (isSpace) +import Data.Maybe (fromMaybe) +import Data.Void (Void) + +import Text.Megaparsec +import Text.Megaparsec.Char + +import qualified Data.Map as M + +-- | A single field of an SFM file. +data Field = Field + { fieldMarker :: String + -- ^ The field marker, ommitting the initial backslash + , fieldWhitespace :: String + -- ^ Whitespace after the field marker + , fieldSourcePos :: Maybe SourcePos + -- ^ Optionally, a Megaparsec 'SourcePos' marking the start of the value + , fieldValue :: String + -- ^ The value of the field, including all whitespace until the next marker + } deriving (Show) + +-- | An SFM file, being a list of fields. +type SFM = [Field] + +-- | Set the 'fieldSourcePos' of a 'Field' to 'Nothing'. Useful for +-- making debug output shorter. +stripSourcePos :: Field -> Field +stripSourcePos f = f { fieldSourcePos = Nothing } + +type Parser = Parsec Void String + +sc :: Parser String +sc = fmap (fromMaybe "") $ optional $ + takeWhile1P (Just "white space") ((&&) <$> isSpace <*> (/='\n')) + +-- | Parse until the next backslash at the beginning of a line. +parseFieldValue :: Parser String +parseFieldValue = do + val <- takeWhileP Nothing (/= '\n') + observing (char '\n') >>= \case + Left _ -> val <$ eof + Right _ -> do + let val' = val++"\n" + -- parse more lines if no following backslash + (notFollowedBy (char '\\') *> ((val'++) <$> parseFieldValue)) + <|> pure val' + +entry :: Parser (String, String, SourcePos, String) +entry = do + _ <- char '\\' + marker <- takeWhile1P (Just "field name") (not . isSpace) + s <- sc + ps <- getSourcePos + value <- parseFieldValue + pure (marker, s, ps, value) + +-- | Parse an SFM file to an 'SFM'. +parseSFM + :: String -- ^ Name of source file + -> String -- ^ Input SFM data to parse + -> Either (ParseErrorBundle String Void) SFM +parseSFM = runParser (sc *> many (toField <$> entry) <* eof) + where + toField (f, s, p, v) = Field f s (Just p) v + +-- | Print a single field as 'String'. +exactPrintField :: Field -> String +exactPrintField f = '\\' : fieldMarker f ++ fieldWhitespace f ++ fieldValue f + +-- | Given an 'SFM', reconstruct the original file. A trivial wrapper +-- around 'exactPrintField'. +exactPrintSFM :: SFM -> String +exactPrintSFM = concatMap exactPrintField + +-- | Rose tree describing a hierarchical SFM document. +data SFMTree + = Root [SFMTree] -- ^ Root node + | Filled Field [SFMTree] -- ^ A 'Field' with zero or more children. + | Missing String [SFMTree] + -- ^ A missing level of the hierarchy: a marker which is inferred + -- from the presence of its children. + deriving (Show) + +-- | The hierarchy underlying an SFM document, defined as a map from +-- field names to their parents. Unlisted fields are treated as roots. +type Hierarchy = M.Map String String + +-- | Returns the full hierarchy of a marker, starting with its +-- immediate parent and finishing with the root. +hierarchyFor :: Hierarchy -> String -> [String] +hierarchyFor h = go + where + go :: String -> [String] + go m = case M.lookup m h of + Just m' -> m' : go m' + Nothing -> [] + +(<+:>) :: SFMTree -> SFMTree -> SFMTree +(Root s) <+:> t = Root (s ++ [t]) +(Filled f s) <+:> t = Filled f (s ++ [t]) +(Missing f s) <+:> t = Missing f (s ++ [t]) + +-- | Use a 'Hierarchy' to generate a tree structure from an 'SFM' +-- document. Fields are converted to 'Filled' nodes, containing as +-- many following nodes as possible, until the next node which is at +-- the same level of the hierarchy or lower. 'Missing' nodes are +-- created for any missing levels of the hierarchy. +toTree :: Hierarchy -> SFM -> SFMTree +toTree h = fst . go (Root []) + where + go :: SFMTree -> SFM -> (SFMTree, SFM) + go t [] = (t, []) + go s@(Root _) (f:fs) = + let (subtree, fs') = go (Filled f []) fs + in go (s <+:> subtree) fs' + go s (f:fs) = + let parentMarker = case s of + Filled (Field{fieldMarker=m}) _ -> m + Missing m _ -> m + hierarchy = hierarchyFor h (fieldMarker f) + in case break (==parentMarker) hierarchy of + -- this marker is unrelated to parentMarker, need to + -- rewind back up the tree and try again + (_, []) -> (s, f:fs) + + -- otherwise this marker belongs somewhere under + -- parentMarker + + -- if it is an immediate child, add the subtree directly + ([], _) -> + let (subtree, fs') = go (Filled f []) fs + in go (s <+:> subtree) fs' + + -- otherwise, recurse into the hierarchy + (m:_, _) -> + let (subtree, fs') = go (Missing m []) (f:fs) + in go (s <+:> subtree) fs' + +-- | Inverse of 'toTree': convert an 'SFMTree' back into a linear +-- 'SFM' document. +fromTree :: SFMTree -> SFM +fromTree (Root s) = concatMap fromTree s +fromTree (Filled f s) = f : concatMap fromTree s +fromTree (Missing _ s) = concatMap fromTree s + +-- | Map a function over all the 'Field's in an 'SFMTree'. +mapField :: (Field -> Field) -> SFMTree -> SFMTree +mapField g (Root s) = Root $ mapField g <$> s +mapField g (Filled f s) = Filled (g f) $ mapField g <$> s +mapField g (Missing m s) = Missing m $ mapField g <$> s + +-- | Depth-first search for fields under an 'SFMTree'. +searchField :: (Field -> Maybe a) -> SFMTree -> [a] +searchField p (Root ts) = searchField p =<< ts +searchField p (Filled f ts) + | Just a <- p f = a : (searchField p =<< ts) + | otherwise = searchField p =<< ts +searchField p (Missing _ ts) = searchField p =<< ts diff --git a/src/Brassica/SoundChange/Apply/Internal.hs b/src/Brassica/SoundChange/Apply/Internal.hs --- a/src/Brassica/SoundChange/Apply/Internal.hs +++ b/src/Brassica/SoundChange/Apply/Internal.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} @@ -18,7 +19,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} {-| __Warning:__ This module is __internal__, and does __not__ follow the Package Versioning Policy. It may be useful for extending @@ -26,9 +26,11 @@ this module. -} module Brassica.SoundChange.Apply.Internal - ( -- * Types - RuleTag(..) + ( -- * Lexeme matching + RuleTag(..) + , RuleStatus(..) + , MatchOutput(..) , match , matchMany , matchMany' @@ -84,9 +86,9 @@ -- too). newtype RuleAp a = RuleAp { runRuleAp :: MultiZipper RuleTag Grapheme -> [(a, MultiZipper RuleTag Grapheme)] } deriving (Functor, Applicative, Monad, MonadState (MultiZipper RuleTag Grapheme) -#if __GLASGOW_HASKELL__ > 806 + , MonadFail -#endif + ) via (StateT (MultiZipper RuleTag Grapheme) []) @@ -115,6 +117,10 @@ matchedCatIxs :: [Int] -- | For each optional group whether it matched or not , matchedOptionals :: [Bool] + -- | For each wildcard, the graphemes which it matched + , matchedWildcards :: [[Grapheme]] + -- | For each Kleene star, how many repititions it matched + , matchedKleenes :: [Int] -- | The graphemes which were matched , matchedGraphemes :: [Grapheme] } deriving (Show) @@ -126,45 +132,50 @@ appendGrapheme out g = modifyMatchedGraphemes (++[g]) out instance Semigroup MatchOutput where - (MatchOutput a1 b1 c1) <> (MatchOutput a2 b2 c2) = MatchOutput (a1++a2) (b1++b2) (c1++c2) + (MatchOutput a1 b1 c1 d1 e1) <> (MatchOutput a2 b2 c2 d2 e2) = + MatchOutput (a1++a2) (b1++b2) (c1++c2) (d1++d2) (e1++e2) zipWith' :: [a] -> [b] -> (a -> b -> c) -> [c] zipWith' xs ys f = zipWith f xs ys +-- Note: see c37afd7028afd4f610d8701799fb6857e2f9b3d9 +-- for motivation for the below functions + +insertAt :: Int -> a -> [a] -> [a] +insertAt n a as = let (xs,ys) = splitAt n as in xs ++ (a:ys) + +insertAtCat :: Int -> Int -> MatchOutput -> MatchOutput +insertAtCat n i mz = mz { matchedCatIxs = insertAt n i $ matchedCatIxs mz } + +insertAtKleene :: Int -> Int -> MatchOutput -> MatchOutput +insertAtKleene n i mz = mz { matchedKleenes = insertAt n i $ matchedKleenes mz } + -- | Match a single 'Lexeme' against a 'MultiZipper', and advance the -- 'MultiZipper' past the match. For each match found, returns the -- 'MatchOutput' tupled with the updated 'MultiZipper'. -match :: forall a t. - OneOf a 'Target 'Env - => MatchOutput -- ^ The previous 'MatchOutput' +match :: MatchOutput -- ^ The previous 'MatchOutput' -> Maybe Grapheme -- ^ The previously-matched grapheme, if any. (Used to match a 'Geminate'.) - -> Lexeme Expanded a -- ^ The lexeme to match. + -> Lexeme Expanded 'Matched -- ^ The lexeme to match. -> MultiZipper t Grapheme -- ^ The 'MultiZipper' to match against. -> [(MatchOutput, MultiZipper t Grapheme)] -- ^ The output: a tuple @(g, mz)@ as described below. match out prev (Optional l) mz = - (out <> MatchOutput [] [False] [], mz) : - matchMany (out <> MatchOutput [] [True] []) prev l mz -match out prev w@(Wildcard l) mz = case match out prev l mz of - [] -> maybeToList (consume mz) >>= \case - (GBoundary, _) -> [] -- don't continue past word boundary - (g, mz') -> match (appendGrapheme out g) prev w mz' - r -> r -match out prev k@(Kleene l) mz = case match out prev l mz of - [] -> [(MatchOutput [] [] [], mz)] - r -> r >>= \(out', mz') -> case match out' prev k mz' of - [] -> error "match: Kleene should never fail" - r' -> r' -match out _ (Grapheme g) mz = (out <> MatchOutput [] [] [g],) <$> maybeToList (matchGrapheme g mz) + (out <> MatchOutput [] [False] [] [] [], mz) : + matchMany (out <> MatchOutput [] [True] [] [] []) prev l mz +match out prev (Wildcard l) mz = matchWildcard out prev l mz +match out prev (Kleene l) mz = matchKleene out prev l mz +match out _ (Grapheme g) mz = (out <> MatchOutput [] [] [] [] [g],) <$> maybeToList (matchGrapheme g mz) match out prev (Category (FromElements gs)) mz = concat $ zipWith' gs [0..] $ \e i -> - first (<> MatchOutput [i] [] []) <$> + -- make sure to insert new index BEFORE any new ones which + -- might be added by the recursive call + first (insertAtCat (length $ matchedCatIxs out) i) <$> case e of Left g -> match out prev (Grapheme g :: Lexeme Expanded a) mz Right ls -> matchMany out prev ls mz match out prev Geminate mz = case prev of Nothing -> [] - Just prev' -> (out <> MatchOutput [] [] [prev'],) <$> maybeToList (matchGrapheme prev' mz) + Just prev' -> (out <> MatchOutput [] [] [] [] [prev'],) <$> maybeToList (matchGrapheme prev' mz) match out prev (Backreference i (FromElements gs)) mz = do e <- maybeToList $ (gs !?) =<< matchedCatIxs out !? (i-1) @@ -172,6 +183,40 @@ Left g -> match out prev (Grapheme g :: Lexeme Expanded a) mz Right ls -> matchMany out prev ls mz +matchKleene + :: MatchOutput + -> Maybe Grapheme + -> Lexeme Expanded 'Matched + -> MultiZipper t Grapheme + -> [(MatchOutput, MultiZipper t Grapheme)] +matchKleene origOut = go 0 origOut + where + go !n out prev l mz = case match out prev l mz of + [] -> [ + ( insertAtKleene (length $ matchedKleenes origOut) n out + , mz + ) ] + r -> r >>= \(out', mz') -> go (n+1) out' prev l mz' + +matchWildcard + :: MatchOutput + -> Maybe Grapheme + -> Lexeme Expanded 'Matched + -> MultiZipper t Grapheme + -> [(MatchOutput, MultiZipper t Grapheme)] +matchWildcard = go [] + where + go matched out prev l mz = case match out prev l mz of + [] -> maybeToList (consume mz) >>= \case + (GBoundary, _) -> [] -- don't continue past word boundary + (g, mz') -> go (g:matched) (appendGrapheme out g) prev l mz' + r -> r <&> \(out', mz') -> + ( out' + { matchedWildcards = matchedWildcards out' ++ [reverse matched] + } + , mz' + ) + matchGrapheme :: Grapheme -> MultiZipper t Grapheme -> Maybe (MultiZipper t Grapheme) matchGrapheme g = matchGraphemeP (==g) @@ -182,10 +227,9 @@ -- 'MultiZipper'. Arguments and output are the same as with 'match', -- though the outputs are given as a list of indices and graphemes -- rather than as a single index and grapheme. -matchMany :: OneOf a 'Target 'Env - => MatchOutput +matchMany :: MatchOutput -> Maybe Grapheme - -> [Lexeme Expanded a] + -> [Lexeme Expanded 'Matched] -> MultiZipper t Grapheme -> [(MatchOutput, MultiZipper t Grapheme)] matchMany out _ [] mz = [(out, mz)] @@ -194,12 +238,11 @@ matchMany out' (lastMay (matchedGraphemes out') <|> prev) ls mz' -- | 'matchMany' without any previous match output. -matchMany' :: OneOf a 'Target 'Env - => Maybe Grapheme - -> [Lexeme Expanded a] +matchMany' :: Maybe Grapheme + -> [Lexeme Expanded 'Matched] -> MultiZipper t Grapheme -> [(MatchOutput, MultiZipper t Grapheme)] -matchMany' = matchMany (MatchOutput [] [] []) +matchMany' = matchMany (MatchOutput [] [] [] [] []) -- Small utility function, not exported lastMay :: [a] -> Maybe a @@ -208,6 +251,8 @@ data ReplacementIndices = ReplacementIndices { ixInCategories :: Int , ixInOptionals :: Int + , ixInWildcards :: Int + , ixInKleenes :: Int , forcedCategory :: Maybe CategoryNumber } deriving (Show) @@ -229,6 +274,16 @@ let i = ixInOptionals ix in (i, ix { ixInOptionals = i+1 }) +advanceWildcard :: ReplacementIndices -> (Int, ReplacementIndices) +advanceWildcard ix = + let i = ixInWildcards ix + in (i, ix { ixInWildcards = i+1 }) + +advanceKleene :: ReplacementIndices -> (Int, ReplacementIndices) +advanceKleene ix = + let i = ixInKleenes ix + in (i, ix { ixInKleenes = i+1 }) + forceCategory :: CategoryNumber -> ReplacementIndices -> ReplacementIndices forceCategory i ixs = ixs { forcedCategory = Just i } @@ -247,7 +302,7 @@ -> [MultiZipper t Grapheme] mkReplacement out = \ls -> fmap (fst . snd) . go startIxs ls . (,Nothing) where - startIxs = ReplacementIndices 0 0 Nothing + startIxs = ReplacementIndices 0 0 0 0 Nothing go :: ReplacementIndices @@ -271,11 +326,12 @@ replaceLex ixs (Category (FromElements gs)) mz prev = case advanceCategory ixs numCatsMatched of (CategoryNumber ci, ixs') -> - let i = matchedCatIxs out !! ci in - case gs !? i of - Just (Left g) -> [(ixs', (insert g mz, Just g))] - Just (Right ls) -> go ixs' ls (mz, prev) - Nothing -> [(ixs', (insert (GMulti "\xfffd") mz, Nothing))] -- Unicode replacement character + case matchedCatIxs out !? ci of + Just i | Just g' <- gs !? i -> + case g' of + Left g -> [(ixs', (insert g mz, Just g))] + Right ls -> go ixs' ls (mz, prev) + _ -> [(ixs', (insert (GMulti "\xfffd") mz, Nothing))] -- Unicode replacement character (Nondeterministic, ixs') -> gs >>= \case Left g -> [(ixs', (insert g mz, Just g))] Right ls -> go ixs' ls (mz, prev) @@ -301,13 +357,24 @@ replaceLex ixs (Multiple c) mz prev = let ixs' = forceCategory Nondeterministic ixs in replaceLex ixs' (Category c) mz prev + replaceLex ixs (Wildcard l) mz prev = + let (i, ixs') = advanceWildcard ixs + in case matchedWildcards out !? i of + Just w -> go ixs' (fmap Grapheme w ++ [l]) (mz, prev) + -- need to add 'l' here too + Nothing -> replaceLex ixs' l mz prev + replaceLex ixs (Kleene l) mz prev = + let (i, ixs') = advanceKleene ixs + in case matchedKleenes out !? i of + Just n -> go ixs' (replicate n l) (mz, prev) + Nothing -> [(ixs', (mz, prev))] -- | Given a 'Rule' and a 'MultiZipper', determines whether the -- 'exception' of that rule (if any) applies starting at the current -- position of the 'MultiZipper'; if it does, returns the index of the -- first element of each matching 'target'. exceptionAppliesAtPoint - :: [Lexeme Expanded 'Target] + :: [Lexeme Expanded 'Matched] -> Environment Expanded -> MultiZipper RuleTag Grapheme -> [Int] exceptionAppliesAtPoint target (ex1, ex2) mz = fmap fst $ flip runRuleAp mz $ do @@ -323,7 +390,7 @@ -- t'Grapheme's, and @is@ is a list of indices, one for each -- 'Category' lexeme matched. matchRuleAtPoint - :: [Lexeme Expanded 'Target] + :: [Lexeme Expanded 'Matched] -> Environment Expanded -> MultiZipper RuleTag Grapheme -> [(MatchOutput, MultiZipper RuleTag Grapheme)] @@ -341,13 +408,19 @@ _ <- RuleAp $ matchMany env1Out (listToMaybe $ matchedGraphemes matchResult) env2 return matchResult +data RuleStatus + = SuccessNormal -- ^ Rule was successful, no need for special handling + | SuccessEpenthesis -- ^ Rule was successful, but cursor was not advanced: need to avoid infinite loop + | Failure -- ^ Rule failed + deriving (Eq, Show) + -- | Given a 'Rule', determine if the rule matches at the current -- point; if so, apply the rule, adding appropriate tags. -applyOnce :: Rule Expanded -> StateT (MultiZipper RuleTag Grapheme) [] Bool +applyOnce :: Rule Expanded -> StateT (MultiZipper RuleTag Grapheme) [] RuleStatus applyOnce r@Rule{target, replacement, exception} = modify (tag AppStart) >> go (environment r) where - go [] = return False + go [] = return Failure go (env:envs) = do result <- try (matchRuleAtPoint target env) case result of @@ -358,32 +431,41 @@ extend' (exceptionAppliesAtPoint target ex) gets (locationOf TargetStart) >>= \p -> if maybe True (`elem` exs) p - then return False + then return Failure else do + originalWord <- get modifyMay $ delete (TargetStart, TargetEnd) modifyMay $ seek TargetStart - modifyM $ mkReplacement out replacement - return True + modifyM $ \w -> + let replacedWords = mkReplacement out replacement w + in case sporadic (flags r) of + -- make sure to re-insert original word + PerApplication -> originalWord : replacedWords + _ -> replacedWords + return $ + -- An epenthesis rule will cause an infinite loop + -- if it matched no graphemes before the replacement + if null (matchedGraphemes out) && null (fst env) + then SuccessEpenthesis + else SuccessNormal Nothing -> modifyMay (seek AppStart) >> go envs -- | Remove tags and advance the current index to the next t'Grapheme' -- after the rule application. setupForNextApplication - :: Bool + :: RuleStatus -> Rule Expanded -> MultiZipper RuleTag Grapheme -> Maybe (MultiZipper RuleTag Grapheme) -setupForNextApplication success r@Rule{flags=Flags{applyDirection}} = +setupForNextApplication status Rule{flags=Flags{applyDirection}} = fmap untag . case applyDirection of RTL -> seek AppStart >=> bwd - LTR -> - if success - then - if null (target r) - then -- need to move forward if applying an epenthesis rule to avoid an infinite loop - seek TargetEnd >=> fwd - else seek TargetEnd - else seek AppStart >=> fwd + LTR -> case status of + SuccessNormal -> seek TargetEnd + SuccessEpenthesis -> + -- need to move forward if applying an epenthesis rule to avoid an infinite loop + seek TargetEnd >=> fwd + Failure -> seek AppStart >=> fwd -- | Apply a 'Rule' to a 'MultiZipper'. The application will start at -- the beginning of the 'MultiZipper', and will be repeated as many @@ -394,21 +476,31 @@ LTR -> toBeginning mz RTL -> toEnd mz result = repeatRule (applyOnce r) startingPos - in if sporadic $ flags r - then mz : result - else result + in case sporadic (flags r) of + PerWord -> mz : result + _ -> result -- PerApplication handled in 'applyOnce' where repeatRule - :: StateT (MultiZipper RuleTag Grapheme) [] Bool + :: StateT (MultiZipper RuleTag Grapheme) [] RuleStatus -> MultiZipper RuleTag Grapheme -> [MultiZipper RuleTag Grapheme] - repeatRule m mz = runStateT m mz >>= \(success, mz') -> - if success && applyOnceOnly (flags r) + repeatRule m mz = runStateT m mz >>= \(status, mz') -> + if (status /= Failure) && applyOnceOnly (flags r) then [mz'] - else case setupForNextApplication success r mz' of + else case setupForNextApplication status r mz' of Just mz'' -> repeatRule m mz'' Nothing -> [mz'] +-- | Check if a 'MultiZipper' matches a 'Filter'. +filterMatches :: Filter Expanded -> MultiZipper RuleTag Grapheme -> Bool +filterMatches (Filter _ ls) = go . toBeginning + where + go mz = + let mzs = matchMany' Nothing ls mz + in case mzs of + [] -> maybe False go $ fwd mz -- try next position if there is one + _ -> True -- filter has matched + -- | Check that the 'MultiZipper' contains only graphemes listed in -- the given 'CategoriesDecl', replacing all unlisted graphemes with -- U+FFFD. @@ -417,13 +509,16 @@ GBoundary -> GBoundary g -> if g `elem` gs then g else GMulti "\xfffd" --- | Apply a 'Statement' to a 'MultiZipper'. This is a simple wrapper --- around 'applyRule' and 'checkGraphemes'. +-- | Apply a 'Statement' to a 'MultiZipper', returning zero, one or +-- more results. applyStatement :: Statement Expanded [Grapheme] -> MultiZipper RuleTag Grapheme -> [MultiZipper RuleTag Grapheme] applyStatement (RuleS r) mz = applyRule r mz +applyStatement (FilterS f) mz + | filterMatches f mz = [] + | otherwise = [mz] applyStatement (DirectiveS gs) mz = [checkGraphemes gs mz] -- | Apply a single 'Rule' to a word. @@ -433,7 +528,12 @@ -- directly. applyRuleStr :: Rule Expanded -> PWord -> [PWord] -- Note: 'fromJust' is safe here as 'apply' should always succeed -applyRuleStr r s = nubOrd $ fmap toList $ applyRule r $ fromListStart s +applyRuleStr r = + addBoundaries + >>> fromListStart + >>> applyRule r + >>> fmap (toList >>> removeBoundaries) + >>> nubOrd -- | Apply a single 'Statement' to a word. -- @@ -454,7 +554,7 @@ data LogItem r = ActionApplied { action :: r , input :: PWord - , output :: PWord + , output :: Maybe PWord } deriving (Show, Functor, Generic, NFData) -- | Logs the evolution of a 'PWord' as various actions are applied to @@ -462,7 +562,7 @@ data PWordLog r = PWordLog { initialWord :: PWord -- ^ The initial word, before any actions have been applied - , derivations :: [(PWord, r)] + , derivations :: [(Maybe PWord, r)] -- ^ The state of the word after each action @r@, stored alongside -- the action which was applied at each point } deriving (Show, Functor, Generic, NFData) @@ -495,7 +595,7 @@ go _ [] = "" go cell1 ((output, action) : ds) = ("" ++ cell1 ++ "→" - ++ concatWithBoundary output + ++ maybe "deleted" concatWithBoundary output ++ "(" ++ render action ++ ")") ++ go "" ds @@ -518,8 +618,10 @@ reportAsText render item = unlines $ concatWithBoundary (initialWord item) : fmap toLine (alignWithPadding $ derivations item) where + alignWithPadding :: [(Maybe PWord, b)] -> [([Char], b)] alignWithPadding ds = - let (fmap concatWithBoundary -> outputs, actions) = unzip ds + let (rawOutputs, actions) = unzip ds + outputs = maybe "(deleted)" concatWithBoundary <$> rawOutputs maxlen = maximum $ length <$> outputs padded = outputs <&> \o -> o ++ replicate (maxlen - length o) ' ' in zip padded actions @@ -534,8 +636,9 @@ -> PWord -> [LogItem (Statement Expanded [Grapheme])] applyStatementWithLog st w = case applyStatementStr st w of - [w'] -> if w' == w then [] else [ActionApplied st w w'] - r -> ActionApplied st w <$> r + [] -> [ActionApplied st w Nothing] + [w'] | w' == w -> [] + r -> ActionApplied st w . Just <$> r -- | Apply 'SoundChanges' to a word. For each possible result, returns -- a 'LogItem' for each 'Statement' which altered the input. @@ -547,8 +650,11 @@ applyChangesWithLog (st:sts) w = case applyStatementWithLog st w of [] -> applyChangesWithLog sts w - items -> items >>= \l@ActionApplied{output=w'} -> - (l :) <$> applyChangesWithLog sts w' + outputActions -> outputActions >>= \l@ActionApplied{output} -> + case output of + Just w' -> (l :) <$> applyChangesWithLog sts w' + -- apply no further changes to a deleted word + Nothing -> [[l]] -- | Apply 'SoundChanges' to a word, returning an 'PWordLog' -- for each possible result. @@ -561,20 +667,22 @@ -- | Apply a set of 'SoundChanges' to a word. applyChanges :: SoundChanges Expanded [Grapheme] -> PWord -> [PWord] applyChanges sts w = - lastOutput <$> applyChangesWithLog sts w + mapMaybe lastOutput $ applyChangesWithLog sts w where - lastOutput [] = w + -- If no changes were applied, output is same as input + lastOutput [] = Just w lastOutput ls = output $ last ls -- | Apply 'SoundChanges' to a word returning the final results, as -- well as a boolean value indicating whether the word should be -- highlighted in a UI due to changes from its initial value. (Note -- that this accounts for 'highlightChanges' values.) -applyChangesWithChanges :: SoundChanges Expanded [Grapheme] -> PWord -> [(PWord, Bool)] +applyChangesWithChanges :: SoundChanges Expanded [Grapheme] -> PWord -> [(Maybe PWord, Bool)] applyChangesWithChanges sts w = applyChangesWithLog sts w <&> \case - [] -> (w, False) + [] -> (Just w, False) logs -> (output $ last logs, hasChanged logs) where hasChanged = any $ \case - ActionApplied{action=RuleS rule} -> highlightChanges $ flags rule - ActionApplied{action=DirectiveS _} -> True + ActionApplied (RuleS rule) _ _ -> highlightChanges $ flags rule + ActionApplied (FilterS _) _ _ -> False -- cannot highlight nonexistent word + ActionApplied (DirectiveS _) _ _ -> True diff --git a/src/Brassica/SoundChange/Category.hs b/src/Brassica/SoundChange/Category.hs --- a/src/Brassica/SoundChange/Category.hs +++ b/src/Brassica/SoundChange/Category.hs @@ -13,17 +13,17 @@ , ExpandError(..) , expand , expandRule - , extend + , extendCategories , expandSoundChanges ) where import Prelude hiding (lookup) import Control.DeepSeq (NFData) import Control.Monad (foldM, unless) -import Control.Monad.State.Strict (StateT, evalStateT, lift, get, put) +import Control.Monad.State.Strict (StateT, evalStateT, lift, get, put, gets) import Data.Containers.ListUtils (nubOrd) import Data.List (intersect, transpose, foldl') -import Data.Maybe (mapMaybe) +import Data.Maybe (mapMaybe, catMaybes) import GHC.Generics (Generic) import qualified Data.Map.Strict as M @@ -115,8 +115,14 @@ <$> traverse (expandLexeme cs) e1 <*> traverse (expandLexeme cs) e2 -extend :: Categories -> Directive -> Either ExpandError Categories -extend cs' (Categories overwrite defs) = +expandFilter :: Categories -> Filter CategorySpec -> Either ExpandError (Filter Expanded) +expandFilter cs (Filter p f) = Filter p <$> traverse (expandLexeme cs) f + +extendCategories + :: Categories + -> (Bool, [CategoryDefinition]) -- ^ The fields of a v'Categories' directive + -> Either ExpandError Categories +extendCategories cs' (overwrite, defs) = foldM go (if overwrite then M.empty else cs') defs where go :: Categories -> CategoryDefinition -> Either ExpandError Categories @@ -146,18 +152,30 @@ expandSoundChanges :: SoundChanges CategorySpec Directive -> Either ExpandError (SoundChanges Expanded [Grapheme]) -expandSoundChanges = flip evalStateT M.empty . traverse go +expandSoundChanges = fmap catMaybes . flip evalStateT (M.empty, []) . traverse go where go :: Statement CategorySpec Directive - -> StateT Categories (Either ExpandError) (Statement Expanded [Grapheme]) + -> StateT + (Categories, [String]) + (Either ExpandError) + (Maybe (Statement Expanded [Grapheme])) go (RuleS r) = do - cs <- get - lift $ RuleS <$> expandRule cs r - go (DirectiveS d) = do - cs <- get - cs' <- lift $ extend cs d - put cs' - pure $ DirectiveS $ mapMaybe left $ values cs' + cs <- gets fst + lift $ Just . RuleS <$> expandRule cs r + go (FilterS f) = do + cs <- gets fst + lift $ Just . FilterS <$> expandFilter cs f + go (DirectiveS (ExtraGraphemes extra)) = do + (cs, _) <- get + put (cs, extra) + pure Nothing + go (DirectiveS (Categories overwrite noreplace defs)) = do + (cs, extra) <- get + cs' <- lift $ extendCategories cs (overwrite, defs) + put (cs', extra) + pure $ if noreplace + then Nothing + else Just $ DirectiveS $ fmap GMulti extra ++ mapMaybe left (values cs') left (Left l) = Just l left (Right _) = Nothing diff --git a/src/Brassica/SoundChange/Frontend/Internal.hs b/src/Brassica/SoundChange/Frontend/Internal.hs --- a/src/Brassica/SoundChange/Frontend/Internal.hs +++ b/src/Brassica/SoundChange/Frontend/Internal.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} {-| __Warning:__ This module is __internal__, and does __not__ follow @@ -10,20 +11,22 @@ -} module Brassica.SoundChange.Frontend.Internal where -import Data.Bifunctor (second) +import Control.Monad ((<=<)) import Data.Maybe (fromMaybe, mapMaybe) import Data.Void (Void) import GHC.Generics (Generic) +import Myers.Diff (getDiff, PolyDiff(..)) import Control.DeepSeq (NFData) import Text.Megaparsec (ParseErrorBundle) -import Brassica.MDF (MDF, parseMDFWithTokenisation, componentiseMDF, componentiseMDFWordsOnly, duplicateEtymologies) +import Brassica.SFM.MDF +import Brassica.SFM.SFM import Brassica.SoundChange.Apply import Brassica.SoundChange.Apply.Internal (applyChangesWithLog, toPWordLog) -import Brassica.SoundChange.Category import Brassica.SoundChange.Tokenise import Brassica.SoundChange.Types +import Data.Bifunctor (first) -- | Rule application mode of the SCA. data ApplicationMode @@ -31,6 +34,10 @@ | ReportRulesApplied deriving (Show, Eq) +getOutputMode :: ApplicationMode -> OutputMode +getOutputMode (ApplyRules _ o _) = o +getOutputMode ReportRulesApplied = WordsOnlyOutput -- default option + data HighlightMode = NoHighlight | DifferentToLastRun @@ -66,21 +73,6 @@ toEnum 3 = WordsWithProtoOutput toEnum _ = undefined -data TokenisationMode = Normal | AddEtymons - deriving (Show, Eq) -instance Enum TokenisationMode where - -- used for conversion to and from C, so want control over values - fromEnum Normal = 0 - fromEnum AddEtymons = 1 - - toEnum 0 = Normal - toEnum 1 = AddEtymons - toEnum _ = undefined - -tokenisationModeFor :: ApplicationMode -> TokenisationMode -tokenisationModeFor (ApplyRules _ MDFOutputWithEtymons _) = AddEtymons -tokenisationModeFor _ = Normal - -- | Output of a single application of rules to a wordlist: either a -- list of possibly highlighted words, an applied rules table, or a -- parse error. @@ -88,7 +80,6 @@ = HighlightedWords [Component (a, Bool)] | AppliedRulesTable [PWordLog r] | ParseError (ParseErrorBundle String Void) - | ExpandError ExpandError deriving (Show, Generic, NFData) -- | Kind of input: either a raw wordlist, or an MDF file. @@ -103,16 +94,12 @@ toEnum 1 = MDF toEnum _ = undefined -data ParseOutput a = ParsedRaw [Component a] | ParsedMDF (MDF [Component a]) - deriving (Show, Functor) +data ParseOutput a = ParsedRaw [Component a] | ParsedMDF SFM + deriving (Show, Functor, Foldable, Traversable) -componentise :: OutputMode -> [a] -> ParseOutput a -> [Component a] -componentise WordsWithProtoOutput ws (ParsedRaw cs) = intersperseWords ws cs -componentise _ _ (ParsedRaw cs) = cs -componentise MDFOutput _ (ParsedMDF mdf) = componentiseMDF mdf -componentise MDFOutputWithEtymons _ (ParsedMDF mdf) = componentiseMDF mdf -componentise WordsOnlyOutput _ (ParsedMDF mdf) = componentiseMDFWordsOnly mdf -componentise WordsWithProtoOutput ws (ParsedMDF mdf) = intersperseWords ws $ componentiseMDFWordsOnly mdf +componentise :: OutputMode -> [a] -> [Component a] -> [Component a] +componentise WordsWithProtoOutput ws cs = intersperseWords ws cs +componentise _ _ cs = cs intersperseWords :: [a] -> [Component a] -> [Component a] intersperseWords (w:ws) (Word c:cs) = @@ -123,87 +110,76 @@ tokeniseAccordingToInputFormat :: InputLexiconFormat - -> TokenisationMode + -> OutputMode -> SoundChanges Expanded [Grapheme] -> String - -> Either (ParseErrorBundle String Void) (ParseOutput PWord) + -> Either (ParseErrorBundle String Void) [Component PWord] tokeniseAccordingToInputFormat Raw _ cs = - fmap ParsedRaw . withFirstCategoriesDecl tokeniseWords cs -tokeniseAccordingToInputFormat MDF Normal cs = - fmap ParsedMDF . withFirstCategoriesDecl parseMDFWithTokenisation cs -tokeniseAccordingToInputFormat MDF AddEtymons cs = - fmap ParsedMDF - . second (duplicateEtymologies $ ('*':) . detokeniseWords) - . withFirstCategoriesDecl parseMDFWithTokenisation cs - -getParsedWords :: ParseOutput a -> [a] -getParsedWords (ParsedRaw cs) = getWords cs -getParsedWords (ParsedMDF mdf) = getWords $ componentiseMDF mdf + withFirstCategoriesDecl tokeniseWords cs +tokeniseAccordingToInputFormat MDF MDFOutputWithEtymons cs = + withFirstCategoriesDecl tokeniseMDF cs <=< + -- TODO don't hard-code hierarchy and filename + fmap (fromTree . duplicateEtymologies ('*':) . toTree mdfHierarchy) + . parseSFM "" +tokeniseAccordingToInputFormat MDF o cs = \input -> do + sfm <- parseSFM "" input + ws <- withFirstCategoriesDecl tokeniseMDF cs sfm + pure $ case o of + MDFOutput -> ws + _ -> -- need to extract words for other output modes + Word <$> getWords ws -- | Top-level dispatcher for an interactive frontend: given a textual -- wordlist and a list of sound changes, returns the result of running -- the changes in the specified mode. parseTokeniseAndApplyRules - :: SoundChanges CategorySpec Directive -- ^ changes + :: (forall a b. (a -> b) -> [Component a] -> [Component b]) -- ^ mapping function to use (for parallelism) + -> SoundChanges Expanded [Grapheme] -- ^ changes -> String -- ^ words -> InputLexiconFormat -> ApplicationMode -> Maybe [Component PWord] -- ^ previous results -> ApplicationOutput PWord (Statement Expanded [Grapheme]) -parseTokeniseAndApplyRules statements ws intype mode prev = - case expandSoundChanges statements of - Left e -> ExpandError e - Right statements' -> - let tmode = tokenisationModeFor mode in - case tokeniseAccordingToInputFormat intype tmode statements' ws of - Left e -> ParseError e - Right toks - | ws' <- getParsedWords toks - -> case mode of - ReportRulesApplied -> - AppliedRulesTable $ mapMaybe toPWordLog $ concat $ - getWords $ componentise WordsOnlyOutput [] $ - applyChangesWithLog statements' <$> toks - ApplyRules DifferentToLastRun mdfout sep -> - let result = concatMap (splitMultipleResults sep) $ - componentise mdfout (fmap pure ws') $ applyChanges statements' <$> toks - in HighlightedWords $ - zipWithComponents result (fromMaybe [] prev) [] $ \thisWord prevWord -> - (thisWord, thisWord /= prevWord) - ApplyRules DifferentToInput mdfout sep -> - HighlightedWords $ concatMap (splitMultipleResults sep) $ - componentise mdfout (fmap (pure . (,False)) ws') $ - applyChangesWithChanges statements' <$> toks - ApplyRules NoHighlight mdfout sep -> - HighlightedWords $ (fmap.fmap) (,False) $ concatMap (splitMultipleResults sep) $ - componentise mdfout (fmap pure ws') $ - applyChanges statements' <$> toks +parseTokeniseAndApplyRules parFmap statements ws intype mode prev = + case tokeniseAccordingToInputFormat intype (getOutputMode mode) statements ws of + Left e -> ParseError e + Right toks + | ws' <- getWords toks + -> case mode of + ReportRulesApplied -> + AppliedRulesTable $ mapMaybe toPWordLog $ concat $ + getWords $ componentise WordsOnlyOutput [] $ + parFmap (applyChangesWithLog statements) toks + ApplyRules DifferentToLastRun mdfout sep -> + let result = concatMap (splitMultipleResults sep) $ + componentise mdfout (fmap pure ws') $ + parFmap (applyChanges statements) toks + in HighlightedWords $ + mapMaybe polyDiffToHighlight $ getDiff (fromMaybe [] prev) result + -- zipWithComponents result (fromMaybe [] prev) [] $ \thisWord prevWord -> + -- (thisWord, thisWord /= prevWord) + ApplyRules DifferentToInput mdfout sep -> + HighlightedWords $ concatMap (splitMultipleResults sep) $ + (fmap.fmap) (mapMaybe extractMaybe) $ + componentise mdfout (fmap (pure . first Just . (,False)) ws') $ + parFmap (applyChangesWithChanges statements) toks + ApplyRules NoHighlight mdfout sep -> + HighlightedWords $ (fmap.fmap) (,False) $ concatMap (splitMultipleResults sep) $ + componentise mdfout (fmap pure ws') $ + parFmap (applyChanges statements) toks where - -- Zips two tokenised input strings. Compared to normal 'zipWith' - -- this has two special properties: - -- - -- * It only zips v'Word's. Any non-v'Word's in the first argument - -- will be passed unaltered to the output; any in the second - -- argument will be ignored. - -- - -- * The returned list will have the same number of elements as does - -- the first argument. If a v'Word' in the first argument has no - -- corresponding v'Word' in the second, the zipping function is - -- called using the default @b@ value given as the third argument. - -- Such a v'Word' in the second argument will simply be ignored. - -- - -- Note the persistent assymetry in the definition: each 'Component' - -- in the first argument will be reflected in the output, but each in - -- the second argument may be ignored. - zipWithComponents :: [Component a] -> [Component b] -> b -> (a -> b -> c) -> [Component c] - zipWithComponents [] _ _ _ = [] - zipWithComponents as [] bd f = (fmap.fmap) (`f` bd) as - zipWithComponents (Word a:as) (Word b:bs) bd f = Word (f a b) : zipWithComponents as bs bd f - zipWithComponents as@(Word _:_) (_:bs) bd f = zipWithComponents as bs bd f - zipWithComponents (a:as) bs@(Word _:_) bd f = unsafeCastComponent a : zipWithComponents as bs bd f - zipWithComponents (a:as) (_:bs) bd f = unsafeCastComponent a : zipWithComponents as bs bd f + -- highlight words in 'Second' but not 'First' + polyDiffToHighlight :: PolyDiff (Component a) (Component a) -> Maybe (Component (a, Bool)) + polyDiffToHighlight (First _) = Nothing + polyDiffToHighlight (Second (Word a)) = Just $ Word (a, True) + polyDiffToHighlight (Second c) = Just $ unsafeCastComponent c + polyDiffToHighlight (Both _ (Word a)) = Just $ Word (a, False) + polyDiffToHighlight (Both _ c) = Just $ unsafeCastComponent c unsafeCastComponent :: Component a -> Component b unsafeCastComponent (Word _) = error "unsafeCastComponent: attempted to cast a word!" unsafeCastComponent (Separator s) = Separator s unsafeCastComponent (Gloss s) = Gloss s + + extractMaybe (Just a, b) = Just (a, b) + extractMaybe (Nothing, _) = Nothing diff --git a/src/Brassica/SoundChange/Parse.hs b/src/Brassica/SoundChange/Parse.hs --- a/src/Brassica/SoundChange/Parse.hs +++ b/src/Brassica/SoundChange/Parse.hs @@ -117,15 +117,22 @@ <|> pure Union parseDirective :: Parser Directive -parseDirective = do - overwrite <- isJust <$> optional (symbol "new") - _ <- symbol "categories" <* scn - cs <- some $ - DefineFeature <$> parseFeature <|> - uncurry DefineCategory <$> (try parseCategoryStandalone <* scn) - _ <- symbol "end" <* scn - pure $ Categories overwrite cs +parseDirective = parseCategoriesDirective <|> parseExtraDirective + where + parseExtraDirective = fmap ExtraGraphemes $ + symbol "extra" *> many parseGrapheme' <* scn + parseCategoriesDirective = do + overwrite <- isJust <$> optional (symbol "new") + _ <- symbol "categories" + noreplace <- isJust <$> optional (symbol "noreplace") + scn + cs <- some $ + DefineFeature <$> parseFeature <|> + uncurry DefineCategory <$> (try parseCategoryStandalone <* scn) + _ <- symbol "end" <* scn + pure $ Categories overwrite noreplace cs + parseOptional :: ParseLexeme a => Parser (Lexeme CategorySpec a) parseOptional = Optional <$> between (symbol "(") (symbol ")") (some parseLexeme) @@ -135,13 +142,13 @@ parseMetathesis :: Parser (Lexeme CategorySpec 'Replacement) parseMetathesis = Metathesis <$ symbol "\\" -parseWildcard :: (ParseLexeme a, OneOf a 'Target 'Env) => Parser (Lexeme CategorySpec a) +parseWildcard :: ParseLexeme a => Parser (Lexeme CategorySpec a) parseWildcard = Wildcard <$> (symbol "^" *> parseLexeme) parseDiscard :: Parser (Lexeme CategorySpec 'Replacement) parseDiscard = Discard <$ symbol "~" -parseKleene :: OneOf a 'Target 'Env => Lexeme CategorySpec a -> Parser (Lexeme CategorySpec a) +parseKleene :: Lexeme CategorySpec a -> Parser (Lexeme CategorySpec a) parseKleene l = try (lexeme $ Kleene l <$ char '*' <* notFollowedBy parseGrapheme') <|> pure l @@ -152,7 +159,7 @@ parseBackreference :: forall a. ParseLexeme a => Parser (Lexeme CategorySpec a) parseBackreference = Backreference <$> (symbol "@" *> nonzero) <*> parseCategory' -instance ParseLexeme 'Target where +instance ParseLexeme 'Matched where parseLexeme = asum [ parseExplicitCategory , parseOptional @@ -170,15 +177,6 @@ , parseDiscard , parseGeminate , parseMultiple - , parseBackreference - , Grapheme <$> parseGrapheme - ] - -instance ParseLexeme 'Env where - parseLexeme = asum - [ parseExplicitCategory - , parseOptional - , parseGeminate , parseWildcard , parseBackreference , Grapheme <$> parseGrapheme @@ -188,8 +186,9 @@ parseLexeme = asum [ parseExplicitCategory , parseOptional + , parseWildcard , Grapheme <$> parseGrapheme - ] + ] >>= parseKleene parseLexemes :: ParseLexeme a => Parser [Lexeme CategorySpec a] parseLexemes = many parseLexeme @@ -199,7 +198,8 @@ <$> toPermutation (isNothing <$> optional (symbol "-x")) <*> toPermutationWithDefault LTR ((LTR <$ symbol "-ltr") <|> (RTL <$ symbol "-rtl")) <*> toPermutation (isJust <$> optional (symbol "-1")) - <*> toPermutation (isJust <$> optional (symbol "-?")) + <*> toPermutationWithDefault ApplyAlways + ((PerApplication <$ symbol "-??") <|> (PerWord <$ symbol "-?")) ruleParser :: Parser (Rule CategorySpec) ruleParser = do @@ -210,8 +210,11 @@ s <- getInput flags <- parseFlags - target <- parseLexemes - _ <- lexeme $ oneOf "/→" + target <- manyTill parseLexeme $ lexeme $ choice + [ string "/" + , string "→" + , string "->" + ] replacement <- parseLexemes envs' <- many $ do @@ -233,10 +236,13 @@ where notNewline c = (c /= '\n') && (c /= '\r') +filterParser :: Parser (Filter CategorySpec) +filterParser = fmap (uncurry Filter) $ match $ symbol "filter" *> parseLexemes <* optional scn + -- | Parse a 'String' in Brassica sound change syntax into a -- 'Rule'. Returns 'Left' if the input string is malformed. -- --- For details on the syntax, refer to . +-- For details on the syntax, refer to . parseRule :: String -> Either (ParseErrorBundle String Void) (Rule CategorySpec) parseRule = runParser (scn *> ruleParser <* eof) "" @@ -246,4 +252,5 @@ where parser = many $ DirectiveS <$> parseDirective + <|> FilterS <$> filterParser <|> RuleS <$> ruleParser diff --git a/src/Brassica/SoundChange/Types.hs b/src/Brassica/SoundChange/Types.hs --- a/src/Brassica/SoundChange/Types.hs +++ b/src/Brassica/SoundChange/Types.hs @@ -14,7 +14,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} module Brassica.SoundChange.Types @@ -39,9 +38,11 @@ , Rule(..) , Environment , Direction(..) + , Sporadicity(..) , Flags(..) , defFlags -- * Statements + , Filter(..) , Statement(..) , plaintext' , SoundChanges @@ -51,34 +52,13 @@ , FeatureSpec(..) , CategoryDefinition(..) , Directive(..) - -- * Utility - , OneOf ) where import Control.DeepSeq (NFData(..)) -import Data.Kind (Constraint) import Data.String (IsString(..)) import GHC.Generics (Generic) import GHC.OldList (dropWhileEnd) -import GHC.TypeLits --- | The constraint @OneOf a x y@ is satisfied if @a ~ x@ or @a ~ y@. --- --- (Note: the strange @() ~ Bool@ constraint is just a simple --- unsatisfiable constraint, so as to not give ‘non-exhaustive pattern --- match’ errors everywhere.) -type family OneOf a x y :: Constraint where - OneOf a a y = () - OneOf a x a = () - OneOf a b c = - ( () ~ Bool - , TypeError ('Text "Couldn't match type " - ':<>: 'ShowType a - ':<>: 'Text " with " - ':<>: 'ShowType b - ':<>: 'Text " or " - ':<>: 'ShowType c)) - -- | The type of graphemes within a word. data Grapheme = GMulti [Char] -- ^ A multigraph: for instance @GMulti "a", GMulti "ch", GMulti "c̓" :: t'Grapheme'@. @@ -115,9 +95,10 @@ GMulti g -> g GBoundary -> "#" --- | The part of a 'Rule' in which a 'Lexeme' may occur: either the --- target, the replacement or the environment, or in any of those. -data LexemeType = Target | Replacement | Env | AnyPart +-- | The part of a 'Rule' in which a 'Lexeme' may occur: in a matched +-- part (target or environment), in replacement, or in either of +-- those. +data LexemeType = Matched | Replacement | AnyPart -- | A 'Lexeme' is the smallest part of a sound change. Both matches -- and replacements are made up of 'Lexeme's: the phantom type @@ -137,9 +118,9 @@ -- | In Brassica sound-change syntax, specified as @>@ Geminate :: Lexeme category a -- | In Brassica sound-change syntax, specified as @^@ before another 'Lexeme' - Wildcard :: OneOf a 'Target 'Env => Lexeme category a -> Lexeme category a + Wildcard :: Lexeme category a -> Lexeme category a -- | In Brassica sound-change syntax, specified as @*@ after another 'Lexeme' - Kleene :: OneOf a 'Target 'Env => Lexeme category a -> Lexeme category a + Kleene :: Lexeme category a -> Lexeme category a -- | In Brassica sound-change syntax, specified as @~@ Discard :: Lexeme category 'Replacement -- | In Brassica sound-change syntax, specified as \@i before a category @@ -191,6 +172,8 @@ generalise f (Optional ls) = Optional $ generalise f <$> ls generalise _ Geminate = Geminate generalise f (Backreference i es) = Backreference i $ f es +generalise f (Wildcard l) = Wildcard $ generalise f l +generalise f (Kleene l) = Kleene $ generalise f l generaliseExpanded :: Expanded 'AnyPart -> Expanded a generaliseExpanded = FromElements . (fmap.fmap.fmap) (generalise generaliseExpanded) . elements @@ -219,19 +202,29 @@ -- corresponding to a ‘/ before _ after’ component of a sound change. -- -- Note that an empty environment is just @([], [])@. -type Environment c = ([Lexeme c 'Env], [Lexeme c 'Env]) +type Environment c = ([Lexeme c 'Matched], [Lexeme c 'Matched]) -- | Specifies application direction of rule — either left-to-right or right-to-left. data Direction = LTR | RTL deriving (Eq, Show, Generic, NFData) +-- | Specifies how regularly a rule should be applied. +data Sporadicity + = ApplyAlways + -- ^ Always apply the rule + | PerWord + -- ^ Apply sporadically, either to the whole word or to none of the word + | PerApplication + -- ^ Apply sporadically, at each application site + deriving (Eq, Show, Generic, NFData) + -- | Flags which can be enabled, disabled or altered on a 'Rule' to -- change how it is applied. data Flags = Flags { highlightChanges :: Bool , applyDirection :: Direction , applyOnceOnly :: Bool - , sporadic :: Bool + , sporadic :: Sporadicity } deriving (Show, Generic, NFData) -- | A default selection of flags which are appropriate for most @@ -253,14 +246,14 @@ { highlightChanges = True , applyDirection = LTR , applyOnceOnly = False - , sporadic = False + , sporadic = ApplyAlways } -- | A single sound change rule: in Brassica sound-change syntax with all elements specified, -- @-flags target / replacement \/ environment1 | environment2 | … \/ exception@. -- (And usually the 'plaintext' of the rule will contain a 'String' resembling that pattern.) data Rule c = Rule - { target :: [Lexeme c 'Target] + { target :: [Lexeme c 'Matched] , replacement :: [Lexeme c 'Replacement] , environment :: [Environment c] , exception :: Maybe (Environment c) @@ -271,11 +264,22 @@ deriving instance (forall a. Show (c a)) => Show (Rule c) deriving instance (forall a. NFData (c a)) => NFData (Rule c) --- | A 'Statement' can be either a single sound change rule, or a --- directive (e.g. category definition). -data Statement c decl = RuleS (Rule c) | DirectiveS decl +-- | A filter, constraining the output to not match the given elements. +-- (The 'String' is the plaintext, as with 'Rule'.) +data Filter c = Filter String [Lexeme c 'Matched] deriving (Generic) +deriving instance (forall a. Show (c a)) => Show (Filter c) +deriving instance (forall a. NFData (c a)) => NFData (Filter c) + +-- | A 'Statement' can be a single sound change rule, a filter, +-- or a directive (e.g. category definition). +data Statement c decl + = RuleS (Rule c) + | FilterS (Filter c) + | DirectiveS decl + deriving (Generic) + deriving instance (forall a. Show (c a), Show decl) => Show (Statement c decl) deriving instance (forall a. NFData (c a), NFData decl) => NFData (Statement c decl) @@ -283,6 +287,7 @@ -- @""@ for all 'DirectiveS' inputs. plaintext' :: Statement c decl -> String plaintext' (RuleS r) = plaintext r +plaintext' (FilterS (Filter p _)) = p plaintext' (DirectiveS _) = "" -- | A set of 'SoundChanges' is simply a list of 'Statement's. @@ -314,7 +319,13 @@ | DefineFeature FeatureSpec deriving (Show, Eq, Ord, Generic, NFData) --- | A directive used in Brassica sound-change syntax: currently only --- @categories … end@ or @new categories … end@ -data Directive = Categories Bool [CategoryDefinition] +-- | A directive used in Brassica sound-change syntax: anything which +-- is not actually a sound change + +data Directive + = Categories Bool Bool [CategoryDefinition] + -- ^ @categories … end@: first 'Bool' for @new@, + -- second for @noreplace@ + | ExtraGraphemes [String] + -- ^ @extra …@ deriving (Show, Eq, Ord, Generic, NFData)