diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,127 @@ # Brassica changelog +## 1.0.0 + +### Behaviour + +(Note: breaking changes are boldfaced.) + +- Bugfixes: + - Etymologies are now added in all situations when processing an MDF file + - Desktop version correctly warns about unsaved changes when opening a file + - Rules such as `[p f] / [f h] / (a) _ #` are no longer applied twice to the same grapheme + (as a consequence of changes to rule application, see below) + - `noreplace` categories now tokenise multigraphs as expected +- Documentation (user guides and Haddocks) have been comprensively rewritten +- ‘Tonogenesis’ example has been replaced by ‘Thai’ example +- New support for phonetic features: + - Features can be written as maximal `$name#ident(values)` after another lexeme + - Categories named `+Feature`, `-Feature` and `+Feature+Value` + get special interpretation with intersections and subtractions + - New category syntax: `&` before category name forces union interpretation + even for category names beginning with `+`/`-` + - Change to category syntax: first element of category is always interpreted as union + (**technically a breaking change**, but unlikely in existing sound changes) + - Syntax `&Feature` after set operation (`&`/`+`/`-`) to include both `-Feature` and `+Feature` + (i.e. all graphemes with a setting for that feature) + - Declaration `auto ` in category definition block + can be used to treat said feature autosegmentally + whenever a grapheme in the selected category is mentioned +- Other changes to sound change syntax: + - `report` directive allows for reporting intermediate results in input→output mode + - Graphemes followed by `~` are now allowed inside a category block, + but **disallowed in category names and in `extra` declarations** (where they would be meaningless) + - **Category intersection now produces a category with graphemes + in the same order as the last category mentioned, rather than the first** + - Optional elements or categories can now be prefixed by `%` to make them match greedily + - New backreference syntax `@#id` allows categories to be matched by ID rather than number + - `extra` graphemes are now always taken into account for multigraph tokenisation + (**technically a breaking change**, but unlikely in existing sound changes) + - Within a category, single graphemes inside braces are now treated the same as single graphemes outside braces + (**technically a breaking change**, but unlikely to change existing sound changes) +- Changes to rule application algorithm: + - **Sound change applications can now overlap, + such that the replacement from one application can be used as the environment for the next** + - New flag `-no` allows for reverting to the previous behaviour (non-overlapping applications) + - **Make RTL and LTR application symmetric, + by reimplementing the former as LTR application with words and rules reversed: + consequently category correspondences, backreferences etc. are also reversed** +- Improvements to graphical interface: + - Whitespace is now preserved when displaying sound change output on desktop and web + - New keyboard shortcuts in desktop GUI: + Ctrl+Enter to apply rules, Ctrl+Tab to toggle between rules and words textboxes + - Some labels have been changed to be more descriptive: + ‘Different to input’ to ‘Any rule applied’, and ‘Wordlist’ to ‘Wordlist + glosses’ + - Improvements to output from ‘Report rules apply’: most importantly, + comments are no longer included next to rules, and + outputs are no longer aligned across input words (greatly increasing responsiveness on desktop) + - User can now choose which MDF hierarchy to use for dictionaries + - Web version brought closer to parity with desktop version + by adding MDF support and an option to ‘synchronise scroll positions’ + - When ‘view results live’ is selected, results are updated on changes to all controls, + not just changes to words or sound changes + - Add ‘Edit’ menu to desktop GUI, including ‘Find’ dialog box + - Add ‘Help’ menu to desktop GUI + - Fields of web GUI can now be initialised using URL query parameters + (`r` for rules, `w` for words) + - Add ‘select all’ buttons to web GUI + - Improve display of web application controls on small screens + - Sound changes editor on web version has been rewritten to work around bug with combining diacritics + - Add option for ‘input→output’ display format to include glosses and whitespace + +### Code + +- CMakeLists for desktop GUI now track Haskell binary dependency correctly +- Renamed `Brassica.SoundChange.Category` to `Brassica.SoundChange.Expand` +- Renamed constructor `Brassica.SoundChange.Types.DirectiveS` to `Brassica.SoundChange.Types.DeclS` +- Changes resulting from addition of `report`: + - New constructor `ReportS` added to `Brassica.SoundChange.Types.Statement` + - A constructor `ReportWord` has been added to `Brassica.SoundChange.Apply.Internal.LogItem`, + while its former record fields `input` and `output` have been replaced with functions + `logInput` and `logOutput`. + - `Brassica.SoundChange.Frontend.Internal` has been restructured to allow display of intermediate results + - New function `Brassica.SoundChange.Tokenise.joinComponents` added to assist with said restructure +- Changes resulting from addition of features: + - New constructors `Feature` and `Autosegment` added to `Brassica.SoundChange.Types.Lexeme` + (the latter primarily for internal use) + - New type `Brassica.SoundChange.Apply.Internal` + - New constructor `DefineAuto` added to `Brassica.SoundChange.Types.CategoryDefinition` + - Changes in category expansion: + new type `Brassica.SoundChange.Expand.AutosegmentDef`, + and new constructor `InvalidDerivedValue` + added to `Brassica.SoundChange.Expand.ExpandError` +- Changes resulting from new rule application algorithm: + - New constructore `PrevEnd` added to `Brassica.SoundChange.Apply.Internal.RuleTag` + - New field `nonOverlappingTarget` added to `Brassica.SoundChange.Types.Flags` +- New constructors `GreedyOptional` and `GreedyCategory` for `Brassica.SoundChange.Types.Lexeme` +- `Brassica.SoundChange.Frontend.Internal.InputLexiconFormat` + now depends on new type `Brassica.SoundChange.Frontend.Internal.MDFHierarchy` +- Word boundaries are now simply ordinary graphemes `"#"`: + `Brassica.SoundChange.Types.Grapheme` is now a type synonym for `[Char]` +- Expansion now results in sound changes with declaration type `GraphemesList` + rather than `[Grapheme]` +- API of `Brassica.SoundChanges.Apply` (and `Brassica.SoundChanges.Apply.Internal`) has been refactored: + - `LogItem` (now re-exported from `Brassica.SoundChanges.Apply`) + no longer stores redundant information on input words + - `PWordLog` is renamed `Log`, and is now based on `LogItem` + - `initialWord` is now renamed `inputWord` + - Former functions `applyRule` and `applyStatement` + have been renamed to `applyRuleMZ` and `applyStatementMZ`; + - Former functions `applyRuleWithLogs` and `applyStatementWithLog` + have been renamed to `applyRule` and `applyStatement` + - Function `applyRuleWithLog` has been removed + - Set of sound change application functions `applyChanges*` + has been replaced with a single function `applyChanges` returning a `PWordLog`, + plus a set of functions to extract various outputs from it +- New constructor `WordsWithProtoOutputPreserve` for `Brassica.SoundChange.Frontend.Internal.OutputMode` +- Remove now-unnecessary pattern `Brassica.SoundChange.Types.Boundary` +- In parsing modules, re-export whole module `Text.Megaparsec.Error` + rather than only re-exporting the single function `errorBundlePretty` +- Category elements are now represented as simply `[Lexeme category a]` + (synonym `Brassica.SoundChanges.Types.CategoryElement`), + without any special case for single-grapheme elements +- `concatWithBoundary` is now no longer re-exported from `Brassica.SoundChange.Tokenise` + ## 0.3.0 ### Behaviour diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,27 +2,27 @@ [![Hackage](https://img.shields.io/hackage/v/brassica.svg?logo=haskell)](https://hackage.haskell.org/package/brassica) -Brassica is a new sound change applier. -Its features include: +Brassica is a sound change applier: a program to simulate the evolution of language over time. -- Can be used interactively both [online](https://bradrn.com/brassica/index.html) and as a desktop application, or non-interactively in batch mode on the command-line or as a [Haskell library](https://hackage.haskell.org/package/brassica) -- Natively supports the MDF dictionary format, also used by tools including [SIL Toolbox](https://software.sil.org/toolbox/) and [Lexique Pro](https://software.sil.org/lexiquepro/) -- First-class support for multigraphs -- Easy control over rule application: apply sound changes sporadically, right-to-left, between words, and in many more ways -- Live preview and control over output highlighting let you try out sound changes quickly and easily -- Highlight and visualise results in numerous ways -- Category operations allow phonetic rules to be written in both featural and character-based ways -- Support for ‘features’ lets rules easily manipulate stress, tone and other suprasegmentals +Brassica’s features include: + +- A choice of four different platforms: you can use Brassica interactively [online](https://bradrn.com/brassica/index.html) or as a standalone application, + non-interactively on the command-line, or as a [Haskell library](https://hackage.haskell.org/package/brassica) +- Being well-tested, including several automated test suites, as well as example files with sound changes from natural languages +- First-class support for suprasegmental features, such as stress and tone +- Easy control over rule application: apply sound changes iteratively, sporadically, right-to-left, between words, and in many more ways +- Native support for the MDF dictionary format, also used by tools including [SIL Toolbox](https://software.sil.org/toolbox/) and [Lexique Pro](https://software.sil.org/lexiquepro/) +- A comprehensive user interface with live preview and highlighting for both sound changes and output - Comes with a [paradigm builder](https://bradrn.com/brassica/builder.html) for quickly investigating inflectional and other patterns -- Rich syntax for specifying phonetic rules, including wildcards, optional elements and more And many more! -See the [documentation](./Documentation.md) for details on Brassica usage. +See the [documentation](./docs) for details on Brassica usage, + and the [example files](./examples) for examples of practical usage. Download Brassica from the [releases page](https://github.com/bradrn/brassica/releases/latest). Alternately, try it online at http://bradrn.com/brassica. As of the time of writing prebuilt binaries exist for Windows and Linux. Instructions for building from source are available at [`BUILDING.md`](./BUILDING.md). -![Image of Brassica with some example sound changes](https://raw.githubusercontent.com/bradrn/brassica/v0.1.0/gui-interface-example.png) +![Image of Brassica with some example sound changes](./docs/screenshot.png) diff --git a/bench/Changes.hs b/bench/Changes.hs --- a/bench/Changes.hs +++ b/bench/Changes.hs @@ -60,22 +60,24 @@ complex = Rule { target = - [ Category $ FromElements $ Left <$> ["t", "d", "n"] + [ Category $ FromElements $ toElem <$> ["t", "d", "n"] , Optional [Grapheme "y"] - , Category $ FromElements $ Left <$> ["i", "e"] + , Category $ FromElements $ toElem <$> ["i", "e"] ] , replacement = - [ Category $ FromElements $ Left <$> ["c", "j", "nh"] + [ Category $ FromElements $ toElem <$> ["c", "j", "nh"] , Optional [Geminate] ] , environment = pure - ( [Category $ FromElements $ Left <$> [GBoundary, "a", "e", "i"]] - , [Category $ FromElements $ Left <$> ["a", "e", "i", "o", "u"]] + ( [Category $ FromElements $ toElem <$> ["#", "a", "e", "i"]] + , [Category $ FromElements $ toElem <$> ["a", "e", "i", "o", "u"]] ) , exception = Nothing , flags = defFlags , plaintext = "[t d n] (y) [i e] / [č j ñ] (>) / [# a e i] _ [a e i o u]" } + + toElem g = [Grapheme g] benchChanges :: Rule Expanded -> PWord -> [Benchmark] benchChanges cs l = diff --git a/brassica.cabal b/brassica.cabal --- a/brassica.cabal +++ b/brassica.cabal @@ -1,10 +1,13 @@ cabal-version: 2.0 name: brassica -version: 0.3.0 +version: 1.0.0 synopsis: Featureful sound change applier description: - The Brassica library for the simulation of sound changes in historical linguistics and language construction. - For further details, please refer to the README below or at . + This is the Brassica library for the simulation of sound changes in historical linguistics and language construction. + . + For an introduction to library usage, see the documentation of [Brassica.SoundChange](https://hackage.haskell.org/package/brassica-1.0.0/candidate/docs/Brassica-SoundChange.html). + . + For further details on Brassica’s design and usage, please refer to the README below or at . category: Linguistics homepage: https://github.com/bradrn/brassica#readme @@ -28,7 +31,7 @@ , Brassica.SoundChange.Apply , Brassica.SoundChange.Apply.Internal , Brassica.SoundChange.Apply.Internal.MultiZipper - , Brassica.SoundChange.Category + , Brassica.SoundChange.Expand , Brassica.SoundChange.Frontend.Internal , Brassica.SoundChange.Parse , Brassica.SoundChange.Tokenise @@ -63,7 +66,7 @@ build-depends: base >=4.7 && <5 , brassica - , aeson ^>=2.2 + , aeson >=2.2 && <2.3 , attoparsec-aeson ^>=2.2 , bytestring >=0.10 && <0.13 , conduit ^>=1.3 @@ -71,7 +74,7 @@ , deepseq >=1.4 && <1.6 , optparse-applicative ^>=0.17.1 || ^>=0.18 , parallel ^>= 3.2 - , text >=1.2 && <2.2 + , text >=1.2 && <2.3 default-language: Haskell2010 @@ -85,7 +88,7 @@ , bytestring >=0.10 && <0.13 , conduit ^>=1.3 , optparse-applicative ^>=0.17.1 || ^>=0.18 - , text >=1.2 && <2.2 + , text >=1.2 && <2.3 default-language: Haskell2010 @@ -100,7 +103,7 @@ , criterion >=1.5 && <1.7 , file-embed >=0.0.15 && <0.0.16 , parallel ^>= 3.2 - , text >=1.2 && <1.3 + , text >=1.2 && <2.3 default-language: Haskell2010 @@ -127,9 +130,25 @@ , tasty ^>=1.4 , tasty-golden ^>=2.3 , bytestring - , text >=1.2 && <2.1 - , transformers ^>=0.5 + , text >=1.2 && <2.3 + , transformers >=0.5 && <0.7 , conduit ^>=1.3 , utf8-string ^>=1.0 + + default-language: Haskell2010 + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: DocTests.hs + hs-source-dirs: test + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base >=4.7 && <5 + , brassica + , tasty ^>=1.4 + , bytestring + , text >=1.2 && <2.3 + , pandoc >=3.3 && <3.4 + , pandoc-types >=1.23 && <1.24 default-language: Haskell2010 diff --git a/cli-pb/Main.hs b/cli-pb/Main.hs --- a/cli-pb/Main.hs +++ b/cli-pb/Main.hs @@ -34,7 +34,7 @@ .| encodeUtf8C .| outC where - opts = info (args <**> helper <**> simpleVersioner "v0.3.0") fullDesc + opts = info (args <**> helper <**> simpleVersioner "v1.0.0") fullDesc args = Options <$> asum diff --git a/cli/Main.hs b/cli/Main.hs --- a/cli/Main.hs +++ b/cli/Main.hs @@ -7,7 +7,7 @@ import Conduit import qualified Data.ByteString as B -import Data.Text (pack, unpack, snoc, Text) +import Data.Text (pack, unpack, snoc, unsnoc, Text) import Data.Text.Encoding (decodeUtf8) import Options.Applicative @@ -32,6 +32,7 @@ Left err -> putStrLn $ case err of (NotFound s) -> "Could not find category: " ++ s InvalidBaseValue -> "Invalid value used as base grapheme in feature definition" + InvalidDerivedValue -> "Invalid value used as derived grapheme in autosegment" MismatchedLengths -> "Mismatched lengths in feature definition" Right rules' -> withSourceFileIf inWordsFile $ \inC -> @@ -42,7 +43,7 @@ .| outC where - opts = info (args <**> helper <**> simpleVersioner "v0.3.0") fullDesc + opts = info (args <**> helper <**> simpleVersioner "v1.0.0") fullDesc args = batchArgs <|> serverArgs serverArgs = flag' Server (long "server" <> help "Run server (for internal use only)") @@ -53,8 +54,12 @@ , FromFile <$> strArgument (metavar "RULES" <> help "File containing sound changes") ] - <*> flag Raw MDF - (long "mdf" <> help "Parse input words in MDF format") + <*> asum + [ flag Raw (MDF Standard) + (long "mdf" <> help "Parse input words in MDF format (standard hierarchy)") + , flag Raw (MDF Alternate) + (long "mdf-alt" <> help "Parse input words in MDF format (alternate hierarchy)") + ] <*> (asum [ flag' (const ReportRulesApplied) (long "report" <> help "Report rules applied rather than outputting words") @@ -79,7 +84,7 @@ (long "out" <> short 'o' <> help "File to which output words should be written (if not specified will write to stdout)")) incrFor Raw = True - incrFor MDF = False + incrFor (MDF _) = False -- duplicated in paradigm builder CLI withSourceFileIf :: Maybe FilePath -> (ConduitM i B.ByteString IO () -> IO a) -> IO a @@ -104,14 +109,14 @@ processWords :: (MonadIO m, MonadThrow m) => Bool -- split into lines? - -> SoundChanges Expanded [Grapheme] + -> SoundChanges Expanded GraphemeList -> InputLexiconFormat -> ApplicationMode -> ConduitT B.ByteString B.ByteString m () processWords incr rules wordsFormat outMode = decodeUtf8C .| (if incr then linesUnboundedC else mapC id) - .| mapC (processApplicationOutput . evolve . unpack . (`snoc` '\n')) + .| mapC (processApplicationOutput . evolve . unpack) .| throwOnLeft .| encodeUtf8C where @@ -122,10 +127,14 @@ Left e -> throwM e Right r -> yield r - processApplicationOutput :: ApplicationOutput PWord (Statement Expanded [Grapheme]) -> Either ParseException Text - processApplicationOutput (HighlightedWords cs) = Right $ pack $ detokeniseWords' highlight cs + processApplicationOutput :: ApplicationOutput PWord (Statement Expanded GraphemeList) -> Either ParseException Text + processApplicationOutput (HighlightedWords cs) = Right $ ensureNewline $ pack $ detokeniseWords' highlight cs processApplicationOutput (AppliedRulesTable is) = Right $ pack $ unlines $ reportAsText plaintext' <$> is processApplicationOutput (ParseError e) = Left $ ParseException $ errorBundlePretty e + + ensureNewline t = case unsnoc t of + Just (_, '\n') -> t + _ -> snoc t '\n' highlight (w, False) = concatWithBoundary w highlight (w, True) = concatWithBoundary w ++ " [+]" diff --git a/cli/Server.hs b/cli/Server.hs --- a/cli/Server.hs +++ b/cli/Server.hs @@ -14,12 +14,14 @@ import Control.DeepSeq (force, NFData) import Control.Exception (evaluate) import Control.Parallel.Strategies (withStrategy, parTraversable, rseq) -import Data.Aeson (Result(..), encode, fromJSON) +import Data.Aeson (Result(..), encode, FromJSON(..), ToJSON(..), Value (..), fromJSON) import Data.Aeson.Parser (json') import Data.Aeson.TH (deriveJSON, defaultOptions, defaultTaggedObject, constructorTagModifier, sumEncoding, tagFieldName) +import Data.Aeson.Types (prependFailure, typeMismatch) import Data.ByteString (toStrict) import Data.Conduit.Attoparsec (conduitParser) import Data.Foldable (toList) +import Data.Text (unpack) import GHC.Generics (Generic) import System.IO (hSetBuffering, stdin, stdout, BufferMode(NoBuffering)) import System.Timeout @@ -57,9 +59,20 @@ | RespError String deriving (Show, Generic, NFData) +instance ToJSON InputLexiconFormat where + toJSON Raw = "Raw" + toJSON (MDF Standard) = "MDFStandard" + toJSON (MDF Alternate) = "MDFAlternate" + +instance FromJSON InputLexiconFormat where + parseJSON (String "Raw") = pure Raw + parseJSON (String "MDFStandard") = pure $ MDF Standard + parseJSON (String "MDFAlternate") = pure $ MDF Alternate + parseJSON (String s) = fail $ "Unknown InputLexiconFormat: " ++ unpack s + parseJSON invalid = prependFailure "parsing InputLexiconFormat failed: " $ + typeMismatch "String" invalid + $(deriveJSON defaultOptions ''Component) -$(deriveJSON defaultOptions ''Grapheme) -$(deriveJSON defaultOptions ''InputLexiconFormat) $(deriveJSON defaultOptions ''HighlightMode) $(deriveJSON defaultOptions ''OutputMode) @@ -107,6 +120,7 @@ Left err -> RespError $ ("
"++) $ (++"
") $ case err of (NotFound s) -> "Could not find category: " ++ s InvalidBaseValue -> "Invalid value used as base grapheme in feature definition" + InvalidDerivedValue -> "Invalid value used as derived grapheme in autosegment" MismatchedLengths -> "Mismatched lengths in feature definition" Right statements' -> let result' = parseTokeniseAndApplyRules parFmap statements' input inFmt mode prev @@ -117,7 +131,7 @@ (Just $ (fmap.fmap) fst result) (escape $ detokeniseWords' highlightWord result) AppliedRulesTable items -> RespRules Nothing $ - surroundTable $ concatMap (reportAsHtmlRows plaintext') items + concatMap (surroundTable . reportAsHtmlRows plaintext') items where highlightWord (s, False) = concatWithBoundary s highlightWord (s, True) = "" ++ concatWithBoundary s ++ "" diff --git a/src/Brassica/Paradigm.hs b/src/Brassica/Paradigm.hs --- a/src/Brassica/Paradigm.hs +++ b/src/Brassica/Paradigm.hs @@ -1,6 +1,15 @@ +-- | +-- Module : Brassica.Paradigm +-- Copyright : See LICENSE file +-- License : BSD3 +-- Maintainer : Brad Neimann +-- module Brassica.Paradigm ( - Process(..) + -- * Re-export + module Text.Megaparsec.Error + -- * Paradigm representation + , Process(..) , Affix , Grammeme(..) , AbstractGrammeme(..) @@ -9,16 +18,16 @@ , FeatureName(..) , Statement(..) , Paradigm - , ResultsTree(..) - , depth - , applyParadigm + -- * Parsing and pretty-printing , parseParadigm , formatNested - -- ** Re-export - , errorBundlePretty + -- * Paradigm application + , applyParadigm + , ResultsTree(..) + , depth ) where import Brassica.Paradigm.Apply import Brassica.Paradigm.Parse import Brassica.Paradigm.Types -import Text.Megaparsec (errorBundlePretty) +import Text.Megaparsec.Error 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 @@ -16,6 +16,8 @@ import Data.Maybe (mapMaybe) import Data.Ord (Down(Down)) +-- | Results from applying a 'Paradigm' to a word, represented as a tree +-- containing each possible choice of 'Grammeme's. data ResultsTree a = Node [ResultsTree a] | Result a deriving (Show, Functor, Foldable) @@ -23,6 +25,8 @@ addLevel f (Result r) = Node $ Result <$> f r addLevel f (Node rs) = Node $ addLevel f <$> rs +-- | Depth of a 'ResultsTree': i.e. how many levels of 'Node's it +-- contains. depth :: ResultsTree a -> Int depth (Node ts) = maximum $ (1+) . depth <$> ts depth (Result _) = 0 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/Paradigm/Types.hs b/src/Brassica/Paradigm/Types.hs --- a/src/Brassica/Paradigm/Types.hs +++ b/src/Brassica/Paradigm/Types.hs @@ -34,14 +34,14 @@ deriving stock (Show, Eq) deriving newtype (IsString) --- | A condition which must be satisfied before including a 'Feature' --- in a word. +-- | A condition which must be satisfied for a 'Feature' to be +-- included in a word. data Condition = Always -- ^ Condition which is always satisfied | Is FeatureName Grammeme - -- ^ Satisfied when the specified feature (identified by its name) - -- has been assigned to the specified 'Grammeme' + -- ^ Satisfied when the specified feature has been assigned to the + -- specified 'Grammeme' | Not FeatureName Grammeme -- ^ Satisfied when the specified feature has /not/ been assigned -- to the specified 'Grammeme' @@ -54,6 +54,7 @@ data Feature = Feature Condition (Maybe FeatureName) [Grammeme] deriving (Show, Eq) +-- | Name to identify a specific 'Feature'. newtype FeatureName = FeatureName String deriving stock (Show, Eq) deriving newtype (IsString) @@ -64,9 +65,9 @@ data Statement = NewFeature Feature | NewMapping [AbstractGrammeme] Affix deriving (Show, Eq) --- | A paradigm is specified as a list of 'Statement's. The list is --- basically big-endian, in that the slowest-varying feature should be --- listed first. (So if e.g. tense is listed first, then first all --- words of tense 1 are listed, next all words of tense 2 are listed, --- and so on.) +-- | A paradigm is specified as a list of 'Statement's. The order is +-- reflected in the output 'Brassica.Paradigm.Apply.ResultsTree': the +-- root has one child for each grammeme in the first 'Feature', with +-- each child then having one child for each grammeme in the second +-- 'Feature', and so on. type Paradigm = [Statement] diff --git a/src/Brassica/SFM/MDF.hs b/src/Brassica/SFM/MDF.hs --- a/src/Brassica/SFM/MDF.hs +++ b/src/Brassica/SFM/MDF.hs @@ -1,10 +1,14 @@ {-# LANGUAGE NamedFieldPuns #-} -{-| This module contains types and functions for working with the MDF - dictionary format, used by programs such as [SIL Toolbox](https://software.sil.org/toolbox/). - For more on the MDF format, refer to e.g. - [Coward & Grimes (2000), /Making Dictionaries: A guide to lexicography and the Multi-Dictionary Formatter/](http://downloads.sil.org/legacy/shoebox/MDF_2000.pdf). --} +-- | +-- Module : Brassica.SFM.MDF +-- Copyright : See LICENSE file +-- License : BSD3 +-- Maintainer : Brad Neimann +-- +-- This module contains types and functions for working with the MDF +-- dictionary format. For more on the MDF format, refer to e.g. +-- [Coward & Grimes (2000)](http://downloads.sil.org/legacy/shoebox/MDF_2000.pdf). module Brassica.SFM.MDF where import Brassica.SFM.SFM @@ -71,7 +75,7 @@ , ("xr" , Regional) , ("xv" , Vernacular) ] --- | Standard MDF hierarchy: with @\lx@ > @\se@ > @\ps@ > @\sn@. +-- | Standard MDF hierarchy, with @\lx@ > @\se@ > @\ps@ > @\sn@. -- Intended for use with 'toTree'. mdfHierarchy :: Hierarchy mdfHierarchy = M.fromList @@ -98,7 +102,7 @@ , ("wr", "sn"), ("xe", "xv"), ("xn", "xv"), ("xr", "xv"), ("xv", "rf") ] --- | Alternate MDF hierarchy: with @\lx@ > @\sn@ > @\se@ > @\ps@. +-- | Alternate MDF hierarchy, with @\lx@ > @\sn@ > @\se@ > @\ps@. -- Intended for use with 'toTree'. mdfAlternateHierarchy :: Hierarchy mdfAlternateHierarchy = M.fromList @@ -130,15 +134,20 @@ -- if using 'tokeniseWords'; everything else is treated as a -- 'Separator', so that it is not disturbed by operations such as rule -- application or rendering to text. +-- +-- (This is a simple wrapper around 'tokeniseField'.) tokeniseMDF :: [String] -- ^ List of available multigraphs (as with 'tokeniseWord') -> SFM -> Either (ParseErrorBundle String Void) [Component PWord] tokeniseMDF gs = fmap concat . traverse (tokeniseField gs) --- | Like 'tokeniseMDF', but for a single 'Field'. +-- | Like 'tokeniseMDF', but for a single 'Field' rather than a whole +-- SFM file. tokeniseField :: [String] -> Field -> Either (ParseErrorBundle String Void) [Component PWord] tokeniseField gs f = case M.lookup (fieldMarker f) fieldLangs of Just Vernacular -> + -- initialise megaparsec state with position starting at given + -- field let ps = initialPosState "" (fieldValue f) s = State { stateInput = fieldValue f @@ -154,7 +163,7 @@ _ -> Right [Separator $ '\\' : fieldMarker f ++ fieldWhitespace f ++ fieldValue f] --- | Add etymological fields to an 'MDF' by duplicating the values in +-- | Add etymological fields to an MDF file by duplicating the values in -- @\lx@, @\se@ and @\ge@ fields. e.g.: -- -- > \lx kapa @@ -177,7 +186,11 @@ -- -- This can be helpful when applying sound changes to an MDF file: the -- vernacular words can be copied as etymologies, and then the sound --- changes can be applied leaving the etymologies as is. +-- changes can be applied leaving the etymologies as is. +-- +-- Note that the hierarchy must already be resolved before this +-- function can be used, as it depends on the tree structure to know +-- where the etymologies should be placed. duplicateEtymologies :: (String -> String) -- ^ Transformation to apply to etymologies, e.g. @('*':)@ @@ -215,7 +228,7 @@ { fieldMarker = "et" , fieldWhitespace = " " , fieldSourcePos = Nothing - , fieldValue = f $ trim lx + , fieldValue = ensureNewline $ f $ trim lx } $ case gl of Nothing -> [] @@ -224,10 +237,12 @@ { fieldMarker = "eg" , fieldWhitespace = " " , fieldSourcePos = Nothing - , fieldValue = gl' - -- no need to add newline here because 'gl' - -- should already have whitespace + , fieldValue = ensureNewline gl' } [] ] trim = dropWhile isSpace . dropWhileEnd isSpace + + ensureNewline s + | last s == '\n' = s + | otherwise = s ++ "\n" diff --git a/src/Brassica/SFM/SFM.hs b/src/Brassica/SFM/SFM.hs --- a/src/Brassica/SFM/SFM.hs +++ b/src/Brassica/SFM/SFM.hs @@ -1,12 +1,17 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE LambdaCase #-} -{-| This module implements basic support for the SIL Standard Format -Marker (SFM) format, used by dictionary software such as -[FieldWorks](https://software.sil.org/fieldworks/). This format forms -the basis of standards such as Multi-Dictionary Formatter (MDF), -implemented here in 'Brassica.SFM.MDF'. --} +-- | +-- Module : Brassica.SFM.SFM +-- Copyright : See LICENSE file +-- License : BSD3 +-- Maintainer : Brad Neimann +-- +-- This module implements basic support for the SIL Standard Format +-- Marker (SFM) format, used by dictionary software such as +-- [FieldWorks](https://software.sil.org/fieldworks/). This format forms +-- the basis of standards such as Multi-Dictionary Formatter (MDF), +-- implemented here in @Brassica.SFM.MDF@. module Brassica.SFM.SFM ( -- * Linear SFM documents Field(..) @@ -41,6 +46,7 @@ -- ^ Whitespace after the field marker , fieldSourcePos :: Maybe SourcePos -- ^ Optionally, a Megaparsec 'SourcePos' marking the start of the value + -- (to enable further parsing) , fieldValue :: String -- ^ The value of the field, including all whitespace until the next marker } deriving (Show) @@ -80,7 +86,7 @@ value <- parseFieldValue pure (marker, s, ps, value) --- | Parse an SFM file to an 'SFM'. +-- | Parse an SFM file to an 'SFM' value. parseSFM :: String -- ^ Name of source file -> String -- ^ Input SFM data to parse @@ -108,7 +114,8 @@ deriving (Show) -- | The hierarchy underlying an SFM document, defined as a map from --- field names to their parents. Unlisted fields are treated as roots. +-- field names to their parents. Fields which are absent from the map +-- are treated as roots. type Hierarchy = M.Map String String -- | Returns the full hierarchy of a marker, starting with its @@ -126,11 +133,11 @@ (Filled f s) <+:> t = Filled f (s ++ [t]) (Missing f s) <+:> t = Missing f (s ++ [t]) --- | Use a 'Hierarchy' to generate a tree structure from an 'SFM' --- document. Fields are converted to 'Filled' nodes, containing as --- many following nodes as possible, until the next node which is at --- the same level of the hierarchy or lower. 'Missing' nodes are --- created for any missing levels of the hierarchy. +-- | Generate a tree structure from an 'SFM' document according to the +-- given 'Hierarchy'. Fields are converted to 'Filled' nodes, +-- containing as many following nodes as possible, until the next node +-- which is at the same level of the hierarchy or lower. 'Missing' +-- nodes are created for any missing levels of the hierarchy. toTree :: Hierarchy -> SFM -> SFMTree toTree h = fst . go (Root []) where @@ -158,8 +165,13 @@ in go (s <+:> subtree) fs' -- otherwise, recurse into the hierarchy - (m:_, _) -> - let (subtree, fs') = go (Missing m []) (f:fs) + (ms, _) -> + -- NB. 'last ms' is the /highest/ missing level! Then + -- the recursive call infers the next-highest level, + -- and so on until all the levels are created. This + -- could be sped up by creating all the levels at once, + -- but it's not worth it for now. + let (subtree, fs') = go (Missing (last ms) []) (f:fs) in go (s <+:> subtree) fs' -- | Inverse of 'toTree': convert an 'SFMTree' back into a linear @@ -175,7 +187,8 @@ mapField g (Filled f s) = Filled (g f) $ mapField g <$> s mapField g (Missing m s) = Missing m $ mapField g <$> s --- | Depth-first search for fields under an 'SFMTree'. +-- | Depth-first search for fields under an 'SFMTree' which satisfy +-- the given predicate. searchField :: (Field -> Maybe a) -> SFMTree -> [a] searchField p (Root ts) = searchField p =<< ts searchField p (Filled f ts) diff --git a/src/Brassica/SoundChange.hs b/src/Brassica/SoundChange.hs --- a/src/Brassica/SoundChange.hs +++ b/src/Brassica/SoundChange.hs @@ -1,7 +1,61 @@ +-- | +-- Module : Brassica.SoundChange +-- Copyright : See LICENSE file +-- License : BSD3 +-- Maintainer : Brad Neimann +-- +-- The modules below provide Brassica’s support for sound changes. +-- For further details on their syntax and processing, refer to the +-- [reference guide](https://github.com/bradrn/brassica/blob/v1.0.0/docs/Reference.md), +-- and the documentation of individual modules. +-- +-- In brief, a sound changes file passes through the following phases: +-- +-- 1. First it is /parsed/ to a @'SoundChanges' 'CategorySpec' 'Directive'@ +-- 2. Next it undergoes /expansion/ to give a @'SoundChanges' 'Expanded' 'GraphemeList'@ +-- 3. Finally it can be /applied/ to a 'PWord' using 'applyChanges' or similar. +-- +-- Words may also be extracted from a words file for application using +-- 'tokeniseWords', and the file can be recreated using +-- 'detokeniseWords' or similar. (For an MDF file one can similarly +-- use 'Brassica.SFM.MDF.tokeniseMDF'.) +-- +-- For a simple example, the following sample applies a sound change +-- file to a words file (without error-handling): +-- +-- @ +-- import Data.Maybe (mapMaybe) +-- import System.Environment (getArgs) +-- import Brassica.SoundChange +-- +-- main :: IO () +-- main = do +-- [changesFile, wordsFile] <- getArgs +-- changes <- readFile changesFile +-- words <- readFile wordsFile +-- +-- let Right changesParsed = 'parseSoundChanges' changes +-- Right changesExpanded = 'expandSoundChanges' changesParsed +-- +-- Right wordsTokenised = +-- 'withFirstCategoriesDecl' 'tokeniseWords' changesExpanded words +-- +-- wordsOutput = fmap (mapMaybe 'getOutput' . 'applyChanges' changesExpanded) <$> wordsTokenised +-- +-- putStrLn $ 'detokeniseWords' $ +-- concatMap ('splitMultipleResults' "/") wordsOutput +-- @ +-- +-- If writing sound changes in Haskell, it is suggested to skip +-- parsing and expansion and directly create a value of type +-- @'SoundChanges' 'Expanded' ('Bool', [t'Grapheme'])@. Expansion is +-- of little use when v'Category's and v'Autosegment's can be assigned +-- names in the code itself. module Brassica.SoundChange (module X) where +-- NB. Haddock seems to list these re-exports in reverse order +import Brassica.SoundChange.Tokenise as X import Brassica.SoundChange.Apply as X -import Brassica.SoundChange.Category as X +import Brassica.SoundChange.Expand as X import Brassica.SoundChange.Parse as X -import Brassica.SoundChange.Tokenise as X import Brassica.SoundChange.Types as X diff --git a/src/Brassica/SoundChange/Apply.hs b/src/Brassica/SoundChange/Apply.hs --- a/src/Brassica/SoundChange/Apply.hs +++ b/src/Brassica/SoundChange/Apply.hs @@ -1,13 +1,32 @@ +-- | +-- Module : Brassica.SoundChange.Apply +-- Copyright : See LICENSE file +-- License : BSD3 +-- Maintainer : Brad Neimann +-- +-- This module contains functions to apply one or more expanded sound +-- changes to words. +-- +-- The most important function is 'applyChanges', which applies a set +-- of 'Brassica.SoudnChanges.Types.SoundChanges' to an input word. It +-- returns a log of all sound changes and other actions which were +-- applied to produce intermediate forms and the final result. The +-- results can be summarised using the functions in +-- [Reporting results](#g:3). module Brassica.SoundChange.Apply ( - -- * Sound change application + -- * Applying single rules applyRuleStr , applyStatementStr + -- * Applying multiple sound changes , applyChanges - -- * Logging - , applyChangesWithLogs - , applyChangesWithChanges - , PWordLog(..) + , Log(..) + , LogItem(..) + -- * Reporting results + , getOutput + , getReports + , getChangedOutputs + , getChangedReports , reportAsText , reportAsHtmlRows ) where 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 @@ -20,54 +20,89 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-| __Warning:__ This module is __internal__, and does __not__ follow - the Package Versioning Policy. It may be useful for extending - Brassica, but be prepared to track development closely if you import - this module. --} +-- | +-- Module : Brassica.SoundChange.Apply.Internal +-- Copyright : See LICENSE file +-- License : BSD3 +-- Maintainer : Brad Neimann +-- +-- __Warning:__ This module is __internal__, and does __not__ follow +-- the Package Versioning Policy. It may be useful for extending +-- Brassica, but be prepared to track development closely if you import +-- this module. +-- +-- This module contains the lower-level functions used by Brassica to +-- match and apply sound changes. The overall algorithm is similar to +-- that described by [Howard (1973)](https://dspace.mit.edu/bitstream/handle/1721.1/12982/26083289-MIT.pdf?sequence=2). +-- +-- Some essential points: +-- +-- * Words are represented as 'MultiZipper's, with a cursor index +-- and zero or more tagged indices. A sound change can then be +-- applied ('applyRuleMZ') by advancing through the word from +-- left to right. (Right-to-left application is achieved by +-- reversing both word and rule.) +-- +-- * For each potential application site, 'applyOnce' checks the +-- target, environments and exceptions. If they are all +-- satisfied, it then replaces the target graphemes with the +-- replacement graphemes. After running 'applyOnce', +-- 'setupForNextApplication' can be used to advance to the next +-- application site. +-- +-- * The lowest-level function for matching is 'match', which +-- matches an individual 'Lexeme' at some point in a word. The +-- lowest-level function for replacement is 'mkReplacement', +-- which constructs replacement graphemes. module Brassica.SoundChange.Apply.Internal ( -- * Lexeme matching RuleTag(..) , RuleStatus(..) , MatchOutput(..) + , FeatureState(..) + , newOutput + , initialOutput , match , matchMany - , matchMany' , mkReplacement , exceptionAppliesAtPoint , matchRuleAtPoint -- * Sound change application , applyOnce - , applyRule + , setupForNextApplication + , applyRuleMZ , checkGraphemes - , applyStatement + , applyStatementMZ , applyRuleStr , applyStatementStr - , applyChanges -- * Logging , LogItem(..) - , PWordLog(..) - , toPWordLog + , Log(..) , reportAsHtmlRows , reportAsText - , applyStatementWithLog - , applyChangesWithLog - , applyChangesWithLogs - , applyChangesWithChanges + , applyStatement + , applyChanges + , getOutput + , getReports + , getChangedOutputs + , getChangedReports ) where import Control.Applicative ((<|>)) import Control.Category ((>>>)) -import Control.Monad ((>=>), join) -- needed for mtl>=2.3 +import Control.Monad ((>=>), (<=<), join) -- needed for mtl>=2.3 import Data.Containers.ListUtils (nubOrd) import Data.Functor ((<&>)) +import Data.List (elemIndex) import Data.Maybe (maybeToList, fromMaybe, listToMaybe, mapMaybe) import GHC.Generics (Generic) import Control.DeepSeq (NFData) import Control.Monad.State +import qualified Data.Map.Strict as Map + import Brassica.SoundChange.Apply.Internal.MultiZipper import Brassica.SoundChange.Types import Data.Bifunctor (Bifunctor(first)) @@ -77,6 +112,9 @@ = AppStart -- ^ The start of a rule application | TargetStart -- ^ The start of the target | TargetEnd -- ^ The end of the target + | PrevEnd + -- ^ The end of the replacement from the last rule application + -- (used to avoid infinite loops from iterative rules) deriving (Eq, Ord, Show) -- | A monad in which to process a 'MultiZipper' over @@ -85,11 +123,7 @@ -- backtracking and multiple answers (backtracking over the state -- too). newtype RuleAp a = RuleAp { runRuleAp :: MultiZipper RuleTag Grapheme -> [(a, MultiZipper RuleTag Grapheme)] } - deriving (Functor, Applicative, Monad, MonadState (MultiZipper RuleTag Grapheme) - - , MonadFail - - ) + deriving (Functor, Applicative, Monad, MonadState (MultiZipper RuleTag Grapheme), MonadFail) via (StateT (MultiZipper RuleTag Grapheme) []) -- | Lift a partial modification function into a 'State'. Update state @@ -110,30 +144,57 @@ [] -> [(Nothing, s)] r -> first Just <$> r +-- | The result of matching a 'Feature' or 'Autosegment': either a +-- specific index in the 'Feature', or an indeterminate result (when +-- no indices matched) +data FeatureState = Index Int | Indeterminate + deriving (Show, Eq) + -- | Describes the output of a 'match' operation. data MatchOutput = MatchOutput - { -- | For each category matched, the index of the matched - -- grapheme in that category. + { -- | For each non-backreferenced category matched: the index of + -- the matched grapheme in that category. matchedCatIxs :: [Int] - -- | For each optional group whether it matched or not + -- | For each optional group: whether it matched or not , matchedOptionals :: [Bool] - -- | For each wildcard, the graphemes which it matched + -- | For each wildcard: the graphemes which it matched , matchedWildcards :: [[Grapheme]] - -- | For each Kleene star, how many repititions it matched + -- | For each Kleene star: how many repetitions it matched , matchedKleenes :: [Int] - -- | The graphemes which were matched + -- | The actual graphemes which were matched , matchedGraphemes :: [Grapheme] + -- | The features which were matched, by name + , matchedFeatures :: Map.Map String [FeatureState] + -- | Backreferenced categories which were matched, by ID + , matchedBackrefIds :: Map.Map String Int + -- | Backreferenced features which were matched, by ID + , matchedFeatureIds :: Map.Map String FeatureState } deriving (Show) +-- | Create 'MatchOutput' for next section of rule given last output +-- (preserving backreferences but emptying all other fields) +newOutput :: MatchOutput -> MatchOutput +newOutput m = MatchOutput + { matchedCatIxs = [] + , matchedOptionals = [] + , matchedWildcards = [] + , matchedKleenes = [] + , matchedGraphemes = [] + , matchedFeatures = Map.empty + , matchedBackrefIds = matchedBackrefIds m + , matchedFeatureIds = matchedFeatureIds m + } + +-- | The empty 'MatchOutput' +initialOutput :: MatchOutput +initialOutput = MatchOutput [] [] [] [] [] Map.empty Map.empty Map.empty + modifyMatchedGraphemes :: ([Grapheme] -> [Grapheme]) -> MatchOutput -> MatchOutput modifyMatchedGraphemes f MatchOutput{..} = MatchOutput{matchedGraphemes=f matchedGraphemes, ..} appendGrapheme :: MatchOutput -> Grapheme -> MatchOutput appendGrapheme out g = modifyMatchedGraphemes (++[g]) out -instance Semigroup MatchOutput where - (MatchOutput a1 b1 c1 d1 e1) <> (MatchOutput a2 b2 c2 d2 e2) = - MatchOutput (a1++a2) (b1++b2) (c1++c2) (d1++d2) (e1++e2) zipWith' :: [a] -> [b] -> (a -> b -> c) -> [c] zipWith' xs ys f = zipWith f xs ys @@ -144,15 +205,24 @@ insertAt :: Int -> a -> [a] -> [a] insertAt n a as = let (xs,ys) = splitAt n as in xs ++ (a:ys) +insertAtOptional :: Int -> Bool -> MatchOutput -> MatchOutput +insertAtOptional n o mz = mz { matchedOptionals = insertAt n o $ matchedOptionals mz } + insertAtCat :: Int -> Int -> MatchOutput -> MatchOutput insertAtCat n i mz = mz { matchedCatIxs = insertAt n i $ matchedCatIxs mz } insertAtKleene :: Int -> Int -> MatchOutput -> MatchOutput insertAtKleene n i mz = mz { matchedKleenes = insertAt n i $ matchedKleenes mz } +appendFeatureAt :: Int -> String -> FeatureState -> MatchOutput -> MatchOutput +appendFeatureAt n name fs out = out { matchedFeatures = Map.alter go name $ matchedFeatures out } + where + go Nothing = Just [fs] + go (Just fss) = Just $ insertAt n fs fss + -- | Match a single 'Lexeme' against a 'MultiZipper', and advance the -- 'MultiZipper' past the match. For each match found, returns the --- 'MatchOutput' tupled with the updated 'MultiZipper'. +-- updated 'MatchOutput' tupled with the updated 'MultiZipper'. match :: MatchOutput -- ^ The previous 'MatchOutput' -> Maybe Grapheme -- ^ The previously-matched grapheme, if any. (Used to match a 'Geminate'.) -> Lexeme Expanded 'Matched -- ^ The lexeme to match. @@ -160,29 +230,91 @@ -> [(MatchOutput, MultiZipper t Grapheme)] -- ^ The output: a tuple @(g, mz)@ as described below. match out prev (Optional l) mz = - (out <> MatchOutput [] [False] [] [] [], mz) : - matchMany (out <> MatchOutput [] [True] [] [] []) prev l mz + let i = length (matchedOptionals out) + in + (insertAtOptional i False out, mz) : + matchMany (insertAtOptional i True out) prev l mz +match out prev (GreedyOptional l) mz = + let i = length (matchedOptionals out) + m = matchMany (insertAtOptional i True out) prev l mz + in case m of + -- skip, but only if no matches + [] -> [(insertAtOptional i False out, mz)] + _ -> m match out prev (Wildcard l) mz = matchWildcard out prev l mz match out prev (Kleene l) mz = matchKleene out prev l mz -match out _ (Grapheme g) mz = (out <> MatchOutput [] [] [] [] [g],) <$> maybeToList (matchGrapheme g mz) +match out _ (Grapheme g) mz = (appendGrapheme out g,) <$> maybeToList (matchGrapheme g mz) match out prev (Category (FromElements gs)) mz = - concat $ zipWith' gs [0..] $ \e i -> + concat $ zipWith' gs [0..] $ \ls i -> -- make sure to insert new index BEFORE any new ones which -- might be added by the recursive call first (insertAtCat (length $ matchedCatIxs out) i) <$> - case e of - Left g -> match out prev (Grapheme g :: Lexeme Expanded a) mz - Right ls -> matchMany out prev ls mz + matchMany out prev ls mz +match out prev (GreedyCategory c) mz = + -- Take first match only + case match out prev (Category c) mz of + [] -> [] + (m:_) -> [m] match out prev Geminate mz = case prev of Nothing -> [] - Just prev' -> (out <> MatchOutput [] [] [] [] [prev'],) <$> maybeToList (matchGrapheme prev' mz) + Just prev' -> (appendGrapheme out prev',) <$> maybeToList (matchGrapheme prev' mz) +match out prev (Backreference (Left ident) (FromElements gs)) mz + | Nothing <- Map.lookup ident (matchedBackrefIds out) = + -- first occurrence, set backref + -- similar to Category case above + concat $ zipWith' gs [0..] $ \ls i -> + first (\o -> o { matchedBackrefIds = Map.insert ident i $ matchedBackrefIds o }) + <$> matchMany out prev ls mz match out prev (Backreference i (FromElements gs)) mz = do - e <- maybeToList $ - (gs !?) =<< matchedCatIxs out !? (i-1) - case e of - Left g -> match out prev (Grapheme g :: Lexeme Expanded a) mz - Right ls -> matchMany out prev ls mz + ls <- maybeToList $ case i of + Left i' -> (gs !?) =<< Map.lookup i' (matchedBackrefIds out) + Right i' -> (gs !?) =<< matchedCatIxs out !? (i'-1) + matchMany out prev ls mz +match out prev (Feature r _n (Just ident) kvs l) mz + | Just fs <- Map.lookup ident (matchedFeatureIds out) = do + -- similar to next case, but just check that features are the same + -- (NB. feature name is irrelevant for this) + (out', mz') <- match out prev l mz + let fs' = case matchedGraphemes out' of + gs | Just g <- lastMay gs -> checkFeature kvs g + _ -> Indeterminate + satisfied = case (fs, fs') of + (Indeterminate, _) -> True + (_, Indeterminate) -> True + _ -> + if r + then fs /= fs' -- reverse comparison + else fs == fs' + if satisfied + then pure (out', mz') + else [] +match out prev (Feature _r n ident kvs l) mz = do + let i = maybe 0 length $ Map.lookup n (matchedFeatures out) + (out', mz') <- match out prev l mz + let fs = case matchedGraphemes out' of + gs | Just g <- lastMay gs -> checkFeature kvs g + _ -> Indeterminate + pure $ case ident of + Nothing -> (appendFeatureAt i n fs out', mz') + Just ident' -> + ( out' { matchedFeatureIds = Map.insert ident' fs $ matchedFeatureIds out' } + , mz' + ) +match out prev (Autosegment n kvs gs) mz = + -- act as 'Category' + 'Feature', without capture + -- and accounting for unmatchable values + gs >>= \g -> do + let i = maybe 0 length $ Map.lookup n (matchedFeatures out) + (out', mz') <- match out prev (Grapheme g) mz + let fs = checkFeature kvs (g, True) + pure (appendFeatureAt i n fs out', mz') +checkFeature :: Eq a => [[a]] -> a -> FeatureState +checkFeature [] _ = Indeterminate +checkFeature (gs:gss) x + | Just i <- x `elemIndex` gs = Index i + | otherwise = checkFeature gss x + matchKleene :: MatchOutput -> Maybe Grapheme @@ -208,7 +340,7 @@ where go matched out prev l mz = case match out prev l mz of [] -> maybeToList (consume mz) >>= \case - (GBoundary, _) -> [] -- don't continue past word boundary + ("#", _) -> [] -- don't continue past word boundary (g, mz') -> go (g:matched) (appendGrapheme out g) prev l mz' r -> r <&> \(out', mz') -> ( out' @@ -224,9 +356,7 @@ matchGraphemeP p mz = value mz >>= \cs -> if p cs then fwd mz else Nothing -- | Match a list of several 'Lexeme's against a --- 'MultiZipper'. Arguments and output are the same as with 'match', --- though the outputs are given as a list of indices and graphemes --- rather than as a single index and grapheme. +-- 'MultiZipper'. Arguments and output are as with 'match'. matchMany :: MatchOutput -> Maybe Grapheme -> [Lexeme Expanded 'Matched] @@ -237,13 +367,6 @@ match out prev l mz >>= \(out', mz') -> matchMany out' (lastMay (matchedGraphemes out') <|> prev) ls mz' --- | 'matchMany' without any previous match output. -matchMany' :: Maybe Grapheme - -> [Lexeme Expanded 'Matched] - -> MultiZipper t Grapheme - -> [(MatchOutput, MultiZipper t Grapheme)] -matchMany' = matchMany (MatchOutput [] [] [] [] []) - -- Small utility function, not exported lastMay :: [a] -> Maybe a lastMay l = if null l then Nothing else Just (last l) @@ -253,10 +376,11 @@ , ixInOptionals :: Int , ixInWildcards :: Int , ixInKleenes :: Int + , ixInFeatures :: Map.Map String Int , forcedCategory :: Maybe CategoryNumber } deriving (Show) -data CategoryNumber = CategoryNumber Int | Nondeterministic +data CategoryNumber = CategoryNumber Int | CategoryId String | Nondeterministic deriving (Show) advanceCategory :: ReplacementIndices -> Int -> (CategoryNumber, ReplacementIndices) @@ -284,6 +408,12 @@ let i = ixInKleenes ix in (i, ix { ixInKleenes = i+1 }) +advanceFeature :: String -> ReplacementIndices -> Maybe (Int, ReplacementIndices) +advanceFeature n ix = + case Map.lookup n (ixInFeatures ix) of + Nothing -> Just (0, ix { ixInFeatures = Map.insert n 1 $ ixInFeatures ix }) + Just i -> Just (i, ix { ixInFeatures = Map.adjust (+1) n $ ixInFeatures ix }) + forceCategory :: CategoryNumber -> ReplacementIndices -> ReplacementIndices forceCategory i ixs = ixs { forcedCategory = Just i } @@ -302,7 +432,7 @@ -> [MultiZipper t Grapheme] mkReplacement out = \ls -> fmap (fst . snd) . go startIxs ls . (,Nothing) where - startIxs = ReplacementIndices 0 0 0 0 Nothing + startIxs = ReplacementIndices 0 0 0 0 Map.empty Nothing go :: ReplacementIndices @@ -329,12 +459,19 @@ case matchedCatIxs out !? ci of Just i | Just g' <- gs !? i -> case g' of - Left g -> [(ixs', (insert g mz, Just g))] - Right ls -> go ixs' ls (mz, prev) - _ -> [(ixs', (insert (GMulti "\xfffd") mz, Nothing))] -- Unicode replacement character + [Grapheme g] -> [(ixs', (insert g mz, Just g))] + ls -> go ixs' ls (mz, prev) + _ -> [(ixs', (insert "\xfffd" mz, Nothing))] -- Unicode replacement character + (CategoryId ci, ixs') -> -- as above + case Map.lookup ci (matchedBackrefIds out) of + Just i | Just g' <- gs !? i -> + case g' of + [Grapheme g] -> [(ixs', (insert g mz, Just g))] + ls -> go ixs' ls (mz, prev) + _ -> [(ixs', (insert "\xfffd" mz, Nothing))] -- Unicode replacement character (Nondeterministic, ixs') -> gs >>= \case - Left g -> [(ixs', (insert g mz, Just g))] - Right ls -> go ixs' ls (mz, prev) + [Grapheme g] -> [(ixs', (insert g mz, Just g))] + ls -> go ixs' ls (mz, prev) replaceLex ixs (Optional ls) mz prev = let (co, ixs') = advanceOptional ixs in case matchedOptionals out !? co of @@ -351,7 +488,10 @@ replaceLex ixs Discard mz prev = let (_, ixs') = advanceCategory ixs numCatsMatched in [(ixs', (mz, prev))] - replaceLex ixs (Backreference i c) mz prev = + replaceLex ixs (Backreference (Left i) c) mz prev = + let ixs' = forceCategory (CategoryId i) ixs + in replaceLex ixs' (Category c) mz prev + replaceLex ixs (Backreference (Right i) c) mz prev = let ixs' = forceCategory (CategoryNumber $ i-1) ixs -- 1-based indexing! in replaceLex ixs' (Category c) mz prev replaceLex ixs (Multiple c) mz prev = @@ -368,34 +508,111 @@ in case matchedKleenes out !? i of Just n -> go ixs' (replicate n l) (mz, prev) Nothing -> [(ixs', (mz, prev))] + replaceLex ixs (Feature r n ident kvs l) mz prev = + let (fs, ixs') = case ident of + Nothing -> case advanceFeature n ixs of + Just (i, ixs_) + | Just fss <- Map.lookup n (matchedFeatures out) + , Just fs_ <- fss !? i + -> (fs_, ixs_) + _ -> (Indeterminate, ixs) + Just ident' -> case Map.lookup ident' (matchedFeatureIds out) of + Just fs_ -> (fs_, ixs) + Nothing -> (Indeterminate, ixs) + in do + (ixs'', (mz', prev')) <- replaceLex ixs' l mz prev + case (kvs, prev') of + (gs:_, Just g) | g /= "#" -> do + g' <- case fs of + Index i -> applyFeature kvs g <$> + if r + then filter (/=i) [0 .. length gs - 1] + else pure i + Indeterminate -> applyFeature kvs g <$> [0 .. length gs - 1] + -- now overwrite previous grapheme + let mz'' = zap (Just . const g') mz' + pure (ixs'', (mz'', Just g')) + -- cannot modify nonexistent or boundary grapheme, + -- or if there are zero key-value pairs + _ -> pure (ixs'', (mz', prev')) + replaceLex ixs (Autosegment _ _ []) mz prev = pure (ixs, (mz, prev)) + replaceLex ixs (Autosegment n kvs (gBase:_)) mz prev = + -- ignore other segments, just produce a single one + -- as if modulated by a 'Feature', but accounting for Nothing values + let (fs, ixs') = case advanceFeature n ixs of + Just (i, ixs_) + | Just fss <- Map.lookup n (matchedFeatures out) + , Just fs_ <- fss !? i + -> (fs_, ixs_) + _ -> (Indeterminate, ixs) + in do + (ixs'', (mz', prev')) <- replaceLex ixs' (Grapheme gBase) mz prev + case prev' of + Just g | g /= "#" -> do + g' <- case fs of + Index i + | Just g'' <- applyFeature' kvs g i + -> pure g'' + _ -> applyFeatureInd' kvs g + -- now overwrite previous grapheme + let mz'' = zap (Just . const g') mz' + pure (ixs'', (mz'', Just g')) + -- cannot modify nonexistent or boundary grapheme, + -- or if there are zero key-value pairs + _ -> pure (ixs'', (mz', prev')) +applyFeature :: [[String]] -> String -> Int -> String +applyFeature [] g _ = g +applyFeature (gs:gss) g i + | g `elem` gs = fromMaybe "\xfffd" $ gs !? i + | otherwise = applyFeature gss g i + +applyFeature' :: [[(String, Bool)]] -> String -> Int -> Maybe String +applyFeature' [] g _ = Just g +applyFeature' (gs:gss) g i = case lookup g gs of + Just _ -> case gs !? i of + Just (g', True) -> Just g' + Just (_, False) -> Nothing -- this grapheme was excluded, need to act as if Indeterminate + Nothing -> Just "\xfffd" + Nothing -> applyFeature' gss g i + +applyFeatureInd' :: [[(String, Bool)]] -> String -> [String] +applyFeatureInd' [] g = [g] +applyFeatureInd' (gs:gss) g = case lookup g gs of + Just _ -> mapMaybe note gs + Nothing -> applyFeatureInd' gss g + where + note (a, True) = Just a + note _ = Nothing + -- | Given a 'Rule' and a 'MultiZipper', determines whether the -- 'exception' of that rule (if any) applies starting at the current --- position of the 'MultiZipper'; if it does, returns the index of the --- first element of each matching 'target'. +-- position of the 'MultiZipper'; if it does, returns the index at +-- which each matching target begins. exceptionAppliesAtPoint - :: [Lexeme Expanded 'Matched] - -> Environment Expanded + :: [Lexeme Expanded 'Matched] -- ^ Target + -> Environment Expanded -- ^ Exceptional environment -> MultiZipper RuleTag Grapheme -> [Int] exceptionAppliesAtPoint target (ex1, ex2) mz = fmap fst $ flip runRuleAp mz $ do - ex1Out <- RuleAp $ matchMany' Nothing ex1 + ex1Out <- RuleAp $ matchMany initialOutput Nothing ex1 pos <- gets curPos - MatchOutput{matchedGraphemes} <- RuleAp $ matchMany' Nothing target - _ <- RuleAp $ matchMany ex1Out (listToMaybe matchedGraphemes) ex2 + targetOut@MatchOutput{matchedGraphemes} <- RuleAp $ matchMany (newOutput ex1Out) Nothing target + _ <- RuleAp $ matchMany (newOutput targetOut) (listToMaybe matchedGraphemes) ex2 return pos --- | Given a target and environment, determine if they rule --- matches. If so, for each match, set the appropriate 'RuleTag's and --- return a tuple of @(is, gs)@, where @gs@ is a list of matched --- t'Grapheme's, and @is@ is a list of indices, one for each --- 'Category' lexeme matched. +-- | Given a target and environment, determine if the rule matches at +-- the current position of the 'MultiZipper'. If so, for each match, +-- return the 'MatchOutput' and the output 'MultiZipper'. The output +-- 'MultiZipper' is advanced past the matched environment, and has its +-- 'RuleTag's set as appropriate. matchRuleAtPoint - :: [Lexeme Expanded 'Matched] - -> Environment Expanded + :: [Lexeme Expanded 'Matched] -- ^ Target + -> Environment Expanded -- ^ Environment -> MultiZipper RuleTag Grapheme -> [(MatchOutput, MultiZipper RuleTag Grapheme)] matchRuleAtPoint target (env1,env2) mz = flip runRuleAp mz $ do - env1Out <- RuleAp $ matchMany' Nothing env1 + let initMO = MatchOutput [] [] [] [] [] Map.empty Map.empty Map.empty + env1Out <- RuleAp $ matchMany initMO Nothing env1 -- start of target needs to be INSIDE 'MultiZipper'! -- otherwise get weird things like /x/#_ resulting in -- #abc#→#xabd#x when it should be #abc#→#xabc# @@ -403,22 +620,29 @@ True -> RuleAp $ const [] False -> do modify $ tag TargetStart - matchResult <- RuleAp $ matchMany' Nothing target + matchResult <- RuleAp $ matchMany (newOutput env1Out) Nothing target modify $ tag TargetEnd - _ <- RuleAp $ matchMany env1Out (listToMaybe $ matchedGraphemes matchResult) env2 + env2Out <- RuleAp $ matchMany (newOutput matchResult) + (listToMaybe $ matchedGraphemes matchResult) env2 + -- environment can affect replacement via IDs + -- only, so collect those return matchResult + { matchedFeatureIds = matchedFeatureIds env2Out + , matchedBackrefIds = matchedBackrefIds env2Out + } +-- | Status of a rule application at a single location. data RuleStatus - = SuccessNormal -- ^ Rule was successful, no need for special handling - | SuccessEpenthesis -- ^ Rule was successful, but cursor was not advanced: need to avoid infinite loop + = SuccessNormal -- ^ Rule was successful, with no need for special handling + | SuccessEpenthesis -- ^ Rule was successful, but cursor was not advanced (need to avoid infinite loop) | Failure -- ^ Rule failed deriving (Eq, Show) -- | Given a 'Rule', determine if the rule matches at the current -- point; if so, apply the rule, adding appropriate tags. applyOnce :: Rule Expanded -> StateT (MultiZipper RuleTag Grapheme) [] RuleStatus -applyOnce r@Rule{target, replacement, exception} = - modify (tag AppStart) >> go (environment r) +applyOnce Rule{..} = + modify (tag AppStart) >> go environment where go [] = return Failure go (env:envs) = do @@ -429,19 +653,28 @@ Nothing -> pure [] Just ex -> gets $ join . toList . extend' (exceptionAppliesAtPoint target ex) - gets (locationOf TargetStart) >>= \p -> - if maybe True (`elem` exs) p - then return Failure - else do - originalWord <- get + originalWord <- get + let pMay = locationOf TargetStart originalWord + pMay' = locationOf PrevEnd originalWord + case pMay of + Nothing -> error "applyOnce: start of target was not tagged" + Just p + | p `elem` exs -> return Failure + -- do not apply rule if it would be + -- applied twice to the same substring + | Just p' <- pMay', p < p' -> return Failure + | otherwise -> do modifyMay $ delete (TargetStart, TargetEnd) modifyMay $ seek TargetStart modifyM $ \w -> let replacedWords = mkReplacement out replacement w - in case sporadic (flags r) of + in case sporadic flags of -- make sure to re-insert original word PerApplication -> originalWord : replacedWords _ -> replacedWords + -- we want TargetEnd to move forward as the replacement is added, + -- but not TargetStart, so restore its old position + modifyMay $ tagAt TargetStart p return $ -- An epenthesis rule will cause an infinite loop -- if it matched no graphemes before the replacement @@ -457,232 +690,293 @@ -> Rule Expanded -> MultiZipper RuleTag Grapheme -> Maybe (MultiZipper RuleTag Grapheme) -setupForNextApplication status Rule{flags=Flags{applyDirection}} = - fmap untag . case applyDirection of - RTL -> seek AppStart >=> bwd - LTR -> case status of - SuccessNormal -> seek TargetEnd - SuccessEpenthesis -> - -- need to move forward if applying an epenthesis rule to avoid an infinite loop - seek TargetEnd >=> fwd - Failure -> seek AppStart >=> fwd +setupForNextApplication status Rule{flags=Flags{nonOverlappingTarget}} = + resetTags <=< case status of + SuccessNormal -> + seek (if nonOverlappingTarget then TargetEnd else TargetStart) + SuccessEpenthesis -> + -- need to move forward if applying an epenthesis rule to avoid an infinite loop + seek TargetEnd >=> fwd + Failure -> seek AppStart >=> fwd + where + resetTags mz = + -- update PrevEnd to farthest replaced position on success, + -- or keep it the same on failure + let p = locationOf TargetEnd mz + p' = locationOf PrevEnd mz + newPrevEnd = case status of + Failure -> p' + _ -> max p p' + in maybe Just (tagAt PrevEnd) newPrevEnd $ untag mz -- | Apply a 'Rule' to a 'MultiZipper'. The application will start at -- the beginning of the 'MultiZipper', and will be repeated as many -- times as possible. Returns all valid results. -applyRule :: Rule Expanded -> MultiZipper RuleTag Grapheme -> [MultiZipper RuleTag Grapheme] -applyRule r = \mz -> -- use a lambda so mz isn't shadowed in the where block - let startingPos = case applyDirection $ flags r of - LTR -> toBeginning mz - RTL -> toEnd mz - result = repeatRule (applyOnce r) startingPos +-- +-- Note: unlike 'applyRuleStr', this can produce duplicate outputs. +applyRuleMZ :: Rule Expanded -> MultiZipper RuleTag Grapheme -> [MultiZipper RuleTag Grapheme] +applyRuleMZ r = \mz -> -- use a lambda so mz isn't shadowed in the where block + let result = case applyDirection (flags r) of + LTR -> repeatRule $ toBeginning mz + -- Apply RTL by reversing both rule and word + RTL -> fmap reverseMZ $ repeatRule $ toBeginning $ reverseMZ mz in case sporadic (flags r) of PerWord -> mz : result _ -> result -- PerApplication handled in 'applyOnce' where + r' = case applyDirection (flags r) of + LTR -> r + RTL -> Rule + { target = reverse $ target r + , replacement = reverse $ replacement r + , environment = reverseEnv <$> environment r + , exception = reverseEnv <$> exception r + , flags = flags r + , plaintext = plaintext r + } + + reverseEnv (e1, e2) = (reverse e2, reverse e1) + repeatRule - :: StateT (MultiZipper RuleTag Grapheme) [] RuleStatus - -> MultiZipper RuleTag Grapheme + :: MultiZipper RuleTag Grapheme -> [MultiZipper RuleTag Grapheme] - repeatRule m mz = runStateT m mz >>= \(status, mz') -> - if (status /= Failure) && applyOnceOnly (flags r) + repeatRule mz = runStateT (applyOnce r') mz >>= \(status, mz') -> + if (status /= Failure) && applyOnceOnly (flags r') then [mz'] - else case setupForNextApplication status r mz' of - Just mz'' -> repeatRule m mz'' - Nothing -> [mz'] + else maybe [mz'] repeatRule (setupForNextApplication status r' mz') -- | Check if a 'MultiZipper' matches a 'Filter'. filterMatches :: Filter Expanded -> MultiZipper RuleTag Grapheme -> Bool filterMatches (Filter _ ls) = go . toBeginning where go mz = - let mzs = matchMany' Nothing ls mz + let mzs = matchMany initialOutput Nothing ls mz in case mzs of [] -> maybe False go $ fwd mz -- try next position if there is one _ -> True -- filter has matched -- | Check that the 'MultiZipper' contains only graphemes listed in --- the given 'CategoriesDecl', replacing all unlisted graphemes with --- U+FFFD. +-- the given list, replacing all unlisted graphemes other than @"#"@ +-- with U+FFFD. checkGraphemes :: [Grapheme] -> MultiZipper RuleTag Grapheme -> MultiZipper RuleTag Grapheme checkGraphemes gs = fmap $ \case - GBoundary -> GBoundary - g -> if g `elem` gs then g else GMulti "\xfffd" + "#" -> "#" + g -> if g `elem` gs then g else "\xfffd" -- | Apply a 'Statement' to a 'MultiZipper', returning zero, one or -- more results. -applyStatement - :: Statement Expanded [Grapheme] +applyStatementMZ + :: Statement Expanded GraphemeList -> MultiZipper RuleTag Grapheme -> [MultiZipper RuleTag Grapheme] -applyStatement (RuleS r) mz = applyRule r mz -applyStatement (FilterS f) mz +applyStatementMZ (RuleS r) mz = applyRuleMZ r mz +applyStatementMZ (FilterS f) mz | filterMatches f mz = [] | otherwise = [mz] -applyStatement (DirectiveS gs) mz = [checkGraphemes gs mz] +applyStatementMZ ReportS mz = [mz] +applyStatementMZ (DeclS (GraphemeList noreplace gs)) mz + | noreplace = [mz] + | otherwise = [checkGraphemes gs mz] --- | Apply a single 'Rule' to a word. --- --- Note: duplicate outputs from this function are removed. To keep --- duplicates, use the lower-level internal function 'applyRule' --- directly. +-- | Apply a single sound change 'Rule' to a word. applyRuleStr :: Rule Expanded -> PWord -> [PWord] -- Note: 'fromJust' is safe here as 'apply' should always succeed applyRuleStr r = addBoundaries >>> fromListStart - >>> applyRule r + >>> applyRuleMZ r >>> fmap (toList >>> removeBoundaries) >>> nubOrd --- | Apply a single 'Statement' to a word. --- --- Note: as with 'applyRuleStr', duplicate outputs from this function --- are removed. To keep duplicates, use the lower-level internal --- function 'applyStatement' directly. -applyStatementStr :: Statement Expanded [Grapheme] -> PWord -> [PWord] +-- | Apply a single 'Statement' to a word. The statement can be a +-- sound change, a filter, or any other element which remains in a +-- sound change file after expansion. +applyStatementStr :: Statement Expanded GraphemeList -> PWord -> [PWord] applyStatementStr st = addBoundaries >>> fromListStart - >>> applyStatement st + >>> applyStatementMZ st >>> fmap (toList >>> removeBoundaries) >>> nubOrd --- | A log item representing a single application of an action. (In --- practise this will usually be a 'Statement'.) Specifies the action --- which was applied, as well as the ‘before’ and ‘after’ states. -data LogItem r = ActionApplied - { action :: r - , input :: PWord - , output :: Maybe PWord - } deriving (Show, Functor, Generic, NFData) +-- | A log item representing a single action @r@ (usually a +-- 'Statement'), and the result from that action. +data LogItem r + = ActionApplied r (Maybe PWord) + -- ^ The word was modified: gives the output word, or 'Nothing' if + -- the wordwas deleted + | ReportWord PWord + -- ^ Corresponds to 'ReportS', giving the intermediate form to report + deriving (Show, Functor, Generic, NFData) --- | Logs the evolution of a 'PWord' as various actions are applied to --- it. The actions (usually 'Statement's) are of type @r@. -data PWordLog r = PWordLog - { initialWord :: PWord - -- ^ The initial word, before any actions have been applied - , derivations :: [(Maybe PWord, r)] - -- ^ The state of the word after each action @r@, stored alongside - -- the action which was applied at each point - } deriving (Show, Functor, Generic, NFData) +-- action :: LogItem r -> Maybe r +-- action (ActionApplied r _ _) = Just r +-- action (ReportWord _) = Nothing -toPWordLog :: [LogItem r] -> Maybe (PWordLog r) -toPWordLog [] = Nothing -toPWordLog ls@(l : _) = Just $ PWordLog - { initialWord = input l - , derivations = (\ActionApplied{..} -> (output, action)) <$> ls - } +logOutput :: LogItem r -> Maybe PWord +logOutput (ActionApplied _ o) = o +logOutput (ReportWord o) = Just o --- | Render a single 'PWordLog' to rows of an HTML table. For +-- | Logs the evolution of a word as it undergoes sound changes and +-- other actions. +data Log r = Log + { inputWord :: PWord + -- ^ The input word, before any actions have been applied + , derivations :: [LogItem r] + -- ^ All actions which were applied, with the state of the word at + -- each point + } deriving (Show, Functor, Generic, NFData) + +-- | Pretty-print a single 'Log' as rows of an HTML table. For -- instance, the example log given in the documentation for -- 'reportAsText' would be converted to the following HTML: -- --- > "tara→tazha(r / zh)→tazh(V / / _ #)" +-- > tara→tazha(r / zh)→tazh(V / / _ #) -- --- Which might be displayed in an HTML table as something like the --- following: +-- Which might be displayed in a browser as follows: -- --- +------+---+-------+-------------+ +-- +------+---+-------+-------------+ -- | tara | → | tazha | (r / zh) | --- +------+---+-------+-------------+ +-- +------+---+-------+-------------+ -- | | → | tazh | (V / / _ #) | --- +------+---+-------+-------------+ +-- +------+---+-------+-------------+ -reportAsHtmlRows :: (r -> String) -> PWordLog r -> String -reportAsHtmlRows render item = go (concatWithBoundary $ initialWord item) (derivations item) +reportAsHtmlRows + :: (r -> String) -- ^ Specifies how to pretty-print actions as text + -> Log r -> String +reportAsHtmlRows render item = go (concatWithBoundary $ inputWord item) (derivations item) where go _ [] = "" - go cell1 ((output, action) : ds) = + go cell1 (ActionApplied action output : ds) = ("" ++ cell1 ++ "→" ++ maybe "deleted" concatWithBoundary output ++ "(" ++ render action ++ ")") ++ go "" ds + go cell1 (ReportWord w : ds) = + ("" ++ cell1 ++ "→" + ++ concatWithBoundary w + ++ "(report)") + ++ go "" ds --- | Render a single 'PWordLog' to plain text. For instance, this log: +-- | Pretty-print a 'Log' as plain text. For instance, this log: -- --- > PWordLog --- > { initialWord = ["t", "a", "r", "a"] --- > , derivations = --- > [ (["t", "a", "zh", "a"], "r / zh") --- > , (["t", "a", "zh"], "V / / _ #") --- > ] --- > } +-- @ +-- 'Log' +-- { 'inputWord' = ["t", "a", "r", "a"] +-- , 'derivations' = +-- [ ('Just' ["t", "a", "zh", "a"], "r \/ zh") +-- , ('Just' ["t", "a", "zh"], "V \/ \/ _ #") +-- ] +-- } +-- @ -- --- Would render as: +-- Would be pretty-printed by @'reportAsText' 'id'@ as: -- -- > tara -- > -> tazha (r / zh) -- > -> tazh (V / / _ #) -reportAsText :: (r -> String) -> PWordLog r -> String +reportAsText + :: (r -> String) -- ^ Specifies how to pretty-print actions as text + -> Log r -> String reportAsText render item = unlines $ - concatWithBoundary (initialWord item) : fmap toLine (alignWithPadding $ derivations item) + concatWithBoundary (inputWord item) : fmap toLine (alignWithPadding $ derivations item) where - alignWithPadding :: [(Maybe PWord, b)] -> [([Char], b)] alignWithPadding ds = - let (rawOutputs, actions) = unzip ds + let (rawOutputs, actions) = unzip $ toPrintable <$> ds outputs = maybe "(deleted)" concatWithBoundary <$> rawOutputs maxlen = maximum $ length <$> outputs padded = outputs <&> \o -> o ++ replicate (maxlen - length o) ' ' in zip padded actions - toLine (output, action) = " -> " ++ output ++ " (" ++ render action ++ ")" + toLine (output, action) = " -> " ++ output ++ " (" ++ action ++ ")" + toPrintable (ActionApplied a o) = (o, render a) + toPrintable (ReportWord w) = (Just w, "report") + -- | Apply a single 'Statement' to a word. Returns a 'LogItem' for -- each possible result, or @[]@ if the rule does not apply and the -- input is returned unmodified. -applyStatementWithLog - :: Statement Expanded [Grapheme] +applyStatement + :: Statement Expanded GraphemeList -> PWord - -> [LogItem (Statement Expanded [Grapheme])] -applyStatementWithLog st w = case applyStatementStr st w of - [] -> [ActionApplied st w Nothing] + -> [LogItem (Statement Expanded GraphemeList)] +applyStatement ReportS w = [ReportWord w] +applyStatement st w = case applyStatementStr st w of + [] -> [ActionApplied st Nothing] [w'] | w' == w -> [] - r -> ActionApplied st w . Just <$> r + r -> ActionApplied st . Just <$> r --- | Apply 'SoundChanges' to a word. For each possible result, returns --- a 'LogItem' for each 'Statement' which altered the input. -applyChangesWithLog - :: SoundChanges Expanded [Grapheme] +-- | Apply a set of 'SoundChanges' to a word, returning a log of which +-- sound changes applied to produce each output word. +applyChanges + :: SoundChanges Expanded GraphemeList -> PWord - -> [[LogItem (Statement Expanded [Grapheme])]] -applyChangesWithLog [] _ = [[]] -applyChangesWithLog (st:sts) w = - case applyStatementWithLog st w of - [] -> applyChangesWithLog sts w - outputActions -> outputActions >>= \l@ActionApplied{output} -> - case output of - Just w' -> (l :) <$> applyChangesWithLog sts w' - -- apply no further changes to a deleted word - Nothing -> [[l]] + -> [Log (Statement Expanded GraphemeList)] +applyChanges scs w = go scs w <&> \ls -> Log + { inputWord = w + , derivations = ls + } + where + go [] _ = [[]] -- one result, no changes applied + go (st:sts) w' = + case applyStatement st w' of + [] -> go sts w' + outputActions -> outputActions >>= \case + l@(ReportWord w'') -> (l :) <$> go sts w'' + l@(ActionApplied _ output) -> case output of + Just w'' -> (l :) <$> go sts w'' + -- apply no further changes to a deleted word + Nothing -> [[l]] --- | Apply 'SoundChanges' to a word, returning an 'PWordLog' --- for each possible result. -applyChangesWithLogs - :: SoundChanges Expanded [Grapheme] - -> PWord - -> [PWordLog (Statement Expanded [Grapheme])] -applyChangesWithLogs scs w = mapMaybe toPWordLog $ applyChangesWithLog scs w +-- | Returns the final output from a sound change log. +getOutput :: Log r -> Maybe PWord +getOutput l = case derivations l of + d@(_:_) -> logOutput $ last d + [] -> Just $ inputWord l --- | Apply a set of 'SoundChanges' to a word. -applyChanges :: SoundChanges Expanded [Grapheme] -> PWord -> [PWord] -applyChanges sts w = - mapMaybe lastOutput $ applyChangesWithLog sts w +-- | Returns, in order: the input word, any intermediate results from +-- 'ReportS', and then the final output. +getReports :: Log r -> [PWord] +getReports l = inputWord l : go (derivations l) where - -- If no changes were applied, output is same as input - lastOutput [] = Just w - lastOutput ls = output $ last ls + go [] = [] + go [ActionApplied _ (Just w')] = [w'] + go (ReportWord w':ls) = w' : go ls + go (_:ls) = go ls --- | Apply 'SoundChanges' to a word returning the final results, as --- well as a boolean value indicating whether the word should be --- highlighted in a UI due to changes from its initial value. (Note --- that this accounts for 'highlightChanges' values.) -applyChangesWithChanges :: SoundChanges Expanded [Grapheme] -> PWord -> [(Maybe PWord, Bool)] -applyChangesWithChanges sts w = applyChangesWithLog sts w <&> \case - [] -> (Just w, False) - logs -> (output $ last logs, hasChanged logs) +-- | Returns the final output from a sound change log, as well as an +-- indication of whether any sound changes have applied to it +-- (accounting for 'highlightChanges' flags). +getChangedOutputs :: Log (Statement c d) -> Maybe (PWord, Bool) +getChangedOutputs l = case derivations l of + [] -> Just (inputWord l, False) + logs -> case logOutput (last logs) of + Just out -> Just (out, hasChanged logs) + Nothing -> Nothing where hasChanged = any $ \case - ActionApplied (RuleS rule) _ _ -> highlightChanges $ flags rule - ActionApplied (FilterS _) _ _ -> False -- cannot highlight nonexistent word - ActionApplied (DirectiveS _) _ _ -> True + ActionApplied (RuleS rule) _ -> highlightChanges $ flags rule + ActionApplied (FilterS _) _ -> False -- cannot highlight nonexistent word + ActionApplied (DeclS _) _ -> True + ActionApplied ReportS _ -> False -- reporting a word yields no change + ReportWord _ -> False + +-- | A combination of 'getOutput' and 'getChangedOutputs': returns all +-- intermediate results, as well as whether each has undergone any +-- sound changes. +getChangedReports :: Log (Statement c d) -> [(PWord, Bool)] +getChangedReports l = (inputWord l, False) : case derivations l of + [] -> [] + ls -> go False ls + where + go _ [] = [] + go hasChanged (ActionApplied action _:ls) = + let hasChanged' = case action of + RuleS rule -> hasChanged || highlightChanges (flags rule) + _ -> hasChanged + in go hasChanged' ls + go hasChanged (ReportWord w':ls) = (w', hasChanged) : go hasChanged ls + +-- | Apply a set of 'SoundChanges' to a word, returning the final +-- output word(s) as well as any intermediate results from 'ReportS', +-- each with a boolean marking changed results (as with 'applyChangesWithChanges'). diff --git a/src/Brassica/SoundChange/Apply/Internal/MultiZipper.hs b/src/Brassica/SoundChange/Apply/Internal/MultiZipper.hs --- a/src/Brassica/SoundChange/Apply/Internal/MultiZipper.hs +++ b/src/Brassica/SoundChange/Apply/Internal/MultiZipper.hs @@ -1,11 +1,16 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE TupleSections #-} -{-| __Warning:__ This module is __internal__, and does __not__ follow - the Package Versioning Policy. It may be useful for extending - Brassica, but be prepared to track development closely if you import - this module. --} +-- | +-- Module : Brassica.SoundChange.Apply.Internal.MultiZipper +-- Copyright : See LICENSE file +-- License : BSD3 +-- Maintainer : Brad Neimann +-- +-- __Warning:__ This module is __internal__, and does __not__ follow +-- the Package Versioning Policy. It may be useful for extending +-- Brassica, but be prepared to track development closely if you import +-- this module. module Brassica.SoundChange.Apply.Internal.MultiZipper ( MultiZipper -- * Conversion @@ -32,6 +37,7 @@ -- * Modification , insert , insertMany + , reverseMZ , zap , tag , tagAt @@ -63,11 +69,11 @@ -- positioned at the index one past the end of the list, rather than -- at the last element of the list. Although this makes some functions -- slightly more complex — most notably, 'value' becomes non-total — --- it makes other algorithms simpler. For instance, this lets --- functions processing a 'MultiZipper' to process a portion of the --- 'MultiZipper' and then move to the next element immediately after --- the processed portion, allowing another function to be run to --- process the next part of the 'MultiZipper'.) +-- it makes sound changes application easier to implement. In +-- particular, it means that functions processing a portion of a +-- 'MultiZipper' can finish by moving to the next element immediately +-- after the processed portion; any subsequent function will then +-- continue by processing the next part of the 'MultiZipper'.) data MultiZipper t a = MultiZipper (V.Vector a) Int (M.Map t Int) deriving (Show, Functor, Foldable, Traversable) @@ -87,6 +93,16 @@ -- | Get the list stored in a 'MultiZipper'. toList :: MultiZipper t a -> [a] toList (MultiZipper as _ _) = V.toList as + +-- | Reverse the contents of a 'MultiZipper', ensuring its current +-- position and tags remain attatched to their elements. +reverseMZ :: MultiZipper t a -> MultiZipper t a +reverseMZ (MultiZipper as pos ts) = + let l = length as + in MultiZipper + (V.reverse as) + (l - pos) + (M.map (l-) ts) -- | The current position of the 'MultiZipper'. curPos :: MultiZipper t a -> Int diff --git a/src/Brassica/SoundChange/Category.hs b/src/Brassica/SoundChange/Category.hs deleted file mode 100644 --- a/src/Brassica/SoundChange/Category.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TupleSections #-} - -module Brassica.SoundChange.Category - ( Categories - , Brassica.SoundChange.Category.lookup - , values - , ExpandError(..) - , expand - , expandRule - , extendCategories - , expandSoundChanges - ) where - -import Prelude hiding (lookup) -import Control.DeepSeq (NFData) -import Control.Monad (foldM, unless) -import Control.Monad.State.Strict (StateT, evalStateT, lift, get, put, gets) -import Data.Containers.ListUtils (nubOrd) -import Data.List (intersect, transpose, foldl') -import Data.Maybe (mapMaybe, catMaybes) -import GHC.Generics (Generic) - -import qualified Data.Map.Strict as M - -import Brassica.SoundChange.Types -import Data.Traversable (for) - --- | A map from names to the (expanded) categories they --- reference. Used to resolve cross-references between categories. -type Categories = M.Map String (Expanded 'AnyPart) - --- | Lookup a category name in 'Categories'. -lookup :: String -> Categories -> Maybe (Expanded a) -lookup = (fmap generaliseExpanded .) . M.lookup - --- | Returns a list of every value mentioned in a set of --- 'Categories' -values :: Categories -> [Either Grapheme [Lexeme Expanded 'AnyPart]] -values = nubOrd . concatMap elements . M.elems - --- Errors which can be emitted while inlining or expanding category --- definitions. -data ExpandError - = NotFound String - -- ^ A category with that name was not found - | InvalidBaseValue - -- ^ A 'Lexeme' was used as a base value in a feature - | MismatchedLengths - -- ^ A 'FeatureSpec' contained a mismatched number of values - deriving (Show, Generic, NFData) - --- | Given a category, return the list of values which it --- matches. -expand :: Categories -> CategorySpec a -> Either ExpandError (Expanded a) -expand cs (MustInline g) = maybe (Left $ NotFound g) Right $ lookup g cs -expand cs (CategorySpec spec) = FromElements <$> foldM go [] spec - where - go es (modifier, e) = do - new <- case e of - Left (GMulti g) - | Just (FromElements c) <- lookup g cs - -> pure c - | otherwise -> pure [Left (GMulti g)] - Left GBoundary -> pure [Left GBoundary] - Right ls -> pure . Right <$> traverse (expandLexeme cs) ls - pure $ case modifier of - Union -> es ++ new - Intersect -> es `intersect` new - Subtract -> es `subtractAll` new - - -- NB. normal (\\) only removes the first matching element - subtractAll xs ys = filter (`notElem` ys) xs - -expandLexeme :: Categories -> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a) -expandLexeme cs (Grapheme (GMulti g)) - | Just (g', '~') <- unsnoc g - = Right $ Grapheme $ GMulti g' - | otherwise = Right $ - case lookup g cs of - Just c -> Category c - Nothing -> Grapheme (GMulti g) - where - -- taken from base-4.19 - unsnoc :: [a] -> Maybe ([a], a) - unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing - {-# INLINABLE unsnoc #-} - -expandLexeme _ (Grapheme GBoundary) = Right $ Grapheme GBoundary -expandLexeme cs (Category c) = Category <$> expand cs c -expandLexeme cs (Optional ls) = Optional <$> traverse (expandLexeme cs) ls -expandLexeme _ Metathesis = Right Metathesis -expandLexeme _ Geminate = Right Geminate -expandLexeme cs (Wildcard l) = Wildcard <$> expandLexeme cs l -expandLexeme cs (Kleene l) = Kleene <$> expandLexeme cs l -expandLexeme _ Discard = Right Discard -expandLexeme cs (Backreference i c) = Backreference i <$> expand cs c -expandLexeme cs (Multiple c) = Multiple <$> expand cs c - -expandRule :: Categories -> Rule CategorySpec -> Either ExpandError (Rule Expanded) -expandRule cs r = Rule - <$> traverse (expandLexeme cs) (target r) - <*> traverse (expandLexeme cs) (replacement r) - <*> traverse expandEnvironment (environment r) - <*> traverse expandEnvironment (exception r) - <*> pure (flags r) - <*> pure (plaintext r) - where - expandEnvironment (e1, e2) = (,) - <$> traverse (expandLexeme cs) e1 - <*> traverse (expandLexeme cs) e2 - -expandFilter :: Categories -> Filter CategorySpec -> Either ExpandError (Filter Expanded) -expandFilter cs (Filter p f) = Filter p <$> traverse (expandLexeme cs) f - -extendCategories - :: Categories - -> (Bool, [CategoryDefinition]) -- ^ The fields of a v'Categories' directive - -> Either ExpandError Categories -extendCategories cs' (overwrite, defs) = - foldM go (if overwrite then M.empty else cs') defs - where - go :: Categories -> CategoryDefinition -> Either ExpandError Categories - go cs (DefineCategory name val) = flip (M.insert name) cs <$> expand cs val - go cs (DefineFeature spec) = do - baseValues <- expand cs $ featureBaseValues spec - derivedCats <- traverse (traverse $ expand cs) $ featureDerived spec - - baseValues' <- for (elements baseValues) $ \case - Left (GMulti g) -> Right g - _ -> Left InvalidBaseValue - let baseLen = length baseValues' - derivedValues = elements . snd <$> derivedCats - unless (all ((==baseLen) . length) derivedValues) $ - Left MismatchedLengths - - let features = zipWith - (\base ds -> (base, FromElements $ Left (GMulti base) : ds)) - baseValues' - (transpose derivedValues) - newCats = - maybe [] (pure . (,baseValues)) (featureBaseName spec) - ++ derivedCats - ++ features - Right $ foldl' (flip $ uncurry M.insert) cs newCats - -expandSoundChanges - :: SoundChanges CategorySpec Directive - -> Either ExpandError (SoundChanges Expanded [Grapheme]) -expandSoundChanges = fmap catMaybes . flip evalStateT (M.empty, []) . traverse go - where - go :: Statement CategorySpec Directive - -> StateT - (Categories, [String]) - (Either ExpandError) - (Maybe (Statement Expanded [Grapheme])) - go (RuleS r) = do - cs <- gets fst - lift $ Just . RuleS <$> expandRule cs r - go (FilterS f) = do - cs <- gets fst - lift $ Just . FilterS <$> expandFilter cs f - go (DirectiveS (ExtraGraphemes extra)) = do - (cs, _) <- get - put (cs, extra) - pure Nothing - go (DirectiveS (Categories overwrite noreplace defs)) = do - (cs, extra) <- get - cs' <- lift $ extendCategories cs (overwrite, defs) - put (cs', extra) - pure $ if noreplace - then Nothing - else Just $ DirectiveS $ fmap GMulti extra ++ mapMaybe left (values cs') - - left (Left l) = Just l - left (Right _) = Nothing diff --git a/src/Brassica/SoundChange/Expand.hs b/src/Brassica/SoundChange/Expand.hs new file mode 100644 --- /dev/null +++ b/src/Brassica/SoundChange/Expand.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Brassica.SoundChange.Expand +-- Copyright : See LICENSE file +-- License : BSD3 +-- Maintainer : Brad Neimann +-- +-- This module implements the process of /expansion/, from Brassica’s +-- surface syntax to a simpler representation in which all categories, +-- features and autosegments have been inlined. For further +-- +-- In the surface syntax, each category is represented as a +-- 'CategorySpec', a description in terms of predefined categories +-- combined with category operations. Expansion converts each one to +-- an 'Expanded' list of graphemes. +-- +-- Similarly, category definitions are parsed as 'Directive's. Once +-- inlined, these can be replaced with simple 'GraphemeList's to be +-- used for filtering graphemes. +module Brassica.SoundChange.Expand + ( + -- * Main function + expandSoundChanges + , ExpandError(..) + -- * Expanding individual elements + , expand + , expandRule + , extendCategories + -- * Categories + , Categories + , AutosegmentDef(..) + , Brassica.SoundChange.Expand.lookup + , values + ) where + +import Prelude hiding (lookup) +import Control.DeepSeq (NFData) +import Control.Monad (foldM, unless) +import Control.Monad.State.Strict (StateT, evalStateT, lift, get, put, gets) +import Data.Bifunctor (first, second) +import Data.Containers.ListUtils (nubOrd) +import Data.List (transpose, foldl', stripPrefix) +import Data.Maybe (mapMaybe, catMaybes) +import Data.Traversable (for) +import GHC.Generics (Generic) + +import qualified Data.Map.Strict as M +import qualified Data.Map.Merge.Strict as M + +import Brassica.SoundChange.Types + +-- | Expanding an autosegment from a grapheme requires knowing its +-- feature name, and a set of graphemes cross-cutting that feature. +-- (Note that 'autoGraphemes' includes the originally-written +-- grapheme.) +data AutosegmentDef = AutosegmentDef + { autoFeature :: String + , autoGraphemes :: [String] + } + deriving (Eq, Show) + +-- | A map from names to the (expanded) categories or autosegments +-- they reference. Used to resolve cross-references between +-- categories. +type Categories = M.Map String (Either (Expanded 'AnyPart) AutosegmentDef) + +-- | Lookup a category name in t'Categories'. +lookup :: String -> Categories -> Maybe (Either (Expanded a) AutosegmentDef) +lookup = (fmap (first generaliseExpanded) .) . M.lookup + +-- | Returns a list of every value mentioned in a set of +-- t'Categories' +values :: Categories -> [[Lexeme Expanded 'AnyPart]] +values = nubOrd . concatMap (either elements autoElements) . M.elems + where + autoElements = fmap (pure . Grapheme) . autoGraphemes + +-- | Errors which can be emitted while inlining or expanding category +-- definitions. +data ExpandError + = NotFound String + -- ^ A category with the given name was not found + | InvalidBaseValue + -- ^ A 'Lexeme' was used as a base value in a feature + | InvalidDerivedValue + -- ^ A 'Lexeme' was used as a derived value in an autosegment + | MismatchedLengths + -- ^ A phonetic feature or 'FeatureSpec' contained a mismatched number of values + deriving (Show, Generic, NFData) + +-- | Given an unexpanded category, return the list of values which it +-- matches. +expand :: Categories -> CategorySpec a -> Either ExpandError (Expanded a) +expand cs (MustInline g) = case lookup g cs of + Just (Left expanded) -> Right expanded + _ -> Left $ NotFound g +expand cs (CategorySpec spec) = FromElements <$> foldM go [] spec + where + go :: [CategoryElement Expanded a] + -> (CategoryModification, CategoryElement CategorySpec a) + -> Either ExpandError [CategoryElement Expanded a] + go es (modifier, e) = do + (new, modifier') <- case e of + [Grapheme g] + | Just (g', '~') <- unsnoc g + -> pure ([[Grapheme g']], modifier) + | modifier == Intersect + , Just (Left (FromElements c)) <- lookup ('+':g) cs + -> pure (c, Intersect) + | modifier == Subtract + , Just (Left (FromElements c)) <- lookup ('-':g) cs + -> pure (c, Intersect) -- do intersection with negative instead! + | '&':g' <- g + , Just (Left (FromElements p)) <- lookup ('+':g') cs + , Just (Left (FromElements n)) <- lookup ('-':g') cs + -> pure (n++p, modifier) + | Just (Left (FromElements c)) <- lookup g cs + -> pure (c, modifier) + | Just (Right _) <- lookup g cs + -- re-expand to produce appropriate 'Auto' + -> (,modifier) . pure . pure <$> expandLexeme cs (Grapheme g) + + -- Note: there are other options for design here + -- see https://verduria.org/viewtopic.php?p=85766#p85766 + -- | Just (Right (AutosegmentDef _ gs)) <- lookup g cs + -- 1. -> pure ([Left (GMulti g)], modifier) + -- 2. -> pure (Left . GMulti <$> g:gs, modifier) + | otherwise -> pure ([[Grapheme g]], modifier) + ls -> (,modifier) . pure <$> traverse (expandLexeme cs) ls + pure $ case modifier' of + Union -> es ++ new + -- important: intersection preserves order of the /last/ category mentioned! + Intersect -> es `intersectC` new + Subtract -> es `subtractC` new + + -- Set operations, also looking into 'Autosegment's + subtractC, intersectC + :: [[Lexeme Expanded a]] + -> [[Lexeme Expanded a]] + -> [[Lexeme Expanded a]] + + subtractC es new = mapMaybe go' es + where + go' g | g `elemAuto` new = Nothing + go' [Autosegment n kvs gs] = + Just [Autosegment n + (filterkvs (`notElem` new) kvs) + (filter ((`notElem` new) . pure . Grapheme) gs)] + go' g = Just g + + intersectC es new = mapMaybe go' new + where + go' g | g `elemAuto` es = Just g + go' [Autosegment n kvs gs] = + Just [Autosegment n + (filterkvs (`elem` es) kvs) + (filter ((`elem` es) . pure . Grapheme) gs)] + go' _ = Nothing + + elemAuto :: [Lexeme Expanded a] -> [[Lexeme Expanded a]] -> Bool + elemAuto _ [] = False + elemAuto g'@[Grapheme gm] ([Autosegment _ _ gs]:ls) = (gm `elem` gs) || elemAuto g' ls + elemAuto g' (g:ls) = (g' == g) || elemAuto g' ls + + filterkvs :: ([Lexeme Expanded a] -> Bool) -> [[(Grapheme, Bool)]] -> [[(Grapheme, Bool)]] + filterkvs p = fmap . fmap $ \(g, b) -> (g, b && p [Grapheme g]) + +expandLexeme :: Categories -> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a) +expandLexeme cs (Grapheme g) + | Just (g', '~') <- unsnoc g + = Right $ Grapheme g' + | otherwise = + case lookup g cs of + Just (Left c) -> Right $ Category c + Just (Right a) -> do + kvs <- expandFeature cs (autoFeature a) + pure $ Autosegment (autoFeature a) ((fmap.fmap) (,True) kvs) (autoGraphemes a) + Nothing -> Right $ Grapheme g +expandLexeme cs (Category c) = Category <$> expand cs c +expandLexeme cs (GreedyCategory c) = GreedyCategory <$> expand cs c +expandLexeme cs (Optional ls) = Optional <$> traverse (expandLexeme cs) ls +expandLexeme cs (GreedyOptional ls) = GreedyOptional <$> traverse (expandLexeme cs) ls +expandLexeme _ Metathesis = Right Metathesis +expandLexeme _ Geminate = Right Geminate +expandLexeme cs (Wildcard l) = Wildcard <$> expandLexeme cs l +expandLexeme cs (Kleene l) = Kleene <$> expandLexeme cs l +expandLexeme _ Discard = Right Discard +expandLexeme cs (Backreference i c) = Backreference i <$> expand cs c +expandLexeme cs (Multiple c) = Multiple <$> expand cs c +expandLexeme cs (Feature r n i [] l) = do + kvs <- expandFeature cs n + l' <- expandLexeme cs l + pure $ Feature r n i kvs l' +expandLexeme cs (Feature r n i kvs l) = Feature r n i kvs <$> expandLexeme cs l +expandLexeme _ (Autosegment n kvs gs) = + -- in reality this case should never occur from parsed sound changes + pure $ Autosegment n kvs gs + +expandFeature :: Categories -> String -> Either ExpandError [[String]] +expandFeature cs n = transpose . fmap snd <$> lookupFeature cs n + +lookupFeature + :: Categories + -> String -- ^ Feature name (no +/- prefix or +value suffix) + -> Either ExpandError [(String, [String])] +lookupFeature cs n = + let pluss :: M.Map String (String, Either (Expanded 'AnyPart) AutosegmentDef) + pluss = M.mapMaybeWithKey plusPrefix cs + -- NB. consistency is guaranteed as 'elems' always returns items in ascending order + in case M.elems pluss of + [] -> Left $ NotFound ('+':n) + [("", Left (FromElements positive))] -> + case M.lookup ('-':n) cs of + Just (Left (FromElements negative)) + | length positive /= length negative -> Left MismatchedLengths + | Just positive' <- traverse getBaseValue positive + , Just negative' <- traverse getBaseValue negative + -> Right [("-", negative'), ("+", positive')] + | otherwise -> Left InvalidBaseValue + _ -> Left $ NotFound ('-':n) + kvs -> case traverse getCategory kvs of + Just vs@(v:vs') + | any ((length v /=) . length) vs' -> Left MismatchedLengths + | Just vs'' <- traverse (traverse getBaseValue) vs + -> Right $ zip (fst <$> kvs) vs'' + _ -> Left InvalidBaseValue + where + plusPrefix ('+':k) v = case stripPrefix n k of + Just ('+':k') -> Just (k', v) + Just "" -> Just ("", v) + _ -> Nothing + plusPrefix _ _ = Nothing + + getCategory (_, Left (FromElements c)) = Just c + getCategory _ = Nothing + +getBaseValue :: CategoryElement Expanded 'AnyPart -> Maybe String +getBaseValue [Grapheme g] = Just g +getBaseValue _ = Nothing + +-- taken from base-4.19 +unsnoc :: [a] -> Maybe ([a], a) +unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing +{-# INLINABLE unsnoc #-} + +-- | Expand all categories in a given sound change 'Rule'. +expandRule :: Categories -> Rule CategorySpec -> Either ExpandError (Rule Expanded) +expandRule cs r = Rule + <$> traverse (expandLexeme cs) (target r) + <*> traverse (expandLexeme cs) (replacement r) + <*> traverse expandEnvironment (environment r) + <*> traverse expandEnvironment (exception r) + <*> pure (flags r) + <*> pure (plaintext r) + where + expandEnvironment (e1, e2) = (,) + <$> traverse (expandLexeme cs) e1 + <*> traverse (expandLexeme cs) e2 + +expandFilter :: Categories -> Filter CategorySpec -> Either ExpandError (Filter Expanded) +expandFilter cs (Filter p f) = Filter p <$> traverse (expandLexeme cs) f + +-- | Extend a set of previously defined t'Categories' to give the +-- resulting state after a v'Categories' directive. +extendCategories + :: Categories + -> (Bool, [CategoryDefinition]) -- ^ The fields of a v'Categories' directive + -> Either ExpandError Categories +extendCategories cs' (overwrite, defs) = + foldM go (if overwrite then M.empty else cs') defs + where + go :: Categories -> CategoryDefinition -> Either ExpandError Categories + go cs (DefineCategory name val) = flip (M.insert name) cs . Left <$> expand cs val + go cs (DefineFeature spec) = do + baseValues <- expand cs $ featureBaseValues spec + derivedCats <- traverse (traverse $ expand cs) $ featureDerived spec + + baseValues' <- for (elements baseValues) $ + maybe (Left InvalidBaseValue) Right . getBaseValue + let baseLen = length baseValues' + derivedValues = elements . snd <$> derivedCats + unless (all ((==baseLen) . length) derivedValues) $ + Left MismatchedLengths + + let features = zipWith + (\base ds -> (base, FromElements $ [Grapheme base] : ds)) + baseValues' + (transpose derivedValues) + newCats = fmap (second Left) $ + maybe [] (pure . (,baseValues)) (featureBaseName spec) + ++ derivedCats + ++ features + Right $ foldl' (flip $ uncurry M.insert) cs newCats + go cs (DefineAuto catName) = do + let (featureName, featureValue) = case catName of + '-':n -> (n, "-") + '+':n -> case break (=='+') n of + (prefix, '+':suffix) -> (prefix, suffix) + (_, []) -> (n, "+") + _ -> error "extendCategories: unexpected output from 'break'" + n -> (n, "") -- let it error out below + features <- M.fromList <$> lookupFeature cs featureName + case M.lookup featureValue features of + Nothing -> Left $ NotFound catName + Just gs -> + -- NB. consistency is guaranteed as 'elems' always returns items in ascending order + let autoCs = M.fromList $ + zipWith (mkAuto featureName) gs (transpose $ M.elems features) + in pure $ M.merge + M.preserveMissing M.preserveMissing + (M.zipWithMatched $ \_ _ c -> c) + cs autoCs + + mkAuto :: String -> String -> [String] -> (String, Either (Expanded 'AnyPart) AutosegmentDef) + mkAuto f g gs = (g, Right $ AutosegmentDef f gs) + +-- | Expand a set of 'SoundChanges'. Expansion proceeds from beginning +-- to end as follows: +-- +-- * Rules and filters are expanded by expanding all categories +-- within them (with 'expand'). Graphemes are replaced with +-- categories or autosegments if previously defined as such. +-- +-- * If a v'Categories' definition block is found, the categories +-- defined within it are expanded and added to (or replace) the +-- list of current categories. The block is replaced with a list +-- of currently defined graphemes. +-- +-- * If 'ExtraGraphemes' are found, they are added to a list of +-- currently defined graphemes. They are replaced with a +-- 'GraphemeList' only if no categories are defined in the +-- 'SoundChanges'. +expandSoundChanges + :: SoundChanges CategorySpec Directive + -> Either ExpandError (SoundChanges Expanded GraphemeList) +expandSoundChanges scs = fmap catMaybes $ flip evalStateT (M.empty, []) $ traverse go scs + where + noCategories = any (\case DeclS (Categories {}) -> True; _ -> False) scs + + go :: Statement CategorySpec Directive + -> StateT + (Categories, [String]) + (Either ExpandError) + (Maybe (Statement Expanded GraphemeList)) + go (RuleS r) = do + cs <- gets fst + lift $ Just . RuleS <$> expandRule cs r + go (FilterS f) = do + cs <- gets fst + lift $ Just . FilterS <$> expandFilter cs f + go ReportS = pure (Just ReportS) + go (DeclS (ExtraGraphemes extra)) = do + (cs, _) <- get + put (cs, extra) + pure $ + if noCategories + then Just $ DeclS $ GraphemeList True extra + else Nothing + go (DeclS (Categories overwrite noreplace defs)) = do + (cs, extra) <- get + cs' <- lift $ extendCategories cs (overwrite, defs) + put (cs', extra) + pure $ Just $ DeclS $ GraphemeList noreplace $ extra ++ mapMaybe grapheme (values cs') + + grapheme [Grapheme g] = Just g + grapheme _ = Nothing 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,17 +1,30 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} -{-| __Warning:__ This module is __internal__, and does __not__ follow - the Package Versioning Policy. It may be useful for extending - Brassica, but be prepared to track development closely if you import - this module. --} +-- | +-- Module : Brassica.SoundChange.Frontend.Internal +-- Copyright : See LICENSE file +-- License : BSD3 +-- Maintainer : Brad Neimann +-- +-- __Warning:__ This module is __internal__, and does __not__ follow +-- the Package Versioning Policy. It may be useful for extending +-- Brassica, but be prepared to track development closely if you import +-- this module. +-- +-- This module exists primarily as an internal common interface for +-- Brassica’s two ‘official’ GUI frontends (desktop and web). If you +-- wish to make your own frontend to Brassica, it is probably easier +-- to write it yourself rather than trying to use this. module Brassica.SoundChange.Frontend.Internal where import Control.Monad ((<=<)) +import Data.Containers.ListUtils (nubOrd) +import Data.List (transpose, intersperse) import Data.Maybe (fromMaybe, mapMaybe) import Data.Void (Void) import GHC.Generics (Generic) @@ -23,25 +36,30 @@ import Brassica.SFM.MDF import Brassica.SFM.SFM import Brassica.SoundChange.Apply -import Brassica.SoundChange.Apply.Internal (applyChangesWithLog, toPWordLog) import Brassica.SoundChange.Tokenise import Brassica.SoundChange.Types -import Data.Bifunctor (first) -- | Rule application mode of the SCA. data ApplicationMode = ApplyRules HighlightMode OutputMode String + -- ^ Apply sound changes as normal, with the given modes and + -- separator | ReportRulesApplied + -- ^ Apply reporting the rules which were applied (as HTML) deriving (Show, Eq) +-- | Get the 'OutputMode' if one is set, otherwise default to +-- 'WordsOnlyOutput'. getOutputMode :: ApplicationMode -> OutputMode getOutputMode (ApplyRules _ o _) = o -getOutputMode ReportRulesApplied = WordsOnlyOutput -- default option +getOutputMode ReportRulesApplied = WordsOnlyOutput +-- | Mode for highlighting output words data HighlightMode = NoHighlight | DifferentToLastRun | DifferentToInput + -- ^ NB. now labeled ‘any rule applied’ in GUI deriving (Show, Eq) instance Enum HighlightMode where -- used for conversion to and from C, so want control over values @@ -54,11 +72,14 @@ toEnum 2 = DifferentToInput toEnum _ = undefined +-- | Mode for reporting output words (and sometimes intermediate and +-- input words too) data OutputMode = MDFOutput | WordsOnlyOutput | MDFOutputWithEtymons | WordsWithProtoOutput + | WordsWithProtoOutputPreserve deriving (Show, Eq) instance Enum OutputMode where -- used for conversion to and from C, so want control over values @@ -66,11 +87,13 @@ fromEnum WordsOnlyOutput = 1 fromEnum MDFOutputWithEtymons = 2 fromEnum WordsWithProtoOutput = 3 + fromEnum WordsWithProtoOutputPreserve = 4 toEnum 0 = MDFOutput toEnum 1 = WordsOnlyOutput toEnum 2 = MDFOutputWithEtymons toEnum 3 = WordsWithProtoOutput + toEnum 4 = WordsWithProtoOutputPreserve toEnum _ = undefined -- | Output of a single application of rules to a wordlist: either a @@ -78,95 +101,92 @@ -- parse error. data ApplicationOutput a r = HighlightedWords [Component (a, Bool)] - | AppliedRulesTable [PWordLog r] + | AppliedRulesTable [Log r] | ParseError (ParseErrorBundle String Void) deriving (Show, Generic, NFData) +-- | For MDF input, the hierarchy used +data MDFHierarchy = Standard | Alternate + deriving (Show, Eq) + -- | Kind of input: either a raw wordlist, or an MDF file. -data InputLexiconFormat = Raw | MDF +data InputLexiconFormat = Raw | MDF MDFHierarchy deriving (Show, Eq) instance Enum InputLexiconFormat where -- used for conversion to and from C, so want control over values fromEnum Raw = 0 - fromEnum MDF = 1 + fromEnum (MDF Standard) = 1 + fromEnum (MDF Alternate) = 2 toEnum 0 = Raw - toEnum 1 = MDF + toEnum 1 = MDF Standard + toEnum 2 = MDF Alternate toEnum _ = undefined +-- | Either a list of 'Component's for a Brassica wordlist file, or a +-- list of 'SFM' fields for an MDF file data ParseOutput a = ParsedRaw [Component a] | ParsedMDF SFM deriving (Show, Functor, Foldable, Traversable) -componentise :: OutputMode -> [a] -> [Component a] -> [Component a] -componentise WordsWithProtoOutput ws cs = intersperseWords ws cs -componentise _ _ cs = cs - -intersperseWords :: [a] -> [Component a] -> [Component a] -intersperseWords (w:ws) (Word c:cs) = - Word w : Separator " → " : Word c : Separator "\n" : intersperseWords ws cs -intersperseWords ws (_:cs) = intersperseWords ws cs -intersperseWords [] cs = cs -intersperseWords _ [] = [] - +-- | Given the selected input and output modes, and the expanded sound +-- changes, tokenise the input according to the format which was selected tokeniseAccordingToInputFormat :: InputLexiconFormat -> OutputMode - -> SoundChanges Expanded [Grapheme] + -> SoundChanges Expanded GraphemeList -> String -> Either (ParseErrorBundle String Void) [Component PWord] tokeniseAccordingToInputFormat Raw _ cs = withFirstCategoriesDecl tokeniseWords cs -tokeniseAccordingToInputFormat MDF MDFOutputWithEtymons cs = - withFirstCategoriesDecl tokeniseMDF cs <=< - -- TODO don't hard-code hierarchy and filename - fmap (fromTree . duplicateEtymologies ('*':) . toTree mdfHierarchy) - . parseSFM "" -tokeniseAccordingToInputFormat MDF o cs = \input -> do +tokeniseAccordingToInputFormat (MDF h) MDFOutputWithEtymons cs = + let h' = case h of + Standard -> mdfHierarchy + Alternate -> mdfAlternateHierarchy + in + withFirstCategoriesDecl tokeniseMDF cs <=< + fmap (fromTree . duplicateEtymologies ('*':) . toTree h') + . parseSFM "" +tokeniseAccordingToInputFormat (MDF _) o cs = \input -> do sfm <- parseSFM "" input ws <- withFirstCategoriesDecl tokeniseMDF cs sfm pure $ case o of MDFOutput -> ws - _ -> -- need to extract words for other output modes - Word <$> getWords ws + _ -> + -- need to extract words for other output modes + -- also add separators to keep words apart visually + intersperse (Separator "\n") $ Word <$> getWords ws -- | Top-level dispatcher for an interactive frontend: given a textual -- wordlist and a list of sound changes, returns the result of running -- the changes in the specified mode. parseTokeniseAndApplyRules :: (forall a b. (a -> b) -> [Component a] -> [Component b]) -- ^ mapping function to use (for parallelism) - -> SoundChanges Expanded [Grapheme] -- ^ changes + -> SoundChanges Expanded GraphemeList -- ^ changes -> String -- ^ words -> InputLexiconFormat -> ApplicationMode -> Maybe [Component PWord] -- ^ previous results - -> ApplicationOutput PWord (Statement Expanded [Grapheme]) + -> ApplicationOutput PWord (Statement Expanded GraphemeList) parseTokeniseAndApplyRules parFmap statements ws intype mode prev = case tokeniseAccordingToInputFormat intype (getOutputMode mode) statements ws of Left e -> ParseError e - Right toks - | ws' <- getWords toks - -> case mode of + Right toks -> case mode of ReportRulesApplied -> - AppliedRulesTable $ mapMaybe toPWordLog $ concat $ - getWords $ componentise WordsOnlyOutput [] $ - parFmap (applyChangesWithLog statements) toks + AppliedRulesTable $ concat $ + getWords $ parFmap (applyChanges statements) toks ApplyRules DifferentToLastRun mdfout sep -> let result = concatMap (splitMultipleResults sep) $ - componentise mdfout (fmap pure ws') $ - parFmap (applyChanges statements) toks + joinComponents' mdfout $ parFmap (doApply mdfout statements) toks in HighlightedWords $ mapMaybe polyDiffToHighlight $ getDiff (fromMaybe [] prev) result -- zipWithComponents result (fromMaybe [] prev) [] $ \thisWord prevWord -> -- (thisWord, thisWord /= prevWord) ApplyRules DifferentToInput mdfout sep -> HighlightedWords $ concatMap (splitMultipleResults sep) $ - (fmap.fmap) (mapMaybe extractMaybe) $ - componentise mdfout (fmap (pure . first Just . (,False)) ws') $ - parFmap (applyChangesWithChanges statements) toks + joinComponents' mdfout $ parFmap (doApplyWithChanges mdfout statements) toks ApplyRules NoHighlight mdfout sep -> HighlightedWords $ (fmap.fmap) (,False) $ concatMap (splitMultipleResults sep) $ - componentise mdfout (fmap pure ws') $ - parFmap (applyChanges statements) toks + joinComponents' mdfout $ parFmap (doApply mdfout statements) toks where -- highlight words in 'Second' but not 'First' polyDiffToHighlight :: PolyDiff (Component a) (Component a) -> Maybe (Component (a, Bool)) @@ -181,5 +201,36 @@ unsafeCastComponent (Separator s) = Separator s unsafeCastComponent (Gloss s) = Gloss s - extractMaybe (Just a, b) = Just (a, b) - extractMaybe (Nothing, _) = Nothing + doApply :: OutputMode -> SoundChanges Expanded GraphemeList -> PWord -> [Component [PWord]] + doApply WordsWithProtoOutput scs w = doApplyWithProto scs w + doApply WordsWithProtoOutputPreserve scs w = doApplyWithProto scs w + doApply _ scs w = [Word $ mapMaybe getOutput $ applyChanges scs w] + + doApplyWithProto scs w = + let intermediates :: [[PWord]] + intermediates = fmap nubOrd $ transpose $ getReports <$> applyChanges scs w + in intersperse (Separator " → ") (fmap Word intermediates) + + doApplyWithChanges :: OutputMode -> SoundChanges Expanded GraphemeList -> PWord -> [Component [(PWord, Bool)]] + doApplyWithChanges WordsWithProtoOutput scs w = doApplyWithChangesWithProto scs w + doApplyWithChanges WordsWithProtoOutputPreserve scs w = doApplyWithChangesWithProto scs w + doApplyWithChanges _ scs w = [Word $ mapMaybe getChangedOutputs $ applyChanges scs w] + + doApplyWithChangesWithProto scs w = + let intermediates :: [[(PWord, Bool)]] + intermediates = fmap nubOrd $ transpose $ getChangedReports <$> applyChanges scs w + in intersperse (Separator " → ") (fmap Word intermediates) + + joinComponents' WordsWithProtoOutput = + joinComponents . intersperse (Separator "\n") . filter (\case Word _ -> True; _ -> False) + joinComponents' WordsWithProtoOutputPreserve = joinComponents . linespace + joinComponents' _ = joinComponents + + -- Insert newlines as necessary to put each 'Word' on a separate line + linespace :: [Component a] -> [Component a] + linespace (Separator s:cs) + | '\n' `elem` s = Separator s : linespace cs + | otherwise = Separator ('\n':s) : linespace cs + linespace (c:cs@(Separator _:_)) = c : linespace cs + linespace (c:cs) = c : Separator "\n" : linespace cs + linespace [] = [] 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 @@ -5,16 +5,26 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Brassica.SoundChange.Parse +-- Copyright : See LICENSE file +-- License : BSD3 +-- Maintainer : Brad Neimann +-- +-- Functions to parse sound changes in Brassica syntax. (For details +-- on the syntax, refer to the +-- [reference guide](https://github.com/bradrn/brassica/blob/v1.0.0/docs/Reference.md).) module Brassica.SoundChange.Parse ( parseRule , parseSoundChanges -- ** Re-export - , errorBundlePretty + , module Text.Megaparsec.Error ) where import Data.Char (isSpace) import Data.Foldable (asum) -import Data.Maybe (isNothing, isJust, fromJust) +import Data.List (dropWhileEnd) +import Data.Maybe (isNothing, isJust, fromJust, fromMaybe) import Data.Void (Void) import Control.Applicative.Permutations @@ -23,6 +33,7 @@ import Text.Megaparsec hiding (State) import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L +import Text.Megaparsec.Error import Brassica.SoundChange.Types @@ -31,15 +42,15 @@ class ParseLexeme (a :: LexemeType) where parseLexeme :: Parser (Lexeme CategorySpec a) --- space consumer which does not match newlines +-- space consumer which does not match newlines or comments sc :: Parser () -sc = L.space space1' (L.skipLineComment ";") empty +sc = L.space space1' empty empty where -- adapted from megaparsec source: like 'space1', but does not -- consume newlines (which are important for rule separation) space1' = void $ takeWhile1P (Just "white space") ((&&) <$> isSpace <*> (/='\n')) --- space consumer which matches newlines +-- space consumer which matches newlines and comments scn :: Parser () scn = L.space space1 (L.skipLineComment ";") empty @@ -50,7 +61,7 @@ symbol = L.symbol sc keyChars :: [Char] -keyChars = "#[](){}>\\→/_^%~*@" +keyChars = "#[](){}>\\→/_^%~*@$;" nonzero :: Parser Int nonzero = label "nonzero postive number" $ try $ do @@ -60,14 +71,17 @@ parseGrapheme :: Parser Grapheme parseGrapheme = lexeme $ - GBoundary <$ char '#' - <|> GMulti <$> parseGrapheme' + pure <$> char '#' + <|> parseGrapheme' True -parseGrapheme' :: Parser String -parseGrapheme' = lexeme $ do +parseGrapheme' :: Bool -> Parser String +parseGrapheme' wantTilde = lexeme $ do star <- optional (char '*') rest <- takeWhile1P Nothing (not . ((||) <$> isSpace <*> (`elem` keyChars))) - nocat <- optional (char '~') + nocat <- + if wantTilde + then optional (char '~') + else pure Nothing pure . maybe id (const ('*':)) star . maybe id (const (++"~")) nocat @@ -76,51 +90,62 @@ parseExplicitCategory :: ParseLexeme a => Parser (Lexeme CategorySpec a) parseExplicitCategory = Category <$> parseExplicitCategory' +parseGreedyCategory :: Parser (Lexeme CategorySpec 'Matched) +parseGreedyCategory = GreedyCategory <$> (char '%' *> parseExplicitCategory') + parseExplicitCategory' :: ParseLexeme a => Parser (CategorySpec a) -parseExplicitCategory' = - CategorySpec <$> (symbol "[" *> someTill parseCategoryModification (symbol "]")) +parseExplicitCategory' = fmap CategorySpec $ + (:) <$> (symbol "[" *> parseCategoryModification True) + <*> manyTill (parseCategoryModification False) (symbol "]") -- This is unused currently, but convenient to keep around just in case -- parseCategory :: ParseLexeme a => Parser (Lexeme CategorySpec a) -- parseCategory = Category <$> parseCategory' parseCategory' :: ParseLexeme a => Parser (CategorySpec a) -parseCategory' = parseExplicitCategory' <|> MustInline <$> parseGrapheme' +parseCategory' = parseExplicitCategory' <|> MustInline <$> parseGrapheme' True parseCategoryStandalone :: Parser (String, CategorySpec 'AnyPart) parseCategoryStandalone = do - g <- parseGrapheme' + g <- parseGrapheme' True _ <- symbol "=" - mods <- some parseCategoryModification + mods <- some (parseCategoryModification False) return (g, CategorySpec mods) parseFeature :: Parser FeatureSpec parseFeature = do _ <- symbol "feature" - featureBaseName <- optional $ try $ parseGrapheme' <* symbol "=" - featureBaseValues <- CategorySpec <$> some parseCategoryModification + featureBaseName <- optional $ try $ parseGrapheme' False <* symbol "=" + featureBaseValues <- CategorySpec <$> some (parseCategoryModification False) featureDerived <- some (symbol "/" *> parseCategoryStandalone) <* scn pure FeatureSpec { featureBaseName, featureBaseValues, featureDerived } +parseAuto :: Parser String +parseAuto = symbol "auto" *> parseGrapheme' False <* scn + parseCategoryModification :: ParseLexeme a - => Parser (CategoryModification, Either Grapheme [Lexeme CategorySpec a]) -parseCategoryModification = (,) - <$> parsePrefix - <*> ( (Right <$> (symbol "{" *> manyTill parseLexeme (symbol "}"))) - <|> (Left <$> parseGrapheme)) + => Bool + -> Parser (CategoryModification, [Lexeme CategorySpec a]) +parseCategoryModification forceUnion = (,) + <$> (if forceUnion + then Union <$ optional (char '&') + else parsePrefix) + <*> (symbol "{" *> manyTill parseLexeme (symbol "}") + <|> (pure . Grapheme <$> parseGrapheme)) where parsePrefix = (Intersect <$ char '+') <|> (Subtract <$ char '-') + <|> (Union <$ char '&') -- necessary for featural categories <|> pure Union parseDirective :: Parser Directive parseDirective = parseCategoriesDirective <|> parseExtraDirective where parseExtraDirective = fmap ExtraGraphemes $ - symbol "extra" *> many parseGrapheme' <* scn + symbol "extra" *> many (parseGrapheme' False) <* scn parseCategoriesDirective = do overwrite <- isJust <$> optional (symbol "new") @@ -129,6 +154,7 @@ scn cs <- some $ DefineFeature <$> parseFeature <|> + DefineAuto <$> parseAuto <|> uncurry DefineCategory <$> (try parseCategoryStandalone <* scn) _ <- symbol "end" <* scn pure $ Categories overwrite noreplace cs @@ -136,6 +162,9 @@ parseOptional :: ParseLexeme a => Parser (Lexeme CategorySpec a) parseOptional = Optional <$> between (symbol "(") (symbol ")") (some parseLexeme) +parseGreedyOptional :: Parser (Lexeme CategorySpec 'Matched) +parseGreedyOptional = GreedyOptional <$> between (symbol "%(") (symbol ")") (some parseLexeme) + parseGeminate :: Parser (Lexeme CategorySpec a) parseGeminate = Geminate <$ symbol ">" @@ -148,26 +177,44 @@ parseDiscard :: Parser (Lexeme CategorySpec 'Replacement) parseDiscard = Discard <$ symbol "~" -parseKleene :: Lexeme CategorySpec a -> Parser (Lexeme CategorySpec a) -parseKleene l = - try (lexeme $ Kleene l <$ char '*' <* notFollowedBy parseGrapheme') +parsePost :: Lexeme CategorySpec a -> Parser (Lexeme CategorySpec a) +parsePost l = + try parseFeatureApp + <|> try (lexeme $ Kleene l <$ char '*' <* notFollowedBy (parseGrapheme' True)) <|> pure l + where + parseFeatureApp = + Feature <$ char '$' + <*> fmap isJust (optional $ char '-') + <*> parseGrapheme' False + <*> optional (char '#' *> parseGrapheme' False) + <*> fmap (fromMaybe []) + ( optional $ between (symbol "(") (symbol ")") $ + many $ lexeme $ parseGrapheme' False `sepBy1` char '~' + ) + <*> pure l parseMultiple :: Parser (Lexeme CategorySpec 'Replacement) parseMultiple = Multiple <$> (symbol "@?" *> parseCategory') parseBackreference :: forall a. ParseLexeme a => Parser (Lexeme CategorySpec a) -parseBackreference = Backreference <$> (symbol "@" *> nonzero) <*> parseCategory' +parseBackreference = Backreference <$> (symbol "@" *> ref) <*> parseCategory' + where + ref = + Left <$> (char '#' *> parseGrapheme' False) + <|> Right <$> nonzero instance ParseLexeme 'Matched where parseLexeme = asum [ parseExplicitCategory , parseOptional + , parseGreedyOptional + , parseGreedyCategory , parseGeminate , parseWildcard , parseBackreference , Grapheme <$> parseGrapheme - ] >>= parseKleene + ] >>= parsePost instance ParseLexeme 'Replacement where parseLexeme = asum @@ -180,7 +227,7 @@ , parseWildcard , parseBackreference , Grapheme <$> parseGrapheme - ] >>= parseKleene + ] >>= parsePost instance ParseLexeme 'AnyPart where parseLexeme = asum @@ -188,7 +235,7 @@ , parseOptional , parseWildcard , Grapheme <$> parseGrapheme - ] >>= parseKleene + ] >>= parsePost parseLexemes :: ParseLexeme a => Parser [Lexeme CategorySpec a] parseLexemes = many parseLexeme @@ -200,6 +247,7 @@ <*> toPermutation (isJust <$> optional (symbol "-1")) <*> toPermutationWithDefault ApplyAlways ((PerApplication <$ symbol "-??") <|> (PerWord <$ symbol "-?")) + <*> toPermutation (isJust <$> optional (symbol "-no")) ruleParser :: Parser (Rule CategorySpec) ruleParser = do @@ -228,29 +276,34 @@ exception <- optional $ (,) <$> (symbol "//" *> parseLexemes) <* symbol "_" <*> parseLexemes + o' <- getOffset + _ <- optional scn -- consume newline after rule if present - o' <- getOffset - let plaintext = takeWhile notNewline $ (fst . fromJust) (takeN_ (o' - o) s) + let plaintext = dropWhile isSpace $ dropWhileEnd isSpace $ + (fst . fromJust) (takeN_ (o' - o) s) return Rule{environment=envs, ..} - where - notNewline c = (c /= '\n') && (c /= '\r') filterParser :: Parser (Filter CategorySpec) filterParser = fmap (uncurry Filter) $ match $ symbol "filter" *> parseLexemes <* optional scn --- | Parse a 'String' in Brassica sound change syntax into a --- 'Rule'. Returns 'Left' if the input string is malformed. --- --- For details on the syntax, refer to . +-- Space handline is a little complex here: we want to make sure that +-- 'report' is always on its own line, but can have as much or as +-- little space after it as needed +reportParser :: Parser () +reportParser = symbol "report" *> sc *> ((newline *> void (optional scn)) <|> eof) + +-- | Parse a single sound change into a 'Rule'. Returns 'Left' if the +-- input string is malformed. parseRule :: String -> Either (ParseErrorBundle String Void) (Rule CategorySpec) parseRule = runParser (scn *> ruleParser <* eof) "" --- | Parse a list of 'SoundChanges'. +-- | Parse a sound change file into a set of 'SoundChanges'. parseSoundChanges :: String -> Either (ParseErrorBundle String Void) (SoundChanges CategorySpec Directive) parseSoundChanges = runParser (scn *> parser <* eof) "" where parser = many $ - DirectiveS <$> parseDirective + DeclS <$> parseDirective <|> FilterS <$> filterParser + <|> ReportS <$ reportParser <|> RuleS <$> ruleParser diff --git a/src/Brassica/SoundChange/Tokenise.hs b/src/Brassica/SoundChange/Tokenise.hs --- a/src/Brassica/SoundChange/Tokenise.hs +++ b/src/Brassica/SoundChange/Tokenise.hs @@ -5,18 +5,27 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Brassica.SoundChange.Tokenise +-- Copyright : See LICENSE file +-- License : BSD3 +-- Maintainer : Brad Neimann +-- +-- This module provides functions to parse a Brassica words file into +-- its constituent 'Component's, and to tokenise the words in that +-- file into their constituent graphemes to form 'PWord's. It also +-- provides functions to reverse these processes. module Brassica.SoundChange.Tokenise - ( - -- * Components - Component(..) + ( + -- * High-level interface + tokeniseWord + , Component(..) , getWords , splitMultipleResults - -- * High-level interface - , tokeniseWord + , joinComponents , tokeniseWords , detokeniseWords' , detokeniseWords - , concatWithBoundary , findFirstCategoriesDecl , withFirstCategoriesDecl -- * Lower-level functions @@ -40,12 +49,22 @@ import Brassica.SoundChange.Types --- | Represents a component of a tokenised input string. v'Word's in --- the input are represented as the type parameter @a@ — which for --- this reason will usually, though not always, be 'PWord'. -data Component a = Word a | Separator String | Gloss String +-- | Represents a component of a Brassica words file. Each word in the +-- input has type @a@ (often 'PWord' or @['PWord']@). +data Component a + = Word a -- ^ An input word to which sound changes will be applied + | Separator String -- ^ A separator, e.g. whitespace + | Gloss String -- ^ A gloss (in Brassica syntax, between square brackets) deriving (Eq, Show, Functor, Foldable, Traversable, Generic, NFData) +-- | Flatten a nested list of 'Component's. +joinComponents :: [Component [Component a]] -> [Component a] +joinComponents = concatMap go + where + go (Word cs) = cs + go (Separator s) = [Separator s] + go (Gloss s) = [Gloss s] + -- | Given a tokenised input string, return only the v'Word's within -- it. getWords :: [Component a] -> [a] @@ -59,8 +78,8 @@ -- -- For instance: -- --- >>> splitMultipleResults " " (Word ["abc", "def", "ghi"]) --- [Word "abc", Separator " ", Word "def", Separator " ", Word "ghi"] +-- >>> splitMultipleResults "/" (Word ["abc", "def", "ghi"]) +-- [Word "abc", Separator "/", Word "def", Separator "/", Word "ghi"] -- -- >>> splitMultipleResults " " (Word ["abc"]) -- [Word "abc"] @@ -68,30 +87,31 @@ splitMultipleResults wh (Word as) = intersperse (Separator wh) $ Word <$> as splitMultipleResults _ (Separator w) = [Separator w] splitMultipleResults _ (Gloss g) = [Gloss g] - + -- | Megaparsec parser for 'PWord's — see 'tokeniseWord' documentation --- for details on the parsing strategy and the meaning of the second --- parameter. For most usecases 'tokeniseWord' should suffice; --- 'wordParser' itself is only really useful in unusual situations --- (e.g. as part of a larger parser). The first parameter gives a list --- of characters (aside from whitespace) which should be excluded from --- words, i.e. the parser will stop if any of them are found. The second --- gives a list of multigraphs which might be expected. +-- for details on the parsing strategy. For most usecases +-- 'tokeniseWord' should suffice; 'wordParser' itself is only really +-- useful in unusual situations (e.g. as part of a larger parser). -- --- Note: the second parameter __must__ be 'sortByDescendingLength'-ed; --- otherwise multigraphs will not be parsed correctly. +-- The first parameter gives a list of characters aside from +-- whitespace which should be excluded from words, i.e. the parser +-- will stop if any of them are found. The second gives a list of +-- multigraphs which might be expected, as with 'tokeniseWord'. +-- +-- Note: the second parameter __must__ be already be sorted by descending length; +-- otherwise multigraphs will not be parsed correctly (i.e. greedily). wordParser :: [Char] -> [String] -> ParsecT Void String Identity PWord wordParser excludes gs = some $ - (GBoundary <$ single '#') - <|> choice (fmap GMulti . chunk <$> gs) - <|> (GMulti . pure <$> satisfy (not . exclude)) + ("#" <$ single '#') + <|> choice (chunk <$> gs) + <|> (pure <$> satisfy (not . exclude)) where exclude = (||) <$> isSpace <*> (`elem` excludes) -- | Megaparsec parser for 'Component's. Similarly to 'wordParser', -- usually it’s easier to use 'tokeniseWords' instead. componentsParser - :: ParsecT Void String Identity a + :: ParsecT Void String Identity a -- ^ Parser for individual words (e.g. 'wordParser') -> ParsecT Void String Identity [Component a] componentsParser p = many $ (Separator <$> takeWhile1P Nothing isSpace) <|> @@ -106,6 +126,8 @@ then '[' : concat contents ++ "]" else concat contents +-- | Sort a list of lists by the length of the inner lists, in +-- descending order. sortByDescendingLength :: [[a]] -> [[a]] sortByDescendingLength = sortBy (compare `on` Down . length) @@ -117,30 +139,33 @@ -- multigraphs is a prefix of another, the tokeniser will prefer the -- longest if possible. If there are no matching multigraphs starting -- at a particular character in the 'String', 'tokeniseWord' will --- treat that character as its own t'Grapheme'. For instance: +-- take that character as forming its own t'Grapheme'. For instance: -- -- >>> tokeniseWord [] "cherish" -- Right [GMulti "c",GMulti "h",GMulti "e",GMulti "r",GMulti "i",GMulti "s",GMulti "h"] --- +-- -- >>> tokeniseWord ["e","h","i","r","s","sh"] "cherish" -- Right [GMulti "c",GMulti "h",GMulti "e",GMulti "r",GMulti "i",GMulti "sh"] --- +-- -- >>> tokeniseWord ["c","ch","e","h","i","r","s","sh"] "cherish" -- Right [GMulti "ch",GMulti "e",GMulti "r",GMulti "i",GMulti "sh"] +-- +-- The resulting 'PWord' can be converted back to a 'String' using +-- 'concatWithBoundary'. (However, it is not strictly speaking a true +-- inverse as it deletes word boundaries). tokeniseWord :: [String] -> String -> Either (ParseErrorBundle String Void) PWord tokeniseWord (sortByDescendingLength -> gs) = parse (wordParser "[" gs) "" --- | Given a list of available multigraphs, tokenise an input string --- into a list of words and other 'Component's. This uses the same --- tokenisation strategy as 'tokeniseWords', but also recognises --- 'Gloss'es (in square brackets) and 'Separator's (in the form of --- whitespace). +-- | Given a list of available multigraphs, tokenise an input words +-- file into a list of words and other 'Component's. This uses the +-- same tokenisation strategy as 'tokeniseWords', but also recognises +-- 'Gloss'es (in square brackets) and 'Separator's (as whitespace). tokeniseWords :: [String] -> String -> Either (ParseErrorBundle String Void) [Component PWord] tokeniseWords (sortByDescendingLength -> gs) = parse (componentsParser $ wordParser "[" gs) "" --- | Given a function to convert 'Word's to strings, converts a list --- of 'Component's to strings. +-- | Inverse of 'tokeniseWords': given a function to convert v'Word's +-- to strings, converts a list of 'Component's to strings. detokeniseWords' :: (a -> String) -> [Component a] -> String detokeniseWords' f = concatMap $ \case Word gs -> f gs @@ -153,12 +178,9 @@ detokeniseWords = detokeniseWords' concatWithBoundary -- | Given a list of sound changes, extract the list of multigraphs --- defined in the first categories declaration of the 'SoundChange's. -findFirstCategoriesDecl :: SoundChanges c [Grapheme] -> [String] -findFirstCategoriesDecl (DirectiveS gs:_) = - mapMaybe - (\case GBoundary -> Nothing; GMulti m -> Just m) - gs +-- defined in the first 'GraphemeList' of the 'SoundChanges'. +findFirstCategoriesDecl :: SoundChanges c GraphemeList -> [String] +findFirstCategoriesDecl (DeclS (GraphemeList _ gs):_) = gs findFirstCategoriesDecl (_:ss) = findFirstCategoriesDecl ss findFirstCategoriesDecl [] = [] @@ -166,5 +188,5 @@ -- like @'withFirstCategoriesDecl' 'tokeniseWords' changes words@ (to -- tokenise using the graphemes from the first categories declaration) -- and so on. -withFirstCategoriesDecl :: ([String] -> t) -> SoundChanges c [Grapheme] -> t +withFirstCategoriesDecl :: ([String] -> t) -> SoundChanges c GraphemeList -> t withFirstCategoriesDecl tok ss = tok (findFirstCategoriesDecl ss) 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 @@ -6,32 +6,52 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Brassica.SoundChange.Types +-- Copyright : See LICENSE file +-- License : BSD3 +-- Maintainer : Brad Neimann +-- +-- This module contains the types used to represent sound changes and +-- words in Brassica. In brief: +-- +-- * A set of 'SoundChanges' is composed of a list of elements +-- +-- * Their most important elements are sound change 'Rule's +-- +-- * Sound changes are composed of 'Lexeme's denoting parts of the +-- input and output words +-- +-- * Each word is a sequence of t'Grapheme's +-- +-- For more details on the syntax and semantics of sound changes, +-- refer to the [reference guide](https://github.com/bradrn/brassica/blob/v1.0.0/docs/Reference.md). module Brassica.SoundChange.Types ( -- * Words and graphemes - Grapheme(..) + Grapheme , PWord , addBoundaries , removeBoundaries , concatWithBoundary -- * Lexemes , Lexeme(..) - , pattern Boundary , LexemeType(..) , generalise -- * Categories , mapCategory , mapCategoryA + , CategoryElement + , CategorySpec(..) + , CategoryModification(..) , Expanded(..) , generaliseExpanded -- * Rules @@ -47,91 +67,106 @@ , plaintext' , SoundChanges -- * Directives - , CategoryModification(..) - , CategorySpec(..) - , FeatureSpec(..) - , CategoryDefinition(..) , Directive(..) + , CategoryDefinition(..) + , FeatureSpec(..) + , GraphemeList(..) ) where -import Control.DeepSeq (NFData(..)) -import Data.String (IsString(..)) +import Control.DeepSeq (NFData(..), deepseq) import GHC.Generics (Generic) import GHC.OldList (dropWhileEnd) --- | The type of graphemes within a word. -data Grapheme - = GMulti [Char] -- ^ A multigraph: for instance @GMulti "a", GMulti "ch", GMulti "c̓" :: t'Grapheme'@. - | GBoundary -- ^ A non-letter element representing a word boundary which sound changes can manipulate - deriving (Eq, Ord, Show, Generic, NFData) - -instance IsString Grapheme where - fromString = GMulti +-- | The type of graphemes within a word. @"#"@ is taken to denote a +-- word boundary (whch is universally treated as a normal grapheme in +-- sound changes.) +type Grapheme = [Char] --- | A word (or a subsequence of one) can be viewed as a list of --- @Grapheme@s: e.g. Portuguese "filha" becomes --- @["f", "i", "lh", "a"] :: 'PWord'@. +-- | Brassica views a word, or a subsequence of one, as a list of +-- @Grapheme@s. For instance, Portuguese "filha" becomes +-- @["f", "i", "lh", "a"]@ when tokenised correctly. -- --- (The name 'PWord' is from ‘phonological word’, these being what a --- SCA typically manipulates; this name was chosen to avoid a clash --- with @Prelude.'Prelude.Word'@.) +-- (The name 'PWord' is from ‘phonological word’, these being what +-- sound changes typically manipulate. The name was chosen to avoid a +-- clash with @t'Word'@ from @base@.) type PWord = [Grapheme] --- Add a 'GBoundary' at the beginning and end of the 'PWord'. +-- | Add word boundaries (@"#"@) at the beginning and end of a 'PWord'. addBoundaries :: PWord -> PWord -addBoundaries w = GBoundary : w ++ [GBoundary] +addBoundaries w = "#" : w ++ ["#"] --- Remove 'GBoundary's from the beginning and end of the 'PWord'. +-- | Remove word boundaries (@"#"@) from the beginning and end of a 'PWord'. removeBoundaries :: PWord -> PWord -removeBoundaries = dropWhile (==GBoundary) . dropWhileEnd (==GBoundary) +removeBoundaries = dropWhile (=="#") . dropWhileEnd (=="#") --- | Render a 'PWord' as a 'String'. Very much like 'concat', but --- treating 'GBoundary's specially. Word-external boundaries are --- deleted, while word-internal boundaries are converted to @"#"@. +-- | Render a 'PWord' as a 'String': does 'removeBoundaries' then 'concat'. concatWithBoundary :: PWord -> String -concatWithBoundary = go . removeBoundaries - where - go = concatMap $ \case - GMulti g -> g - GBoundary -> "#" +concatWithBoundary = concat . removeBoundaries --- | The part of a 'Rule' in which a 'Lexeme' may occur: in a matched --- part (target or environment), in replacement, or in either of --- those. -data LexemeType = Matched | Replacement | AnyPart +-- | The part of a 'Rule' in which a 'Lexeme' may occur. +data LexemeType + = Matched -- ^ In the target, environment or exception (‘matching’ position) + | Replacement -- ^ In the replacement only + | AnyPart -- ^ Not restricted to any one part --- | A 'Lexeme' is the smallest part of a sound change. Both matches --- and replacements are made up of 'Lexeme's: the phantom type --- variable @a@ specifies where each different variety of 'Lexeme' may --- occur. 'Lexeme's are also parameterised by their category type, --- which may be 'Expanded' or something else. +-- | Each part of a sound change is made up of a sequence of +-- 'Lexeme's. Each 'Lexeme' denotes part of an input or output word. +-- +-- The first type variable @category@ is the type used to represent +-- categories within the sound change. This will usually be +-- 'CategorySpec' after parsing, or 'Expanded' after expansion. +-- +-- The second type variable is phantom and represents the part of the +-- rule in which the lexeme is placed. Various lexemes are restricted +-- to 'Matched' or 'Replacement' positions respectively. +-- +-- For details on the syntax and semantics of each kind of lexeme, +-- refer to the [reference guide](https://github.com/bradrn/brassica/blob/v1.0.0/docs/Reference.md). data Lexeme category (a :: LexemeType) where - -- | In Brassica sound-change syntax, one or more letters without intervening whitespace, - -- or a word boundary specified as @#@ Grapheme :: Grapheme -> Lexeme category a - -- | In Brassica sound-change syntax, delimited by square brackets Category :: category a -> Lexeme category a - -- | In Brassica sound-change syntax, delimited by parentheses + -- | Written @%category@, matching-only + GreedyCategory :: category 'Matched -> Lexeme category 'Matched + -- | Written @(lexemes)@ Optional :: [Lexeme category a] -> Lexeme category a - -- | In Brassica sound-change syntax, specified as @\@ + -- | Written @%(lexemes)@, matching-only + GreedyOptional :: [Lexeme category 'Matched] -> Lexeme category 'Matched + -- | Written @\\@, replacement-only Metathesis :: Lexeme category 'Replacement - -- | In Brassica sound-change syntax, specified as @>@ + -- | Written @>@ Geminate :: Lexeme category a - -- | In Brassica sound-change syntax, specified as @^@ before another 'Lexeme' + -- | Written @^lexeme@ Wildcard :: Lexeme category a -> Lexeme category a - -- | In Brassica sound-change syntax, specified as @*@ after another 'Lexeme' + -- | Written @lexeme*@ Kleene :: Lexeme category a -> Lexeme category a - -- | In Brassica sound-change syntax, specified as @~@ + -- | Written @~@, replacement-only Discard :: Lexeme category 'Replacement - -- | In Brassica sound-change syntax, specified as \@i before a category - Backreference :: Int -> category a -> Lexeme category a - -- | In Brassica sound-change syntax, specified as \@? before a category + -- | Written @\@n category@ or @\@#id category@ + Backreference :: Either String Int -> category a -> Lexeme category a + -- | Written @\@? category@ Multiple :: category 'Replacement -> Lexeme category 'Replacement + -- | Written @lexeme$Name@ or variations (see reference guide) + Feature + :: Bool -- ^ 'True' iff the feature is negated + -> String -- ^ Feature name + -> Maybe String -- ^ Identifier if backreferenced, else 'Nothing' + -> [[Grapheme]] -- ^ List of correspondence sets + -> Lexeme category a + -> Lexeme category a + -- | Not directly available in Brassica syntax, inserted in expansion + Autosegment + :: Grapheme -- ^ Feature name + -> [[(Grapheme, Bool)]] -- ^ List of correspondence sets, with exclusion states + -> [Grapheme] -- ^ Graphemes to be matched by this 'Autosegment' + -> Lexeme category a +-- | Map a function over any categories in the given 'Lexeme'. mapCategory :: (forall x. c x -> c' x) -> Lexeme c a -> Lexeme c' a mapCategory _ (Grapheme g) = Grapheme g mapCategory f (Category c) = Category (f c) +mapCategory f (GreedyCategory c) = GreedyCategory (f c) mapCategory f (Optional ls) = Optional (mapCategory f <$> ls) +mapCategory f (GreedyOptional ls) = GreedyOptional (mapCategory f <$> ls) mapCategory _ Metathesis = Metathesis mapCategory _ Geminate = Geminate mapCategory f (Wildcard l) = Wildcard (mapCategory f l) @@ -139,7 +174,10 @@ mapCategory _ Discard = Discard mapCategory f (Backreference i c) = Backreference i (f c) mapCategory f (Multiple c) = Multiple (f c) +mapCategory f (Feature r n i kvs l) = Feature r n i kvs $ mapCategory f l +mapCategory _ (Autosegment n kvs gs) = Autosegment n kvs gs +-- | Like 'mapCategory', with an 'Applicative' effect. mapCategoryA :: Applicative t => (forall x. c x -> t (c' x)) @@ -147,7 +185,9 @@ -> t (Lexeme c' a) mapCategoryA _ (Grapheme g) = pure $ Grapheme g mapCategoryA f (Category c) = Category <$> f c +mapCategoryA f (GreedyCategory c) = GreedyCategory <$> f c mapCategoryA f (Optional ls) = Optional <$> traverse (mapCategoryA f) ls +mapCategoryA f (GreedyOptional ls) = GreedyOptional <$> traverse (mapCategoryA f) ls mapCategoryA _ Metathesis = pure Metathesis mapCategoryA _ Geminate = pure Geminate mapCategoryA f (Wildcard l) = Wildcard <$> mapCategoryA f l @@ -155,9 +195,12 @@ mapCategoryA _ Discard = pure Discard mapCategoryA f (Backreference i c) = Backreference i <$> f c mapCategoryA f (Multiple c) = Multiple <$> f c +mapCategoryA f (Feature r n i kvs l) = Feature r n i kvs <$> mapCategoryA f l +mapCategoryA _ (Autosegment n kvs gs) = pure $ Autosegment n kvs gs --- | The type of a category after expansion. -newtype Expanded a = FromElements { elements :: [Either Grapheme [Lexeme Expanded a]] } +-- | The type of a category after expansion: a simple list of +-- 'CategoryElement's. +newtype Expanded a = FromElements { elements :: [CategoryElement Expanded a] } deriving (Eq, Ord, Show, Generic, NFData) instance Semigroup (Expanded a) where @@ -166,6 +209,9 @@ instance Monoid (Expanded a) where mempty = FromElements [] +-- | Generalise a @'Lexeme' c ''AnyPart'@ so it can be used in any +-- specific part of a sound change, given a way to similarly +-- generalise any categories it contains. generalise :: (c 'AnyPart -> c a) -> Lexeme c 'AnyPart -> Lexeme c a generalise _ (Grapheme g) = Grapheme g generalise f (Category es) = Category $ f es @@ -174,13 +220,13 @@ generalise f (Backreference i es) = Backreference i $ f es generalise f (Wildcard l) = Wildcard $ generalise f l generalise f (Kleene l) = Kleene $ generalise f l +generalise f (Feature r n i kvs l) = Feature r n i kvs $ generalise f l +generalise _ (Autosegment n kvs gs) = Autosegment n kvs gs +-- | Generalise an 'Expanded' category to be used in any part of a +-- sound change, similarly to 'generalise'. generaliseExpanded :: Expanded 'AnyPart -> Expanded a -generaliseExpanded = FromElements . (fmap.fmap.fmap) (generalise generaliseExpanded) . elements - --- | A 'Lexeme' matching a single word boundary, specified as @#@ in Brassica syntax. -pattern Boundary :: Lexeme c a -pattern Boundary = Grapheme GBoundary +generaliseExpanded = FromElements . (fmap.fmap) (generalise generaliseExpanded) . elements deriving instance (forall x. Show (c x)) => Show (Lexeme c a) deriving instance (forall x. Eq (c x)) => Eq (Lexeme c a) @@ -189,26 +235,33 @@ instance (forall x. NFData (c x)) => NFData (Lexeme c a) where rnf (Grapheme g) = rnf g rnf (Category cs) = rnf cs + rnf (GreedyCategory cs) = rnf cs rnf (Optional ls) = rnf ls + rnf (GreedyOptional ls) = rnf ls rnf Metathesis = () rnf Geminate = () rnf (Wildcard l) = rnf l rnf (Kleene l) = rnf l rnf Discard = () - rnf (Backreference i l) = seq i $ rnf l + rnf (Backreference i l) = i `deepseq` rnf l rnf (Multiple l) = rnf l + rnf (Feature r n i kvs l) = r `deepseq` l `deepseq` n `deepseq` i `deepseq` rnf kvs + rnf (Autosegment n kvs gs) = n `deepseq` kvs `deepseq` rnf gs -- | An 'Environment' is a tuple of @(before, after)@ components, --- corresponding to a ‘/ before _ after’ component of a sound change. +-- corresponding to an environment or exception in a sound change: +-- @before _ after@. -- --- Note that an empty environment is just @([], [])@. +-- (An empty environment is just @([], [])@.) type Environment c = ([Lexeme c 'Matched], [Lexeme c 'Matched]) --- | Specifies application direction of rule — either left-to-right or right-to-left. +-- | Specifies application direction of rule: either left-to-right or right-to-left. data Direction = LTR | RTL deriving (Eq, Show, Generic, NFData) --- | Specifies how regularly a rule should be applied. +-- | Specifies how regularly a rule should be applied. A sporadic +-- rule will produce two or more results, preserving the input as one +-- of the outputs. data Sporadicity = ApplyAlways -- ^ Always apply the rule @@ -221,10 +274,11 @@ -- | Flags which can be enabled, disabled or altered on a 'Rule' to -- change how it is applied. data Flags = Flags - { highlightChanges :: Bool - , applyDirection :: Direction - , applyOnceOnly :: Bool - , sporadic :: Sporadicity + { highlightChanges :: Bool -- ^ Whether results from this sound change can be highlighted in a GUI + , applyDirection :: Direction -- ^ Direction in which to apply the rule + , applyOnceOnly :: Bool -- ^ Whether to apply the rule only once to a word + , sporadic :: Sporadicity -- ^ Whether the rule should be applied sporadically, and if so, how + , nonOverlappingTarget :: Bool -- ^ Whether the rule should apply non-iteratively (avoiding environments which overlap with targets) } deriving (Show, Generic, NFData) -- | A default selection of flags which are appropriate for most @@ -236,29 +290,32 @@ -- , 'applyDirection' = 'LTR' -- , 'applyOnceOnly' = 'False' -- , 'sporadic' = 'False' +-- , 'nonOverlappingTarget' = 'False' -- } -- @ -- --- That is: highlight changes, apply from left to right, apply --- repeatedly, and don’t apply sporadically. +-- That is: apply repeatedly and iteratively from left to right, +-- non-sporadically, with the results available for highlighting. defFlags :: Flags defFlags = Flags { highlightChanges = True , applyDirection = LTR , applyOnceOnly = False , sporadic = ApplyAlways + , nonOverlappingTarget = False } --- | A single sound change rule: in Brassica sound-change syntax with all elements specified, --- @-flags target / replacement \/ environment1 | environment2 | … \/ exception@. --- (And usually the 'plaintext' of the rule will contain a 'String' resembling that pattern.) +-- | A single sound change rule. +-- +-- In Brassica sound-change syntax with all elements specified, this would be +-- @-flags target / replacement \/ environment1 \/ environment2 \/ … \/ exception@. data Rule c = Rule { target :: [Lexeme c 'Matched] , replacement :: [Lexeme c 'Replacement] , environment :: [Environment c] , exception :: Maybe (Environment c) , flags :: Flags - , plaintext :: String + , plaintext :: String -- ^ Rule text before parsing (displayed e.g. for debugging purposes) } deriving (Generic) deriving instance (forall a. Show (c a)) => Show (Rule c) @@ -272,40 +329,67 @@ deriving instance (forall a. Show (c a)) => Show (Filter c) deriving instance (forall a. NFData (c a)) => NFData (Filter c) --- | A 'Statement' can be a single sound change rule, a filter, --- or a directive (e.g. category definition). +-- | A 'Statement' within a sound change file can be a single sound +-- change rule, a filter, an instruction to report intermediate +-- results, or some other declaration. +-- +-- The declaration type depends on the current sound change +-- phase. Usually it will be 'Directive' after parsing, or +-- 'GraphemeList' after expansion. data Statement c decl - = RuleS (Rule c) - | FilterS (Filter c) - | DirectiveS decl + = RuleS (Rule c) -- ^ Sound change rule + | FilterS (Filter c) -- ^ Filter + | ReportS -- ^ Report intermediate result + | DeclS decl -- ^ Declaration (phase-dependent) deriving (Generic) deriving instance (forall a. Show (c a), Show decl) => Show (Statement c decl) deriving instance (forall a. NFData (c a), NFData decl) => NFData (Statement c decl) -- | A simple wrapper around 'plaintext' for 'Statement's. Returns --- @""@ for all 'DirectiveS' inputs. +-- @"\"@ for all 'DeclS' inputs. plaintext' :: Statement c decl -> String plaintext' (RuleS r) = plaintext r plaintext' (FilterS (Filter p _)) = p -plaintext' (DirectiveS _) = "" +plaintext' ReportS = "intermediate result" +plaintext' (DeclS _) = "" -- | A set of 'SoundChanges' is simply a list of 'Statement's. type SoundChanges c decl = [Statement c decl] -- | The individual operations used to construct a category in -- Brassica sound-change syntax. -data CategoryModification = Union | Intersect | Subtract +data CategoryModification + = Union -- ^ Written @[Category1 &Category2]@ or @[Category1 Category2]@ + | Intersect -- ^ Written @[Category1 +Category2]@ + | Subtract -- ^ Written @[Category1 -Category2]@ deriving (Show, Eq, Ord, Generic, NFData) --- | The specification of a category in Brassica sound-change syntax. +-- | A single element of a category: a sequence of 'Lexeme's. (Single +-- v'Grapheme's receive some special treatment, e.g. they can be +-- written without surrounding braces in Brassica syntax.) +type CategoryElement category a = [Lexeme category a] + +-- | The specification of a category in Brassica sound-change +-- syntax. Usually this will be as a 'CategorySpec': a list of +-- 'CategoryElement's, each of which modifies the previous definition +-- using the given 'CategoryModification' method. +-- +-- In some positions (e.g. after a 'Backreference') a category must be +-- provided, but that category can be predefined, to be inlined during +-- expansion. In such positions, the given category name is stored as +-- a 'MustInline' category. (In other positions predefined categories +-- are indistinguishable from normal v'Grapheme's, and represented as +-- such.) data CategorySpec a - = CategorySpec [(CategoryModification, Either Grapheme [Lexeme CategorySpec a])] + = CategorySpec [(CategoryModification, CategoryElement CategorySpec a)] | MustInline String -- ^ A single grapheme assumed to have been specified earlier as a category deriving (Show, Eq, Ord, Generic, NFData) -- | The specification of a suprasegmental feature in Brassica -- sound-change syntax. +-- +-- Deprecated since 1.0.0. data FeatureSpec = FeatureSpec { featureBaseName :: Maybe String , featureBaseValues :: CategorySpec 'AnyPart @@ -313,19 +397,32 @@ } deriving (Show, Eq, Ord, Generic, NFData) --- | A definition of a new category, either directly or via features. +-- | A single definition within a category definition block. data CategoryDefinition = DefineCategory String (CategorySpec 'AnyPart) + -- ^ Defines a category with the given name and value | DefineFeature FeatureSpec + -- ^ Defines a feature as a set of categories + | DefineAuto String + -- ^ Defines a category as autosegmental deriving (Show, Eq, Ord, Generic, NFData) -- | A directive used in Brassica sound-change syntax: anything which --- is not actually a sound change - +-- occurs in a sound change file with the primary purpose of defining +-- something for later use. data Directive - = Categories Bool Bool [CategoryDefinition] - -- ^ @categories … end@: first 'Bool' for @new@, - -- second for @noreplace@ + = Categories -- ^ Category definition block + Bool -- ^ Whether category was introduced with @new@ + Bool -- ^ Whether category was introduced with @noreplace@ + [CategoryDefinition] | ExtraGraphemes [String] - -- ^ @extra …@ + -- ^ Extra graphemes declaration: @extra …@ deriving (Show, Eq, Ord, Generic, NFData) + +-- | A list of graphemes, replacing v'Categories' in expanded sound +-- changes. These are used in tokenisation to determine which +-- multigraphs are used, and in rule application to filter unwanted +-- graphemes. The first 'Bool' indicates whether filtration should +-- occur for any particular categories block. +data GraphemeList = GraphemeList Bool [Grapheme] + deriving (Eq, Show, Ord, Generic, NFData) diff --git a/test/DocTests.hs b/test/DocTests.hs new file mode 100644 --- /dev/null +++ b/test/DocTests.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Data.Functor ((<&>)) +import Data.List (intercalate) +import Data.Maybe (mapMaybe) +import Data.Traversable (for) +import Text.Pandoc +import Test.Tasty (defaultMain, testGroup) +import Test.Tasty.Providers + +import qualified Data.Text as T +import qualified Data.Text.IO as T + +import Brassica.SoundChange (applyChanges, concatWithBoundary, getOutput) +import Brassica.SoundChange.Expand (expandSoundChanges) +import Brassica.SoundChange.Parse (parseSoundChanges, errorBundlePretty) +import Brassica.SoundChange.Tokenise (withFirstCategoriesDecl, tokeniseWord) + +main :: IO () +main = defaultMain $ testGroup "brassica-doctests" + [ doctest "docs/Writing-Sound-Changes.md" "" + , doctest "docs/Reference.md" "\ +\categories noreplace\n\ +\C = m n p t ch k b d j g f s sh h v z r l w y\n\ +\-Stress = a e i o u\n\ +\+Stress = á é í ó ú\n\ +\auto -Stress\n\ +\V = &&Stress\n\ +\end\n" + ] + +doctest :: FilePath -> String -> TestTree +doctest file prefix = singleTest file $ DocTest file prefix + +data DocTest = DocTest FilePath String + +instance IsTest DocTest where + testOptions = pure [] + run _ (DocTest path prefix) _ = do + doc <- T.readFile path + runIO (readMarkdown def { readerExtensions = githubMarkdownExtensions } doc) <&> \case + Left err -> testFailed $ T.unpack $ renderError err + Right (Pandoc _ blocks) -> + let rules = flip mapMaybe blocks $ \case + CodeBlock (_, cs, _) text + | "brassica" `elem` cs + -> + let rule = prefix ++ T.unpack text + examples = flip mapMaybe (T.lines text) $ \x -> + case words $ T.unpack x of + ";":i:"→":o:_ -> Just (i, o) + _ -> Nothing + in Just (rule, examples) + _ -> Nothing + results = for rules $ \(rule, examples) -> + case parseSoundChanges rule of + Left err -> Left $ errorBundlePretty err + Right scs -> + case expandSoundChanges scs of + Left err -> Left $ show err + Right scs' -> for examples $ \(i, o) -> + case withFirstCategoriesDecl tokeniseWord scs' i of + Left err -> Left $ errorBundlePretty err + Right i' -> + let o' = mapMaybe getOutput $ applyChanges scs' i' + o'' = + if null o' + then "(deleted)" + else intercalate "/" $ concatWithBoundary <$> o' + in if o == o'' + then Right ("" :: String) + else Left $ + "expected " ++ i ++ "→" ++ o ++ + ", got " ++ o'' ++ + "\nfor sound change:\n" ++ rule + in case results of + Left err -> testFailed err + Right _ -> testPassed "" diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -5,6 +5,7 @@ import Conduit import Control.Category ((>>>)) import Control.Monad.Trans.Except (runExceptT, throwE) +import Data.Maybe (mapMaybe) import System.IO (IOMode(..), withFile) import Test.Tasty ( defaultMain, testGroup, TestTree ) import Test.Tasty.Golden (goldenVsFile) @@ -13,35 +14,35 @@ import qualified Data.ByteString.UTF8 as B8 import qualified Data.Text as T -import Brassica.SoundChange (applyChanges, splitMultipleResults, applyChangesWithLogs, reportAsText) -import Brassica.SoundChange.Category (expandSoundChanges) +import Brassica.SoundChange (applyChanges, getOutput, splitMultipleResults, reportAsText, GraphemeList) +import Brassica.SoundChange.Expand (expandSoundChanges) import Brassica.SoundChange.Parse (parseSoundChanges, errorBundlePretty) import Brassica.SoundChange.Tokenise (tokeniseWords, detokeniseWords, withFirstCategoriesDecl, Component, getWords) -import Brassica.SoundChange.Types (SoundChanges, PWord, plaintext', Expanded, Grapheme) +import Brassica.SoundChange.Types (SoundChanges, PWord, plaintext', Expanded) main :: IO () main = defaultMain $ testGroup "brassica-tests" - [ proto21eTest applyChanges showWord "proto21e golden test" "proto21e.out" "proto21e.golden" - , proto21eTest applyChangesWithLogs showLogs "proto21e golden test with log" "proto21e-log.out" "proto21e-log.golden" + [ changesTest ((mapMaybe getOutput .) . applyChanges) showWord "changes golden test" "words.out" "words.golden" + , changesTest applyChanges showLogs "changes golden test with log" "words-log.out" "words-log.golden" ] where showWord = detokeniseWords . concatMap (splitMultipleResults " ") showLogs logs = unlines $ fmap (reportAsText plaintext') $ concat $ getWords logs -proto21eTest - :: (SoundChanges Expanded [Grapheme] -> PWord -> [a]) +changesTest + :: (SoundChanges Expanded GraphemeList -> PWord -> [a]) -> ([Component [a]] -> String) -> String -> FilePath -> FilePath -> TestTree -proto21eTest applyFn showWord testName outName goldenName = +changesTest applyFn showWord testName outName goldenName = let outName' = "test/" ++ outName goldenName' = "test/" ++ goldenName in goldenVsFile testName goldenName' outName' $ withFile outName' WriteMode $ \outFile -> fmap (either id id) . runExceptT $ do - soundChangesData <- B8.toString <$> liftIO (B.readFile "test/proto21e.bsc") + soundChangesData <- B8.toString <$> liftIO (B.readFile "test/changes.bsc") soundChanges' <- catchEither (parseSoundChanges soundChangesData) $ \err -> do liftIO $ putStrLn $ "Cannot parse the SCA file because:\n" ++ @@ -59,7 +60,7 @@ withFirstCategoriesDecl tokeniseWords soundChanges >>> (fmap.fmap.fmap) (applyFn soundChanges) >>> either prettyError prettyOutput - liftIO $ withSourceFile "test/proto21e.in" $ flip connect + liftIO $ withSourceFile "test/words.in" $ flip connect $ decodeUtf8C .| linesUnboundedC .| mapC (evolve . T.unpack)