diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,1 @@ +# Changelog for brassica diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Brad Neimann (c) 2020-2022 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Brad Neimann nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,25 @@ +# Brassica + +Brassica is a new sound change applier. +Its features include: + +- Can be used interactively both [online](http://bradrn.com/brassica/index.html) and as a desktop application, or non-interactively in batch mode on the command-line or as a Haskell library +- Natively supports the MDF dictionary format, also used by tools including [SIL Toolbox](https://software.sil.org/toolbox/) and [Lexique Pro](https://software.sil.org/lexiquepro/) +- First-class support for multigraphs +- Easy control over rule application: apply sound changes sporadically, right-to-left, and in many more ways +- Live preview and control over output highlighting allows fast iteration through rules +- 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 +- Comes with a paradigm builder 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. + +Download Brassica from the [releases page](https://github.com/bradrn/brassica/releases/latest). +Alternately, try it online at http://bradrn.com/brassica. +As of the time of writing prebuilt binaries exist only for Windows. +Instructions for building from source are available at [`BUILDING.md`](./BUILDING.md). + +![Image of Brassica with some example sound changes](https://raw.githubusercontent.com/bradrn/brassica/v0.0.3/gui-interface-example.png) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bench/Changes.hs b/bench/Changes.hs new file mode 100644 --- /dev/null +++ b/bench/Changes.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import Criterion.Main (defaultMain, bench, nf, bgroup) +import Data.FileEmbed (embedFile) +import Data.Text (unpack) +import Data.Text.Encoding (decodeUtf8) + +import Brassica.SoundChange + +main :: IO () +main = defaultMain + [ bgroup "single" + [ bgroup "basic" + [ bgroup "0" $ benchChanges basic ["b"] + , bgroup "1" $ benchChanges basic ["a"] + , bgroup "2" $ benchChanges basic ["a","b"] + , bgroup "4" $ benchChanges basic ["a","b","x","a"] + , bgroup "8" $ benchChanges basic ["a","b","x","a","x","b","a","b"] + , bgroup "8a" $ benchChanges basic ["b","b","x","b","x","b","b","b"] + ] + , bgroup "complex" + [ bgroup "1" $ benchChanges complex ["t"] + , bgroup "2" $ benchChanges complex ["ti"] + , bgroup "4" $ benchChanges complex ["a", "t", "i", "e"] + , bgroup "8" $ benchChanges complex ["n", "y", "i", "u", "t", "i", "e", "a"] + , bgroup "16" $ benchChanges complex ["a", "n", "y", "i", "u", "t", "i", "e", "d", "y", "i", "e", "t", "a", "d", "a"] + , bgroup "16a" $ benchChanges complex ["u", "n", "y", "i", "u", "t", "i", "e", "d", "y", "a", "e", "t", "a", "d", "a"] + ] + ] + , bgroup "many" + [ bench "parse" $ nf parseSoundChanges manyChanges + , bench "parseRun" $ case parseSoundChanges manyChanges of + Left _ -> error "invalid changes file" + Right cs -> case withFirstCategoriesDecl tokeniseWords cs manyWords of + Left _ -> error "invalid words file" + Right ws -> nf (fmap $ applyChanges cs) $ getWords ws + ] + ] + where + basic = Rule + { target = [Grapheme "a"] + , replacement = [Grapheme "b"] + , environment = ([], []) + , exception = Nothing + , flags = defFlags + , plaintext = "a/b" + } + + complex = Rule + { target = + [ Category [GraphemeEl "t", GraphemeEl "d", GraphemeEl "n"] + , Optional [Grapheme "y"] + , Category [GraphemeEl "i", GraphemeEl "e"] + ] + , replacement = + [ Category [GraphemeEl "c", GraphemeEl "j", GraphemeEl "nh"] + , Optional [Geminate] + ] + , environment = + ( [Category [BoundaryEl, GraphemeEl "a", GraphemeEl "e", GraphemeEl "i"]] + , [Category [GraphemeEl "a", GraphemeEl "e", GraphemeEl "i", GraphemeEl "o", GraphemeEl "u"]] + ) + , exception = Nothing + , flags = defFlags + , plaintext = "[t d n] (y) [i e] / [č j ñ] (>) / [# a e i] _ [a e i o u]" + } + + benchChanges cs l = + -- [ bench "log" $ nf (applyStatementWithLogs (RuleS cs)) l + -- given the implementation of logging, the above benchmark doesn't help very much at all + [ bench "nolog" $ nf (applyChanges [RuleS cs]) l + ] + +manyChanges :: String +manyChanges = unpack $ decodeUtf8 $(embedFile "bench/sample-changes.bsc") + +manyWords :: String +manyWords = unpack $ decodeUtf8 $(embedFile "bench/sample-words.lex") diff --git a/bench/Paradigm.hs b/bench/Paradigm.hs new file mode 100644 --- /dev/null +++ b/bench/Paradigm.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Criterion.Main (bench, nf, defaultMain) + +import Brassica.Paradigm + +main :: IO () +main = defaultMain + [ bench "small" $ nf (build smallParadigm) smallWords + , bench "mid" $ nf (build smallParadigm) largeWords + , bench "mid2" $ nf (build largeParadigm) smallWords + , bench "large" $ nf (build largeParadigm) largeWords + ] + where + build = concatMap . applyParadigm + +smallParadigm :: Paradigm +smallParadigm = + [ NewFeature $ Feature Always Nothing + [ Concrete [Prefix 1 "a"] + , Concrete [Prefix 1 "b"] + , Concrete [Prefix 1 "c"] + ] + , NewFeature $ Feature Always Nothing + [ Concrete [Suffix 1 "x"] + , Concrete [Suffix 1 "y"] + , Concrete [] + ] + , NewFeature $ Feature Always Nothing + [ Concrete [Prefix 2 "n", Suffix 2 "v"] + , Concrete [Prefix 2 "n", Suffix 2 "w"] + , Concrete [Prefix 2 "m", Suffix 2 "w"] + ] + ] + +largeParadigm :: Paradigm +largeParadigm = + [ NewFeature $ Feature Always Nothing + [ Concrete [Prefix 1 "a"] + , Concrete [Prefix 1 "b"] + , Concrete [Prefix 1 "c"] + , Concrete [Prefix 1 "d"] + , Concrete [Prefix 1 "e"] + , Concrete [Prefix 1 "f"] + , Concrete [Prefix 1 "g"] + , Concrete [Prefix 1 "h"] + , Concrete [Prefix 1 "i"] + ] + , NewFeature $ Feature Always Nothing + [ Abstract "abstract1a" + , Abstract "abstract1b" + ] + , NewFeature $ Feature Always Nothing + [ Concrete [Prefix 2 "n", Suffix 2 "v"] + , Concrete [Prefix 2 "n", Suffix 2 "w"] + , Concrete [Prefix 2 "m", Suffix 2 "v"] + , Concrete [Prefix 2 "m", Suffix 2 "w"] + ] + , NewFeature $ Feature Always Nothing + [ Abstract "abstract2a" + , Abstract "abstract2b" + ] + , NewFeature $ Feature Always Nothing + [ Concrete [Suffix 4 "a"] + , Concrete [Suffix 4 "b"] + , Concrete [Suffix 4 "c"] + , Concrete [Suffix 4 "d"] + , Concrete [Suffix 4 "e"] + , Concrete [Suffix 4 "f"] + , Concrete [Suffix 4 "g"] + , Concrete [Suffix 4 "h"] + , Concrete [Suffix 4 "i"] + ] + , NewMapping ["abstract1a","abstract2a"] [Suffix 3 "q"] + , NewMapping ["abstract1a","abstract2b"] [Suffix 3 "w"] + , NewMapping ["abstract1b","abstract2a"] [Suffix 3 "e"] + , NewMapping ["abstract1b","abstract2b"] [Suffix 3 "r"] + ] + +smallWords :: [String] +smallWords = ["word", "wurd", "ward", "werd", "wird"] + +largeWords :: [String] +largeWords = ["word", "wurd", "ward", "werd", "wird", "xyz", "yzx", "zxy", "zyx", "yxz", "xzy", "qw", "we", "er", "rt", "ty"] diff --git a/brassica.cabal b/brassica.cabal new file mode 100644 --- /dev/null +++ b/brassica.cabal @@ -0,0 +1,111 @@ +cabal-version: 2.0 +name: brassica +version: 0.0.3 +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 . + +category: Linguistics +homepage: https://github.com/bradrn/brassica#readme +bug-reports: https://github.com/bradrn/brassica/issues +author: Brad Neimann +maintainer: Brad Neimann +copyright: 2020-2022 Brad Neimann +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/bradrn/brassica + +library + exposed-modules: Brassica.SoundChange + , Brassica.SoundChange.Apply + , Brassica.SoundChange.Apply.Internal + , Brassica.SoundChange.Apply.Internal.MultiZipper + , Brassica.SoundChange.Category + , Brassica.SoundChange.Frontend.Internal + , Brassica.SoundChange.Parse + , Brassica.SoundChange.Tokenise + , Brassica.SoundChange.Types + , Brassica.MDF + , Brassica.Paradigm + other-modules: Brassica.Paradigm.Apply + , Brassica.Paradigm.Parse + , Brassica.Paradigm.Types + hs-source-dirs: src + ghc-options: -Wall + build-depends: + base >=4.7 && <5 + , containers >=0.6 && <0.7 + , deepseq >=1.4 && <1.5 + , megaparsec >=8.0 && <8.1 + , mtl >=2.2 && <2.3 + , parser-combinators >=1.2 && <1.3 + , split >=0.2 && <0.3 + , transformers >=0.5 && <0.6 + + default-language: Haskell2010 + +executable brassica + main-is: Main.hs + hs-source-dirs: cli + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base >=4.7 && <5 + , brassica + , bytestring ^>=0.10 + , conduit ^>=1.3 + , optparse-applicative ^>=0.17 + , text ^>=1.2 + + default-language: Haskell2010 + +benchmark changes-bench + type: exitcode-stdio-1.0 + main-is: Changes.hs + hs-source-dirs: bench + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base >=4.7 && <5 + , brassica + , criterion >=1.5 && <1.6 + , file-embed >=0.0.15 && <0.0.16 + , text >=1.2 && <1.3 + + default-language: Haskell2010 + +benchmark paradigm-bench + type: exitcode-stdio-1.0 + main-is: Paradigm.hs + hs-source-dirs: bench + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base >=4.7 && <5 + , brassica + , criterion >=1.5 && <1.6 + + default-language: Haskell2010 + +test-suite changes-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + build-depends: + base >=4.7 && <5 + , brassica + , tasty ^>=1.4 + , tasty-golden ^>=2.3 + , bytestring ^>=0.10 + , text ^>=1.2 + , transformers ^>=0.5 + , conduit ^>=1.3 + , utf8-string ^>=1.0 + + default-language: Haskell2010 diff --git a/cli/Main.hs b/cli/Main.hs new file mode 100644 --- /dev/null +++ b/cli/Main.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +module Main where + +import Control.Exception (Exception) + +import Conduit +import qualified Data.ByteString as B +import Data.Text (pack, unpack, Text) +import Data.Text.Encoding (decodeUtf8) +import Options.Applicative + +import Brassica.SoundChange +import Brassica.SoundChange.Frontend.Internal + + +main :: IO () +main = do + Options{..} <- execParser opts + changesText <- unpack . decodeUtf8 <$> B.readFile rulesFile + + case parseSoundChanges changesText of + Left err -> + putStrLn $ errorBundlePretty err + Right rules -> + withSourceFileIf inWordsFile $ \inC -> + withSinkFileIf outWordsFile $ \outC -> + runConduit $ + inC + .| processWords (incrFor wordsFormat) rules wordsFormat tokMode outMode + .| outC + + where + opts = info (args <**> helper) fullDesc + + args = Options + <$> strArgument + (metavar "RULES" <> help "File containing sound changes") + <*> flag Raw MDF + (long "mdf" <> help "Parse input words in MDF format") + <*> flag Normal AddEtymons + (long "etymons" <> help "With --mdf, add etymologies to output") + <*> (flag' ReportRulesApplied + (long "report" <> help "Report rules applied rather than outputting words") + <|> + flag (ApplyRules NoHighlight MDFOutput) (ApplyRules NoHighlight WordsOnlyOutput) + (long "wordlist" <> help "With --mdf, output only a list of the derived words")) + <*> optional (strOption + (long "in" <> short 'i' <> help "File containing input words (if not specified will read from stdin)")) + <*> optional (strOption + (long "out" <> short 'o' <> help "File to which output words should be written (if not specified will write to stdout)")) + + incrFor Raw = True + incrFor MDF = False + + withSourceFileIf :: Maybe FilePath -> (ConduitM i B.ByteString IO () -> IO a) -> IO a + withSourceFileIf = maybe ($ stdinC) withSourceFile + + withSinkFileIf :: Maybe FilePath -> (ConduitM B.ByteString o IO () -> IO a) -> IO a + withSinkFileIf = maybe ($ stdoutC) withSinkFile + +data Options = Options + { rulesFile :: String + , wordsFormat :: InputLexiconFormat + , tokMode :: TokenisationMode + , outMode :: ApplicationMode + , inWordsFile :: Maybe String + , outWordsFile :: Maybe String + } deriving (Show) + +processWords + :: (MonadIO m, MonadThrow m) + => Bool -- split into lines? + -> SoundChanges + -> InputLexiconFormat + -> TokenisationMode + -> ApplicationMode + -> ConduitT B.ByteString B.ByteString m () +processWords incr rules wordsFormat tokMode outMode = + decodeUtf8C + .| (if incr then linesUnboundedC else mapC id) + .| mapC (processApplicationOutput . evolve . unpack) + .| throwOnLeft + .| (if incr then unlinesC else mapC id) + .| encodeUtf8C + where + evolve ws = parseTokeniseAndApplyRules rules ws wordsFormat tokMode outMode Nothing + + throwOnLeft :: (MonadThrow m, Exception e) => ConduitT (Either e r) r m () + throwOnLeft = awaitForever $ \case + Left e -> throwM e + Right r -> yield r + + processApplicationOutput :: ApplicationOutput PWord Statement -> Either ParseException Text + processApplicationOutput (HighlightedWords cs) = Right $ pack $ detokeniseWords $ (fmap.fmap) fst cs + processApplicationOutput (AppliedRulesTable is) = Right $ pack $ unlines $ reportAsText plaintext' <$> is + processApplicationOutput (ParseError e) = Left $ ParseException $ errorBundlePretty e + +newtype ParseException = ParseException String + deriving Show + +instance Exception ParseException diff --git a/src/Brassica/MDF.hs b/src/Brassica/MDF.hs new file mode 100644 --- /dev/null +++ b/src/Brassica/MDF.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} + +{-| This module contains types and functions for working with the MDF + dictionary format, used by programs such as [SIL Toolbox](https://software.sil.org/toolbox/). + For more on the MDF format, refer to e.g. + [Coward & Grimes (2000), /Making Dictionaries: A guide to lexicography and the Multi-Dictionary Formatter/](http://downloads.sil.org/legacy/shoebox/MDF_2000.pdf). +-} +module Brassica.MDF + ( + -- * MDF files + MDF(..) + , MDFLanguage(..) + , fieldLangs + -- * Parsing + , parseMDFRaw + , parseMDFWithTokenisation + -- ** Re-export + , errorBundlePretty + -- * Conversion + , componentiseMDF + , componentiseMDFWordsOnly + , duplicateEtymologies + ) where + +import Control.Category ((>>>)) +import Data.Char (isSpace) +import Data.Void (Void) + +import qualified Data.Map as M +import Text.Megaparsec +import Text.Megaparsec.Char + +import Brassica.SoundChange.Tokenise +import Brassica.SoundChange.Types (Grapheme, PWord) +import Data.Maybe (fromMaybe) + +-- | An MDF (Multi-Dictionary Formatter) file, represented as a list +-- of (field marker, whitespace, field value) tuples. The field marker +-- is represented excluding its initial slash; whitespace after the +-- field marker is also stored, allowing the original MDF file to be +-- precisely recovered. Field values should includes all whitespace to +-- the next marker. All field values are stored as 'String's, with the +-- exception of 'Vernacular' fields, which have type @v@. +-- +-- For instance, the following MDF file: +-- +-- > \lx kapa +-- > \ps n +-- > \ge parent +-- > \se sakapa +-- > \ge father +-- +-- Could be stored as: +-- +-- > MDF [ ("lx", " ", Right "kapa\n") +-- > , ("ps", " ", Left "n\n") +-- > , ("ge", " ", Left "parent\n") +-- > , ("se", " ", Right "sakapa\n") +-- > , ("ge", " ", Left "father") +-- > ] +newtype MDF v = MDF { unMDF :: [(String, String, Either String v)] } + deriving (Show, Functor) + +type Parser = Parsec Void String + +sc :: Parser String +sc = fmap (fromMaybe "") $ optional $ takeWhile1P (Just "white space") isSpace + +parseToSlash :: Parser String +parseToSlash = takeWhileP (Just "field value") (/= '\\') + +entry :: Parser v -> Parser (String, String, Either String v) +entry pv = do + _ <- char '\\' + marker <- takeWhile1P (Just "field name") (not . isSpace) + s <- sc + value <- case M.lookup marker fieldLangs of + Just Vernacular -> Right <$> pv + _ -> Left <$> parseToSlash + pure (marker, s, value) + +-- | Parse an MDF file to an 'MDF', storing the 'Vernacular' fields as 'String's. +parseMDFRaw :: String -> Either (ParseErrorBundle String Void) (MDF String) +parseMDFRaw = runParser (fmap MDF $ sc *> many (entry parseToSlash) <* eof) "" + +-- | Parse an MDF file to an 'MDF', parsing the 'Vernacular' fields +-- into 'Component's in the process. +parseMDFWithTokenisation + :: [Grapheme] + -> String + -> Either (ParseErrorBundle String Void) (MDF [Component PWord]) +parseMDFWithTokenisation (sortByDescendingLength -> gs) = + runParser (fmap MDF $ sc *> p <* eof) "" + where + p = many $ entry $ componentsParser $ wordParser "\\" gs + +-- | Convert an 'MDF' to a list of 'Component's representing the same +-- textual content. Vernacular field values are left as is; everything +-- else is treated as a 'Separator', so that it is not disturbed by +-- operations such as rule application or rendering to text. +componentiseMDF :: MDF [Component a] -> [Component a] +componentiseMDF = unMDF >>> concatMap \case + (m, s, Left v) -> [Separator ('\\':m ++ s ++ v)] + (m, s, Right v) -> Separator ('\\':m ++ s) : v + +-- | As with 'componentiseMDF', but the resulting 'Component's contain +-- the contents of 'Vernacular' fields only; all else is +-- discarded. The first parameter specifies the 'Separator' to insert +-- after each vernacular field. +componentiseMDFWordsOnly :: MDF [Component a] -> [Component a] +componentiseMDFWordsOnly = unMDF >>> concatMap \case + (_, _, Right v) -> v + _ -> [] + +-- | Add etymological fields to an 'MDF' by duplicating the values in +-- @\lx@, @\se@ and @\ge@ fields. e.g.: +-- +-- > \lx kapa +-- > \ps n +-- > \ge parent +-- > \se sakapa +-- > \ge father +-- +-- Would become: +-- +-- > \lx kapa +-- > \ps n +-- > \ge parent +-- > \et kapa +-- > \eg parent +-- > \se sakapa +-- > \ge father +-- > \et sakapa +-- > \eg father +-- +-- This can be helpful when applying sound changes to an MDF file: the +-- vernacular words can be copied as etymologies, and then the sound +-- changes can be applied leaving the etymologies as is. +duplicateEtymologies + :: (v -> String) + -- ^ Function to convert from vernacular field values to + -- strings. Can also be used to preprocess the value of the + -- resulting @\et@ fields, e.g. by prepending @*@ or similar. + -> MDF v -> MDF v +duplicateEtymologies typeset = MDF . go Nothing Nothing . unMDF + where + mkEt word gloss = word' gloss' + where + word' = case word of + Just et -> (("et", " ", Left $ typeset et) :) + Nothing -> id + gloss' = case gloss of + Just eg -> [("eg", " ", Left eg)] + Nothing -> [] + + go word gloss [] = mkEt word gloss + go word _ (f@("ge", _, Left gloss'):fs) -- store gloss field for future etymology + = f : go word (Just gloss') fs + go word gloss (f@(m, _, Right word'):fs) -- add etymology & store word if word or subentry field reached + | m == "lx" || m == "se" + = mkEt word gloss ++ f : go (Just word') Nothing fs + go word gloss (f@("dt", _, _):fs) -- add etymology if date (usually final field in entry) reached + = mkEt word gloss ++ f : go Nothing Nothing fs + go word gloss (f:fs) = f : go word gloss fs + + +-- | The designated language of an MDF field. +data MDFLanguage = English | National | Regional | Vernacular | Other + deriving (Eq, Show) + +-- | A 'M.Map' from the most common field markers to the language of +-- their values. +-- +-- (Note: This is currently hardcoded in the source code, based on the +-- values in the MDF definitions from SIL Toolbox. There’s probably a +-- more principled way of defining this, but hardcoding should suffice +-- for now.) +fieldLangs :: M.Map String MDFLanguage +fieldLangs = M.fromList + [ ("1d" , Vernacular) , ("1e" , Vernacular) , ("1i" , Vernacular) + , ("1p" , Vernacular) , ("1s" , Vernacular) , ("2d" , Vernacular) + , ("2p" , Vernacular) , ("2s" , Vernacular) , ("3d" , Vernacular) + , ("3p" , Vernacular) , ("3s" , Vernacular) , ("4d" , Vernacular) + , ("4p" , Vernacular) , ("4s" , Vernacular) , ("a" , Vernacular) + , ("an" , Vernacular) , ("bb" , English) , ("bw" , English) + , ("ce" , English) , ("cf" , Vernacular) , ("cn" , National) + , ("cr" , National) , ("de" , English) , ("dn" , National) + , ("dr" , Regional) , ("dt" , Other) , ("dv" , Vernacular) + , ("ec" , English) , ("ee" , English) , ("eg" , English) + , ("en" , National) , ("er" , Regional) , ("es" , English) + , ("et" , Other) {- defined as vernacular in SIL Toolbox, but by + definition it's really a different language -} + , ("ev" , Vernacular) , ("ge" , English) + , ("gn" , National) , ("gr" , Regional) , ("gv" , Vernacular) + , ("hm" , English) , ("is" , English) , ("lc" , Vernacular) + , ("le" , English) , ("lf" , English) , ("ln" , National) + , ("lr" , Regional) , ("lt" , English) , ("lv" , Vernacular) + , ("lx" , Vernacular) , ("mn" , Vernacular) , ("mr" , Vernacular) + , ("na" , English) , ("nd" , English) , ("ng" , English) + , ("np" , English) , ("nq" , English) , ("ns" , English) + , ("nt" , English) , ("oe" , English) , ("on" , National) + , ("or" , Regional) , ("ov" , Vernacular) , ("pc" , English) + , ("pd" , English) , ("pde", English) , ("pdl", English) + , ("pdn", National) , ("pdr", Regional) , ("pdv", Vernacular) + , ("ph" , Other) , ("pl" , Vernacular) , ("pn" , National) + , ("ps" , English) , ("rd" , Vernacular) , ("re" , English) + , ("rf" , English) , ("rn" , National) , ("rr" , Regional) + , ("sc" , English) , ("sd" , English) , ("se" , Vernacular) + , ("sg" , Vernacular) , ("sn" , English) , ("so" , English) + , ("st" , English) , ("sy" , Vernacular) , ("tb" , English) + , ("th" , Vernacular) , ("u" , Vernacular) , ("ue" , English) + , ("un" , National) , ("ur" , Regional) , ("uv" , Vernacular) + , ("va" , Vernacular) , ("ve" , English) , ("vn" , National) + , ("vr" , Regional) , ("we" , English) , ("wn" , National) + , ("wr" , Regional) , ("xe" , English) , ("xn" , National) + , ("xr" , Regional) , ("xv" , Vernacular) + ] diff --git a/src/Brassica/Paradigm.hs b/src/Brassica/Paradigm.hs new file mode 100644 --- /dev/null +++ b/src/Brassica/Paradigm.hs @@ -0,0 +1,24 @@ +module Brassica.Paradigm + ( + -- * Types + Process(..) + , Affix + , Grammeme(..) + , AbstractGrammeme(..) + , Condition(..) + , Feature(..) + , FeatureName(..) + , Statement(..) + , Paradigm + -- * Application + , applyParadigm + -- * Parsing + , parseParadigm + -- ** Re-export + , errorBundlePretty + ) where + +import Brassica.Paradigm.Apply +import Brassica.Paradigm.Parse +import Brassica.Paradigm.Types +import Text.Megaparsec (errorBundlePretty) diff --git a/src/Brassica/Paradigm/Apply.hs b/src/Brassica/Paradigm/Apply.hs new file mode 100644 --- /dev/null +++ b/src/Brassica/Paradigm/Apply.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE LambdaCase #-} + +module Brassica.Paradigm.Apply (applyParadigm) where + +import Brassica.Paradigm.Types + +import Data.List (sortOn) +import Data.Maybe (mapMaybe) +import Data.Ord (Down(Down)) + +-- | Apply the given 'Paradigm' to a root, to produce all possible +-- derived forms. +applyParadigm :: Paradigm -> String -> [String] +applyParadigm p w = + let fs = mapMaybe getFeature p + ms = mapMaybe getMapping p + in applyTo w . expand ms <$> combinations fs + where + getFeature (NewFeature f) = Just f + getFeature _ = Nothing + + getMapping (NewMapping k v) = Just (k,v) + getMapping _ = Nothing + +combinations :: [Feature] -> [[Grammeme]] +combinations = go [] + where + go :: [(Maybe FeatureName, Grammeme)] -> [Feature] -> [[Grammeme]] + go acc [] = return $ snd <$> reverse acc + go acc (Feature c n gs : fs) = + if satisfied (flip lookup acc . Just) c + then do + g <- gs + go ((n,g) : acc) fs + else go acc fs + + satisfied + :: (FeatureName -> Maybe Grammeme) + -> Condition + -> Bool + satisfied _ Always = True + satisfied l (Is n g) = case l n of + Just g' -> g == g' + Nothing -> False + satisfied l (Not n g) = case l n of + Just g' -> g /= g' + Nothing -> True + +expand :: [([AbstractGrammeme], Affix)] -> [Grammeme] -> [Process] +expand ms = concat . ((++) <$> concretes <*> (replace . filterAbstract)) + where + concretes :: [Grammeme] -> [Affix] + concretes = mapMaybe $ \case + Concrete affix -> Just affix + Abstract _ -> Nothing + + filterAbstract :: [Grammeme] -> [AbstractGrammeme] + filterAbstract = mapMaybe $ \case + Concrete _ -> Nothing + Abstract g -> Just g + + replace :: [AbstractGrammeme] -> [Affix] + replace gs = do + (condition, replacement) <- ms + if condition `subsetOf` gs + then return replacement + else [] + + xs `subsetOf` ys = all (`elem` ys) xs + +applyTo :: String -> [Process] -> String +applyTo w is = + let ps = concatMap snd $ sortOn (Down . fst) $ mapMaybe getPrefix is + ss = concatMap snd $ sortOn fst $ mapMaybe getSuffix is + in ps ++ w ++ ss + where + getPrefix (Prefix s i) = Just (s,i) + getPrefix _ = Nothing + + getSuffix (Suffix s i) = Just (s,i) + getSuffix _ = Nothing diff --git a/src/Brassica/Paradigm/Parse.hs b/src/Brassica/Paradigm/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Brassica/Paradigm/Parse.hs @@ -0,0 +1,91 @@ +module Brassica.Paradigm.Parse (parseParadigm) where + +import Control.Monad (void) +import Data.Char (isSpace) +import Data.Void (Void) + +import Text.Megaparsec +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L + +import Brassica.Paradigm.Types +import Data.Maybe (fromMaybe) + +type Parser = Parsec Void String + +-- adapted from megaparsec source: like 'space1', but does not +-- consume newlines (which are important for rule separation) +space1' :: Parser () +space1' = void $ takeWhile1P (Just "whitespace") ((&&) <$> isSpace <*> (/='\n')) + +sc :: Parser () +sc = L.space space1' (L.skipLineComment "*") empty + +lexeme :: Parser a -> Parser a +lexeme = L.lexeme sc + +symbol :: String -> Parser String +symbol = L.symbol sc + +name :: Parser String +name = lexeme $ some alphaNumChar + +slot :: Parser (String -> Process) +slot = do + n <- L.signed (pure ()) L.decimal + pure $ if n > 0 then Suffix n else Prefix (-n) + +morphValue :: Parser String +morphValue = lexeme (takeWhile1P (Just "letter") $ (&&) <$> (not.isSpace) <*> (/=')')) + +process :: Parser Process +process = slot <* char '.' <*> morphValue + +oneOrMany :: Parser p -> Parser [p] +oneOrMany p = between (symbol "(") (symbol ")") (many p) <|> fmap pure p + +affix :: Parser Affix +affix = oneOrMany process + +grammeme :: Parser Grammeme +grammeme = + Concrete <$> affix + <|> Abstract . AbstractGrammeme <$> name + +condition :: Parser Condition +condition = do + _ <- symbol "when" + between (symbol "(") (symbol ")") $ + try (Is . FeatureName <$> name <* symbol "is" <*> grammeme) + <|> Not . FeatureName <$> name <* symbol "not" <*> grammeme + +feature :: Parser Feature +feature = do + c <- fromMaybe Always <$> optional condition + globalSlot <- optional $ try $ slot <* space1' + case globalSlot of + Nothing -> do + n <- optional $ try $ name <* symbol "=" + gs <- some grammeme + _ <- optional eol + return $ Feature c (FeatureName <$> n) gs + Just globalSlot' -> do + n <- optional $ try $ name <* symbol "=" + gs <- some $ oneOrMany $ process <|> (globalSlot' <$> morphValue) + _ <- optional eol + return $ Feature c (FeatureName <$> n) (Concrete <$> gs) + +mapping :: Parser ([AbstractGrammeme], Affix) +mapping = (,) <$> manyTill (AbstractGrammeme <$> name) (symbol ">") <*> affix <* optional eol + +statement :: Parser Statement +statement = sc *> + (uncurry NewMapping <$> try mapping + <|> NewFeature <$> feature) + +-- | 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 . +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 new file mode 100644 --- /dev/null +++ b/src/Brassica/Paradigm/Types.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Brassica.Paradigm.Types where + +import Data.String (IsString) + +-- | Represents a single morphophonological process: currently, either +-- prefixation or suffixation of a 'String'. The 'Int' gives the +-- distance of the affix from the root. +data Process + = Prefix Int String + | Suffix Int String + deriving (Show, Eq) + +-- | A single affix (using the term in a wide sense) can be thought of +-- as a list of morphophonological processes. For instance, the Berber +-- feminine circumfix /t-/…/-t/ might be represented as +-- @['Prefix' 1 "t", 'Suffix' 1 "t"] :: 'Affix'@. +type Affix = [Process] + +-- | A 'Grammeme' represents one value of a grammatical feature: for +-- instance past, or dual. This can be realised as a 'Concrete' affix, +-- or can be left 'Abstract' so that it can be encoded in a cumulative +-- morph or similar. +-- +-- (The name is from Wikipedia; it doesn’t seem widely-used, but I can +-- find no better for this concept.) +data Grammeme = Concrete Affix | Abstract AbstractGrammeme + deriving (Show, Eq) + +-- | An abstract identifier for a 'Grammeme'. +newtype AbstractGrammeme = AbstractGrammeme String + deriving stock (Show, Eq) + deriving newtype (IsString) + +-- | A condition which must be satisfied before including a 'Feature' +-- 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' + | Not FeatureName Grammeme + -- ^ Satisfied when the specified feature has /not/ been assigned + -- to the specified 'Grammeme' + deriving (Show, Eq) + +-- | A grammatical feature, which may be realised by one of a +-- selection of 'Grammeme's. A feature may be given a descriptive +-- name, as well as a condition which must be satisfied for the +-- 'Feature' to be included in a word. +data Feature = Feature Condition (Maybe FeatureName) [Grammeme] + deriving (Show, Eq) + +newtype FeatureName = FeatureName String + deriving stock (Show, Eq) + deriving newtype (IsString) + +-- | Each statement in a paradigm description specifies either a new +-- 'Feature', or a new mapping from a set of abstract grammemes to +-- their realisation. +data Statement = NewFeature Feature | NewMapping [AbstractGrammeme] Affix + 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.) +type Paradigm = [Statement] diff --git a/src/Brassica/SoundChange.hs b/src/Brassica/SoundChange.hs new file mode 100644 --- /dev/null +++ b/src/Brassica/SoundChange.hs @@ -0,0 +1,7 @@ +module Brassica.SoundChange (module X) where + +import Brassica.SoundChange.Apply as X +import Brassica.SoundChange.Category 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 new file mode 100644 --- /dev/null +++ b/src/Brassica/SoundChange/Apply.hs @@ -0,0 +1,15 @@ +module Brassica.SoundChange.Apply + ( + -- * Sound change application + applyRuleStr + , applyStatementStr + , applyChanges + -- * Logging + , applyChangesWithLogs + , applyChangesWithChanges + , PWordLog(..) + , reportAsText + , reportAsHtmlRows + ) where + +import Brassica.SoundChange.Apply.Internal diff --git a/src/Brassica/SoundChange/Apply/Internal.hs b/src/Brassica/SoundChange/Apply/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Brassica/SoundChange/Apply/Internal.hs @@ -0,0 +1,471 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +{-| __Warning:__ This module is __internal__, and does __not__ follow + the Package Versioning Policy. It may be useful for extending + Brassica, but be prepared to track development closely if you import + this module. +-} +module Brassica.SoundChange.Apply.Internal + ( -- * Types + RuleTag(..) + -- * Lexeme matching + , match + , matchMany + , mkReplacement + , exceptionAppliesAtPoint + , matchRuleAtPoint + -- * Sound change application + , applyOnce + , applyRule + , checkGraphemes + , applyStatement + , applyRuleStr + , applyStatementStr + , applyChanges + -- * Logging + , LogItem(..) + , PWordLog(..) + , toPWordLog + , reportAsHtmlRows + , reportAsText + , applyStatementWithLog + , applyChangesWithLog + , applyChangesWithLogs + , applyChangesWithChanges + ) where + +import Control.Applicative ((<|>)) +import Data.Containers.ListUtils (nubOrd) +import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.Maybe (maybeToList, fromMaybe, listToMaybe, mapMaybe) +import GHC.Generics (Generic) + +import Control.DeepSeq (NFData) +import Control.Monad.State + +import Brassica.SoundChange.Apply.Internal.MultiZipper +import Brassica.SoundChange.Types +import Data.Bifunctor (Bifunctor(first)) + +-- | Defines the tags used when applying a 'Rule'. +data RuleTag + = AppStart -- ^ The start of a rule application + | TargetStart -- ^ The start of the target + | TargetEnd -- ^ The end of the target + deriving (Eq, Ord, Show) + +-- | A monad in which to process a 'MultiZipper' over +-- 'Char's. Essentially a @StateT (MultiZipper RuleTag Grapheme) []@: +-- it stores the 'MultiZipper' as state, and allows failure, +-- 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) +#if __GLASGOW_HASKELL__ > 806 + , MonadFail +#endif + ) + via (StateT (MultiZipper RuleTag Grapheme) []) + +-- | Lift a partial modification function into a 'State'. Update state +-- if it succeeds, otherwise rollback. +modifyMay :: Monad m => (s -> Maybe s) -> StateT s m () +modifyMay f = modify $ \s -> fromMaybe s (f s) + +-- | Monadic version of 'modify'. +modifyM :: Monad m => (s -> m s) -> StateT s m () +modifyM f = StateT (fmap ((),) . f) + +-- | Given a nondeterministic stateful function, lift it into a +-- 'StateT' computation which returns 'Nothing' when the original +-- action would have failed with no results. +try :: (s -> [(a, s)]) -> StateT s [] (Maybe a) +try p = StateT $ \s -> + case p s of + [] -> [(Nothing, s)] + r -> first Just <$> r + +-- | Describes the output of a 'match' operation. +data MatchOutput = MatchOutput + { -- | For each category matched, the index of the matched + -- grapheme in that category. + matchedCatIxs :: [Int] + -- | For each optional group whether it matched or not + , matchedOptionals :: [Bool] + -- | The graphemes which were matched + , matchedGraphemes :: [Grapheme] + } deriving (Show) + +modifyMatchedGraphemes :: ([Grapheme] -> [Grapheme]) -> MatchOutput -> MatchOutput +modifyMatchedGraphemes f MatchOutput{..} = MatchOutput{matchedGraphemes=f matchedGraphemes, ..} + +prependGrapheme :: Grapheme -> MatchOutput -> MatchOutput +prependGrapheme g = modifyMatchedGraphemes (g:) + +instance Semigroup MatchOutput where + (MatchOutput a1 b1 c1) <> (MatchOutput a2 b2 c2) = MatchOutput (a1++a2) (b1++b2) (c1++c2) + +-- | Match a single 'Lexeme' against a 'MultiZipper', and advance the +-- 'MultiZipper' past the match. For each match found, returns the +-- 'MatchOutput' tupled with the updated 'MultiZipper'. +match :: OneOf a 'Target 'Env + => Maybe Grapheme -- ^ The previously-matched grapheme, if any. (Used to match a 'Geminate'.) + -> Lexeme a -- ^ The lexeme to match. + -> MultiZipper t Grapheme -- ^ The 'MultiZipper' to match against. + -> [(MatchOutput, MultiZipper t Grapheme)] + -- ^ The output: a tuple @((i, g), mz)@ as described below. +match prev (Optional l) mz = + (MatchOutput [] [False] [], mz) : + (first (MatchOutput [] [True] [] <>) <$> matchMany prev l mz ) +match prev w@(Wildcard l) mz = case match prev l mz of + [] -> maybeToList (consume mz) >>= \(g, mz') -> + first (prependGrapheme g) <$> match prev w mz' + r -> r +match prev k@(Kleene l) mz = case match prev l mz of + [] -> [(MatchOutput [] [] [], mz)] + r -> r >>= \(out, mz') -> case match prev k mz' of + [] -> error "match: Kleene should never fail" + r' -> first (out <>) <$> r' +match _ (Grapheme g) mz = (MatchOutput [] [] [g],) <$> maybeToList (matchGrapheme g mz) +match _ (Category gs) mz = + gs + -- Attempt to match each option in category... + & fmap (\case + BoundaryEl -> if atBoundary mz then Just ([], mz) else Nothing + GraphemeEl g -> ([g],) <$> matchGrapheme g mz) + -- ...get the index of each match... + & zipWith (\i m -> fmap (i,) m) [0..] + -- ...and take all matches + & (>>= maybeToList) + & fmap (\(i, (g, mz')) -> (MatchOutput [i] [] g, mz')) +match _ Boundary mz = if atBoundary mz then [(MatchOutput [] [] [], mz)] else [] +match prev Geminate mz = case prev of + Nothing -> [] + Just prev' -> (MatchOutput [] [] [prev'],) <$> maybeToList (matchGrapheme prev' mz) + +matchGrapheme :: Grapheme -> MultiZipper t Grapheme -> Maybe (MultiZipper t Grapheme) +matchGrapheme g = matchGraphemeP (==g) + +matchGraphemeP :: (Grapheme -> Bool) -> MultiZipper t Grapheme -> Maybe (MultiZipper t Grapheme) +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. +matchMany :: OneOf a 'Target 'Env + => Maybe Grapheme + -> [Lexeme a] + -> MultiZipper t Grapheme + -> [(MatchOutput, MultiZipper t Grapheme)] +matchMany = go (MatchOutput [] [] []) + where + go out _ [] mz = [(out, mz)] + go out prev (l:ls) mz = match prev l mz >>= \(out', mz') -> + go (out <> out') (lastMay (matchedGraphemes out') <|> prev) ls mz' + +-- Small utility function, not exported +lastMay :: [a] -> Maybe a +lastMay l = if null l then Nothing else Just (last l) + +-- | Given a list of 'Lexeme's specifying a replacement, generate all +-- possible replacements and apply them to the given input. +mkReplacement + :: MatchOutput -- ^ The result of matching against the target + -> [Lexeme 'Replacement] -- ^ The 'Lexeme's specifying the replacement. + -> MultiZipper t Grapheme + -> [MultiZipper t Grapheme] +mkReplacement = \out ls -> fmap (fst . snd) . go out ls . (,Nothing) + where + go out [] (mz, prev) = [(out, (mz, prev))] + go out (l:ls) (mz, prev) = do + (out', (mz', prev')) <- replaceLex out l mz prev + go out' ls (mz', prev') + + replaceLex + :: MatchOutput + -> Lexeme 'Replacement + -> MultiZipper t Grapheme + -> Maybe Grapheme + -> [(MatchOutput, (MultiZipper t Grapheme, Maybe Grapheme))] + replaceLex out (Grapheme g) mz _prev = [(out, (insert g mz, Just g))] + replaceLex out@MatchOutput{matchedCatIxs=(i:is)} (Category gs) mz _prev = + fmap (out{matchedCatIxs=is},) $ + if i < length gs + then case gs !! i of GraphemeEl g -> [(insert g mz, Just g)] + else [(insert "\xfffd" mz, Nothing)] -- Unicode replacement character + replaceLex out (Category gs) mz _prev = + gs <&> \(GraphemeEl g) -> (out, (insert g mz, Just g)) + replaceLex MatchOutput{matchedOptionals=(o:os), ..} (Optional ls) mz prev = + let out' = MatchOutput{matchedOptionals=os, ..} + in if o + then go out' ls (mz, prev) + else [(out', (mz, Nothing))] + replaceLex out (Optional ls) mz prev = (out, (mz, Nothing)) : go out ls (mz, prev) + replaceLex out@MatchOutput{matchedGraphemes} Metathesis mz _prev = + [(out, (flip insertMany mz $ reverse matchedGraphemes, listToMaybe matchedGraphemes))] + replaceLex out Geminate mz prev = + [(out, (flip insertMany mz $ maybeToList prev, prev))] + replaceLex out@MatchOutput{matchedCatIxs=(_:is)} Discard mz prev = [(out{matchedCatIxs=is}, (mz, prev))] + replaceLex out@MatchOutput{matchedCatIxs=[]} Discard mz prev = [(out, (mz, prev))] + +-- | Given a 'Rule' and a 'MultiZipper', determines whether the +-- 'exception' of that rule (if any) applies starting at the current +-- position of the 'MultiZipper'; if it does, returns the index of the +-- first element of each matching 'target'. +exceptionAppliesAtPoint :: [Lexeme 'Target] -> Environment -> MultiZipper RuleTag Grapheme -> [Int] +exceptionAppliesAtPoint target (ex1, ex2) mz = fmap fst $ flip runRuleAp mz $ do + _ <- RuleAp $ matchMany Nothing ex1 + pos <- gets curPos + MatchOutput{matchedGraphemes} <- RuleAp $ matchMany Nothing target + _ <- RuleAp $ matchMany (listToMaybe matchedGraphemes) ex2 + return pos + +-- | Given a 'Rule', determine if that rule matches. If so, for each +-- match, set the appropriate 'RuleTag's and return a tuple of @(is, +-- gs)@, where @gs@ is a list of matched t'Grapheme's, and @is@ is a +-- list of indices, one for each 'Category' lexeme matched. +matchRuleAtPoint + :: Rule + -> MultiZipper RuleTag Grapheme + -> [(MatchOutput, MultiZipper RuleTag Grapheme)] +matchRuleAtPoint Rule{environment = (env1, env2), ..} mz = flip runRuleAp mz $ do + _ <- RuleAp $ matchMany Nothing env1 + modify $ tag TargetStart + matchResult <- RuleAp $ matchMany Nothing target + modify $ tag TargetEnd + _ <- RuleAp $ matchMany (listToMaybe $ matchedGraphemes matchResult) env2 + return matchResult + +-- | Given a 'Rule', determine if the rule matches at the current +-- point; if so, apply the rule, adding appropriate tags. +applyOnce :: Rule -> StateT (MultiZipper RuleTag Grapheme) [] Bool +applyOnce r@Rule{target, replacement, exception} = do + modify $ tag AppStart + result <- try (matchRuleAtPoint r) + case result of + Just out -> do + exs <- case exception of + Nothing -> pure [] + Just ex -> gets $ join . toList . + extend' (exceptionAppliesAtPoint target ex) + gets (locationOf TargetStart) >>= \p -> + if maybe True (`elem` exs) p + then return False + else do + modifyMay $ modifyBetween (TargetStart, TargetEnd) $ const [] + modifyMay $ seek TargetStart + modifyM $ mkReplacement out replacement + return True + Nothing -> return False + +-- | Remove tags and advance the current index to the next t'Grapheme' +-- after the rule application. +setupForNextApplication :: Bool -> Rule -> MultiZipper RuleTag Grapheme -> Maybe (MultiZipper RuleTag Grapheme) +setupForNextApplication success r@Rule{flags=Flags{applyDirection}} = fmap untag . + case applyDirection of + RTL -> seek AppStart >=> bwd + LTR -> + if success + then + if null (target r) + then -- need to move forward if applying an epenthesis rule to avoid an infinite loop + seek TargetEnd >=> fwd + else seek TargetEnd + else seek AppStart >=> fwd + +-- | 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 -> 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 + in if sporadic $ flags r + then mz : result + else result + where + repeatRule + :: StateT (MultiZipper RuleTag Grapheme) [] Bool + -> MultiZipper RuleTag Grapheme + -> [MultiZipper RuleTag Grapheme] + repeatRule m mz = runStateT m mz >>= \(success, mz') -> + if success && applyOnceOnly (flags r) + then [mz'] + else case setupForNextApplication success r mz' of + Just mz'' -> repeatRule m mz'' + Nothing -> [mz'] + +-- | Check that the 'MultiZipper' contains only graphemes listed in +-- the given 'CategoriesDecl', replacing all unlisted graphemes with +-- U+FFFD. +checkGraphemes :: CategoriesDecl -> MultiZipper RuleTag Grapheme -> MultiZipper RuleTag Grapheme +checkGraphemes (CategoriesDecl gs) = fmap $ \g -> if g `elem` gs then g else "\xfffd" + +-- | Apply a 'Statement' to a 'MultiZipper'. This is a simple wrapper +-- around 'applyRule' and 'checkGraphemes'. +applyStatement :: Statement -> MultiZipper RuleTag Grapheme -> [MultiZipper RuleTag Grapheme] +applyStatement (RuleS r) mz = applyRule r mz +applyStatement (CategoriesDeclS gs) mz = [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. +applyRuleStr :: Rule -> PWord -> [PWord] +-- Note: 'fromJust' is safe here as 'apply' should always succeed +applyRuleStr r s = nubOrd $ fmap toList $ applyRule r $ fromListStart s + +-- | 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 -> PWord -> [PWord] +applyStatementStr st s = nubOrd $ fmap toList $ applyStatement st $ fromListStart s + +-- | 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 :: PWord + } 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 :: [(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) + +toPWordLog :: [LogItem r] -> Maybe (PWordLog r) +toPWordLog [] = Nothing +toPWordLog ls@(l : _) = Just $ PWordLog + { initialWord = input l + , derivations = (\ActionApplied{..} -> (output, action)) <$> ls + } + +-- | Render a single 'PWordLog' to 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 / / _ #)" +-- +-- Which might be displayed in an HTML table as something like the +-- following: +-- +-- +------+---+-------+-------------+ +-- | tara | → | tazha | (r / zh) | +-- +------+---+-------+-------------+ +-- | | → | tazh | (V / / _ #) | +-- +------+---+-------+-------------+ + +reportAsHtmlRows :: (r -> String) -> PWordLog r -> String +reportAsHtmlRows render item = go (concat $ initialWord item) (derivations item) + where + go _ [] = "" + go cell1 ((output, action) : ds) = + ("" ++ cell1 ++ "→" + ++ concat output + ++ "(" ++ render action ++ ")") + ++ go "" ds + +-- | Render a single 'PWordLog' to plain text. For instance, this log: +-- +-- > PWordLog +-- > { initialWord = ["t", "a", "r", "a"] +-- > , derivations = +-- > [ (["t", "a", "zh", "a"], "r / zh") +-- > , (["t", "a", "zh"], "V / / _ #") +-- > ] +-- > } +-- +-- Would render as: +-- +-- > tara +-- > -> tazha (r / zh) +-- > -> tazh (V / / _ #) +reportAsText :: (r -> String) -> PWordLog r -> String +reportAsText render item = unlines $ + concat (initialWord item) : fmap toLine (alignWithPadding $ derivations item) + where + alignWithPadding ds = + let (fmap concat -> outputs, actions) = unzip ds + maxlen = maximum $ length <$> outputs + padded = outputs <&> \o -> o ++ replicate (maxlen - length o) ' ' + in zip padded actions + + toLine (output, action) = " -> " ++ output ++ " (" ++ render action ++ ")" + +-- | 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 -> PWord -> [LogItem Statement] +applyStatementWithLog st w = case applyStatementStr st w of + [w'] -> if w' == w then [] else [ActionApplied st w w'] + r -> ActionApplied st w <$> r + +-- | Apply 'SoundChanges' to a word. For each possible result, returns +-- a 'LogItem' for each 'Statement' which altered the input. +applyChangesWithLog :: SoundChanges -> PWord -> [[LogItem Statement]] +applyChangesWithLog [] _ = [[]] +applyChangesWithLog (st:sts) w = + case applyStatementWithLog st w of + [] -> applyChangesWithLog sts w + items -> items >>= \l@ActionApplied{output=w'} -> + (l :) <$> applyChangesWithLog sts w' + +-- | Apply 'SoundChanges' to a word, returning an 'PWordLog' +-- for each possible result. +applyChangesWithLogs :: SoundChanges -> PWord -> [PWordLog Statement] +applyChangesWithLogs scs w = mapMaybe toPWordLog $ applyChangesWithLog scs w + +-- | Apply a set of 'SoundChanges' to a word. +applyChanges :: SoundChanges -> PWord -> [PWord] +applyChanges sts w = + lastOutput <$> applyChangesWithLog sts w + where + lastOutput [] = w + lastOutput ls = output $ last ls + +-- | Apply 'SoundChanges' to a word returning the final results, as +-- well as a boolean value indicating whether the word should be +-- highlighted in a UI due to changes from its initial value. (Note +-- that this accounts for 'highlightChanges' values.) +applyChangesWithChanges :: SoundChanges -> PWord -> [(PWord, Bool)] +applyChangesWithChanges sts w = applyChangesWithLog sts w <&> \case + [] -> (w, False) + logs -> (output $ last logs, hasChanged logs) + where + hasChanged = any $ \case + ActionApplied{action=RuleS rule} -> highlightChanges $ flags rule + ActionApplied{action=CategoriesDeclS _} -> True diff --git a/src/Brassica/SoundChange/Apply/Internal/MultiZipper.hs b/src/Brassica/SoundChange/Apply/Internal/MultiZipper.hs new file mode 100644 --- /dev/null +++ b/src/Brassica/SoundChange/Apply/Internal/MultiZipper.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE DeriveTraversable #-} + +{-| __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 + , fromListStart + , fromListPos + , toList + -- * Querying + , curPos + , atStart + , atEnd + , atBoundary + , value + , valueN + , locationOf + , yank + -- * Movement + , move + , fwd + , bwd + , consume + , seek + , toBeginning + , toEnd + -- * Modification + , insert + , insertMany + , zap + , tag + , tagAt + , query + , untag + , untagWhen + , modifyBetween + , extend + , extend' + ) where + +import Control.Applicative (Alternative((<|>))) +import Data.Foldable (Foldable(foldl')) +import qualified Data.Map.Strict as M + +-- | A 'MultiZipper' is a list zipper (list+current index), with the +-- addition of ‘tags’ which can be assigned to indices in the +-- list. Any tag may be assigned to any index, with the restriction +-- that two different indices may not be tagged with the same +-- tag. This sort of data structure is useful for certain algorithms, +-- where it can be convenient to use tags to save positions in the +-- list and then return back to them later. +-- +-- (One subtlety: unlike most list zipper implementations, a +-- 'MultiZipper' positioned at the ‘end’ of a list is actually at +-- 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'.) +data MultiZipper t a = MultiZipper [a] Int (M.Map t Int) + deriving (Show, Functor, Foldable, Traversable) + +-- | Convert a list to a 'MultiZipper' positioned at the start of that +-- list. +fromListStart :: [a] -> MultiZipper t a +fromListStart as = MultiZipper as 0 M.empty + +-- | Convert a list to a 'MultiZipper' at a specific position in the +-- list. Returns 'Nothing' if the index is invalid. +fromListPos :: [a] -> Int -> Maybe (MultiZipper t a) +fromListPos as pos = + if invalid pos as + then Nothing + else Just $ MultiZipper as pos M.empty + +-- | Get the list stored in a 'MultiZipper'. +toList :: MultiZipper t a -> [a] +toList (MultiZipper as _ _) = as + +-- | The current position of the 'MultiZipper'. +curPos :: MultiZipper t a -> Int +curPos (MultiZipper _ pos _) = pos + +-- | Determine whether the 'MultiZipper' is positioned at the start of +-- its list. +atStart :: MultiZipper t a -> Bool +atStart (MultiZipper _ pos _) = pos <= 0 + +-- | Determine whether the 'MultiZipper' is positioned at the end of +-- its list. +atEnd :: MultiZipper t a -> Bool +atEnd (MultiZipper as pos _) = pos >= length as + +-- | Determine whether the 'MultiZipper' is positioned at the start or +-- end of its list. +atBoundary :: MultiZipper t a -> Bool +atBoundary = (||) <$> atStart <*> atEnd + +-- | The element at the current position of the 'MultiZipper'. Returns +-- 'Nothing' if the 'MultiZipper' is positioned ‘at the end of the +-- list’ (recall this actually means that the 'MultiZipper' is +-- positioned /after/ the last element of its list). +value :: MultiZipper t a -> Maybe a +value (MultiZipper as pos _) = + if atNonvalue pos as + then Nothing + else Just $ as !! pos + +-- | @valueN n mz@ returns the next @n@ elements of @mz@ starting from +-- the current position, as well as returning a new 'MultiZipper' +-- positioned past the end of those @n@ elements. (So running +-- @valueN m@ and then @valueN n@ would return the next @m+n@ +-- elements.) Returns 'Nothing' if this would move the position of the +-- 'MultiZipper' past the end of the list. +valueN :: Int -> MultiZipper t a -> Maybe ([a], MultiZipper t a) +valueN i (MultiZipper as pos ts) = + let pos' = pos + i in + if invalid pos' as || i < 0 + then Nothing + else Just (take i $ drop pos as, MultiZipper as pos' ts) + +-- | Given a tag, return its position +locationOf :: Ord t => t -> MultiZipper t a -> Maybe Int +locationOf t (MultiZipper _ _ ts) = M.lookup t ts + +-- | Get all tags at the current position +query :: Ord t => MultiZipper t a -> [t] +query (MultiZipper _ pos ts) = M.keys $ M.filter (==pos) ts + +seekIx :: Int -> MultiZipper t a -> Maybe (MultiZipper t a) +seekIx i (MultiZipper as _ ts) = + if invalid i as + then Nothing + else Just (MultiZipper as i ts) + +-- | @move n mz@ will move the position of @mz@ by @n@ forward (if +-- n>0) or by @-n@ backward (if n<0). Returns 'Nothing' if this would +-- cause the 'MultiZipper' to move after the end or before the +-- beginning of the list. +move :: Int -> MultiZipper t a -> Maybe (MultiZipper t a) +move s mz@(MultiZipper _ pos _) = seekIx (pos + s) mz + +-- | Move one position forward if possible, otherwise return 'Nothing'. +fwd :: MultiZipper t a -> Maybe (MultiZipper t a) +fwd = move 1 + +-- | Move one position backwards if possible, otherwise return 'Nothing'. +bwd :: MultiZipper t a -> Maybe (MultiZipper t a) +bwd = move (-1) + +-- | If possible, move one position forward, returning the value moved +-- over +consume :: MultiZipper t a -> Maybe (a, MultiZipper t a) +consume (MultiZipper as pos ts) = + if invalid (pos+1) as + then Nothing + else Just (as!!pos, MultiZipper as (pos+1) ts) + +-- | Move the 'MultiZipper' to be at the specified tag. Returns +-- 'Nothing' if that tag is not present. +seek :: Ord t => t -> MultiZipper t a -> Maybe (MultiZipper t a) +seek t (MultiZipper as _ ts) = case M.lookup t ts of + Nothing -> Nothing + Just pos -> Just $ MultiZipper as pos ts + +-- | Move to the beginning of the 'MultiZipper'. +toBeginning :: MultiZipper t a -> MultiZipper t a +toBeginning (MultiZipper as _ ts) = MultiZipper as 0 ts + +-- | Move to the end of the 'MultiZipper'. +toEnd :: MultiZipper t a -> MultiZipper t a +toEnd (MultiZipper as _ ts) = MultiZipper as (length as) ts + +-- | Find first element before point which returns 'Just' when +-- queried, if any, returning the result of the query function. +yank :: (a -> Maybe b) -> MultiZipper t a -> Maybe b +yank p mz = bwd mz >>= \mz' -> (value mz' >>= p) <|> yank p mz' + +-- | Insert a new element at point and move forward by one position. +insert :: a -> MultiZipper t a -> MultiZipper t a +insert a (MultiZipper as pos ts) = + case splitAt pos as of + (as1, as2) -> MultiZipper (as1 ++ [a] ++ as2) (pos+1) $ correctIxsFrom pos (+1) ts + +-- | Insert multiple elements at point and move after them. A simple +-- wrapper around 'insert'. +insertMany :: [a] -> MultiZipper t a -> MultiZipper t a +insertMany = flip $ foldl' $ flip insert + +-- | Modify the first element before point to which the modification +-- function returns 'Just'. +zap :: (a -> Maybe a) -> MultiZipper t a -> MultiZipper t a +zap p = \mz@(MultiZipper as pos ts) -> case go as (pos-1) of + Nothing -> mz + Just as' -> MultiZipper as' pos ts + where + go _ (-1) = Nothing + go as pos + | pos == length as = go as (pos-1) + | otherwise = case p (as !! pos) of + Nothing -> go as (pos-1) + Just a' -> case splitAt pos as of + (as1, _:as2) -> Just $ as1 ++ (a':as2) + _ -> error "error in zap: impossible case reached" + +-- | Set a tag at the current position. +tag :: Ord t => t -> MultiZipper t a -> MultiZipper t a +tag t (MultiZipper as pos ts) = MultiZipper as pos $ M.insert t pos ts + +-- | Set a tag at a given position if possible, otherwise return 'Nothing'. +tagAt :: Ord t => t -> Int -> MultiZipper t a -> Maybe (MultiZipper t a) +tagAt t i (MultiZipper as pos ts) = + if invalid i as + then Nothing + else Just $ MultiZipper as pos $ M.insert t i ts + +-- | Remove tags satisfying predicate +untagWhen :: (t -> Bool) -> MultiZipper t a -> MultiZipper t a +untagWhen p (MultiZipper as pos ts) = MultiZipper as pos $ snd $ M.partitionWithKey (flip $ const p) ts + +-- | Remove all tags. +untag :: MultiZipper t a -> MultiZipper t a +untag (MultiZipper as pos _) = MultiZipper as pos M.empty + +-- | Modify a 'MultiZipper' between the selected tags. Returns +-- 'Nothing' if a nonexistent tag is selected, else returns the +-- modified 'MultiZipper'. +modifyBetween :: Ord t + => (t, t) + -- ^ Selected tags. Note that the resulting interval + -- will be [inclusive, exclusive). + -> ([a] -> [a]) + -- ^ Function to modify designated interval. + -> MultiZipper t a + -> Maybe (MultiZipper t a) +modifyBetween (t1, t2) f mz@(MultiZipper as pos ts) = do + (i1, i2) <- fmap correctOrder $ (,) <$> locationOf t1 mz <*> locationOf t2 mz + let (before_t1, after_t1) = splitAt i1 as + (cut_part, after_t2) = splitAt (i2-i1) after_t1 + replacement = f cut_part + dEnd = length replacement - length cut_part + pos' = pos + dEnd + return $ MultiZipper (before_t1 ++ replacement ++ after_t2) pos' (correctIxsFrom i2 (+dEnd) ts) + where + correctOrder (m, n) = if m <= n then (m, n) else (n, m) + +-- | Given a function to compute a value from a 'MultiZipper' starting +-- at a particular point, apply that function to all possible starting +-- points and collect the results. Tags are left unchanged. +-- +-- (Note: this is really just the same @extend@ method as in the +-- @Comonad@ typeclass, although 'MultiZipper' wouldn’t be a lawful +-- comonad.) +extend :: (MultiZipper t a -> b) -> MultiZipper t a -> MultiZipper t b +extend f (MultiZipper as pos ts) = MultiZipper as' pos ts + where + as' = fmap (\i -> f $ MultiZipper as i ts) [0 .. length as - 1] + +-- | Like 'extend', but includes the end position of the zipper, thus +-- increasing the 'MultiZipper' length by one when called. +extend' :: (MultiZipper t a -> b) -> MultiZipper t a -> MultiZipper t b +extend' f (MultiZipper as pos ts) = MultiZipper as' pos ts + where + as' = fmap (\i -> f $ MultiZipper as i ts) [0 .. length as] + +-- Utility functions for checking and modifying indices in lists: +invalid :: Int -> [a] -> Bool +invalid pos as = (pos < 0) || (pos > length as) + +atNonvalue :: Int -> [a] -> Bool +atNonvalue pos as = (pos < 0) || (pos >= length as) + +correctIxsFrom :: Int -> (Int -> Int) -> M.Map t Int -> M.Map t Int +correctIxsFrom i f = M.map $ \pos -> if pos >= i then f pos else pos diff --git a/src/Brassica/SoundChange/Category.hs b/src/Brassica/SoundChange/Category.hs new file mode 100644 --- /dev/null +++ b/src/Brassica/SoundChange/Category.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE KindSignatures #-} + +module Brassica.SoundChange.Category + ( + -- * Category construction + Category(..) + , CategoryState(..) + , categorise + -- * Category expansion + , Categories + , Brassica.SoundChange.Category.lookup + , mapCategories + , expand + -- * Obtaining values + , bake + , values + ) where + +import Data.Coerce +import Data.List (intersect) +import Data.Maybe (fromMaybe) + +import qualified Data.Map.Strict as M +import Data.Containers.ListUtils (nubOrd) + +-- | Type-level tag for 'Category'. When parsing a category definition +-- from a string, usually categories will refer to other +-- categories. This is the 'Unexpanded' state. Once 'Expanded', these +-- references will have been inlined, and the category no longer +-- depends on other categories. +data CategoryState = Unexpanded | Expanded + +-- | A set of values (usually representing phonemes) which behave the +-- same way in a sound change. A 'Category' is constructed using the +-- set operations supplied as constructors, possibly referencing other +-- 'Category's; these references can then be 'expand'ed, allowing the +-- 'Category' to be 'bake'd to a list of matching values. +-- +-- Note that Brassica makes no distinction between ad-hoc categories +-- and predefined categories beyond the sound change parser; the +-- latter is merely syntax sugar for the former, and both are +-- represented using the same 'Category' type. In practise this is not +-- usually a problem, since 'Category's are still quite convenient to +-- construct manually. +data Category (s :: CategoryState) a + = Empty + -- ^ The empty category (@[]@ in Brassica syntax) + | Node a + -- ^ A single value (@[a]@) + | UnionOf [Category s a] + -- ^ The union of multiple categories (@[Ca Cb Cc]@) + | Intersect (Category s a) (Category s a) + -- ^ The intersection of two categories (@[Ca +Cb]@) + | Subtract (Category s a) (Category s a) + -- ^ The second category subtracted from the first (@[Ca -Cb]@) + deriving (Show, Eq, Ord, Functor) + +-- | A map from names to the (expanded) categories they +-- reference. Used to resolve cross-references between categories. +type Categories a = M.Map a (Category 'Expanded a) + +-- | @Data.Map.Strict.'Data.Map.Strict.lookup'@, specialised to 'Categories'. +lookup :: Ord a => a -> Categories a -> Maybe (Category 'Expanded a) +lookup = M.lookup + +-- | Map a function over all the values in a set of 'Categories'. +mapCategories :: Ord b => (a -> b) -> Categories a -> Categories b +mapCategories f = M.map (fmap f) . M.mapKeys f + +-- | Given a list of values, return a 'Category' which matches only +-- those values. (This is a simple wrapper around 'Node' and +-- 'UnionOf'.) +categorise :: Ord a => [a] -> Category 'Expanded a +categorise = UnionOf . fmap Node + +-- | Expand an 'Unexpanded' category by inlining its references. The +-- references should only be to categories in the given 'Categories'. +expand :: Ord a => Categories a -> Category 'Unexpanded a -> Category 'Expanded a +expand _ Empty = Empty +expand cs n@(Node a) = fromMaybe (coerce n) $ M.lookup a cs +expand cs (UnionOf u) = UnionOf $ expand cs <$> u +expand cs (Intersect a b) = Intersect (expand cs a) (expand cs b) +expand cs (Subtract a b) = Subtract (expand cs a) (expand cs b) + +-- | Given an 'Expanded' category, return the list of values which it +-- matches. +bake :: Eq a => Category 'Expanded a -> [a] +bake Empty = [] +bake (Node a) = [a] +bake (UnionOf u) = concatMap bake u +bake (Intersect a b) = bake a `intersect` bake b +bake (Subtract a b) = bake a `difference` bake b + where + difference l m = filter (not . (`elem` m)) l + +-- | Returns a list of every value mentioned in a set of +-- 'Categories'. This includes all values, even those which are +-- 'Intersect'ed or 'Subtract'ed out: e.g. given 'Categories' +-- including @[a b -a]@, this will return a list including +-- @["a","b"]@, not just @["b"]@. +values :: Ord a => Categories a -> [a] +values = nubOrd . concatMap go . M.elems + where + go Empty = [] + go (Node a) = [a] + go (UnionOf u) = concatMap go u + go (Intersect a b) = go a ++ go b + go (Subtract a b) = go a ++ go b diff --git a/src/Brassica/SoundChange/Frontend/Internal.hs b/src/Brassica/SoundChange/Frontend/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Brassica/SoundChange/Frontend/Internal.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# 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 where + +import Data.Bifunctor (second) +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Void (Void) +import GHC.Generics (Generic) + +import Control.DeepSeq (NFData) +import Text.Megaparsec (ParseErrorBundle) + +import Brassica.MDF (MDF, parseMDFWithTokenisation, componentiseMDF, componentiseMDFWordsOnly, duplicateEtymologies) +import Brassica.SoundChange.Apply +import Brassica.SoundChange.Apply.Internal (applyChangesWithLog, toPWordLog) +import Brassica.SoundChange.Tokenise +import Brassica.SoundChange.Types + +-- | Rule application mode of the SCA. +data ApplicationMode + = ApplyRules HighlightMode MDFOutputMode + | ReportRulesApplied + deriving (Show, Eq) + +data HighlightMode + = NoHighlight + | DifferentToLastRun + | DifferentToInput + deriving (Show, Eq) +instance Enum HighlightMode where + -- used for conversion to and from C, so want control over values + fromEnum NoHighlight = 0 + fromEnum DifferentToLastRun = 1 + fromEnum DifferentToInput = 2 + + toEnum 0 = NoHighlight + toEnum 1 = DifferentToLastRun + toEnum 2 = DifferentToInput + toEnum _ = undefined + +data MDFOutputMode = MDFOutput | WordsOnlyOutput + deriving (Show, Eq) +instance Enum MDFOutputMode where + -- used for conversion to and from C, so want control over values + fromEnum MDFOutput = 0 + fromEnum WordsOnlyOutput = 1 + + toEnum 0 = MDFOutput + toEnum 1 = WordsOnlyOutput + toEnum _ = undefined + +data TokenisationMode = Normal | AddEtymons + deriving (Show, Eq) +instance Enum TokenisationMode where + -- used for conversion to and from C, so want control over values + fromEnum Normal = 0 + fromEnum AddEtymons = 1 + + toEnum 0 = Normal + toEnum 1 = AddEtymons + toEnum _ = undefined + +-- | Output of a single application of rules to a wordlist: either a +-- list of possibly highlighted words, an applied rules table, or a +-- parse error. +data ApplicationOutput a r + = HighlightedWords [Component (a, Bool)] + | AppliedRulesTable [PWordLog r] + | ParseError (ParseErrorBundle String Void) + deriving (Show, Generic, NFData) + +-- | Kind of input: either a raw wordlist, or an MDF file. +data InputLexiconFormat = Raw | MDF + 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 + + toEnum 0 = Raw + toEnum 1 = MDF + toEnum _ = undefined + +data ParseOutput a = ParsedRaw [Component a] | ParsedMDF (MDF [Component a]) + deriving (Show, Functor) + +componentise :: MDFOutputMode -> ParseOutput a -> [Component a] +componentise _ (ParsedRaw cs) = cs +componentise MDFOutput (ParsedMDF mdf) = componentiseMDF mdf +componentise WordsOnlyOutput (ParsedMDF mdf) = componentiseMDFWordsOnly mdf + +tokeniseAccordingToInputFormat + :: InputLexiconFormat + -> TokenisationMode + -> SoundChanges + -> String + -> Either (ParseErrorBundle String Void) (ParseOutput PWord) +tokeniseAccordingToInputFormat Raw _ cs = + fmap ParsedRaw . withFirstCategoriesDecl tokeniseWords cs +tokeniseAccordingToInputFormat MDF Normal cs = + fmap ParsedMDF . withFirstCategoriesDecl parseMDFWithTokenisation cs +tokeniseAccordingToInputFormat MDF AddEtymons cs = + fmap ParsedMDF + . second (duplicateEtymologies $ ('*':) . detokeniseWords) + . withFirstCategoriesDecl parseMDFWithTokenisation cs + +-- | Top-level dispatcher for an interactive frontend: given a textual +-- wordlist and a list of sound changes, returns the result of running +-- the changes in the specified mode. +parseTokeniseAndApplyRules + :: SoundChanges -- ^ changes + -> String -- ^ words + -> InputLexiconFormat + -> TokenisationMode + -> ApplicationMode + -> Maybe [Component PWord] -- ^ previous results + -> ApplicationOutput PWord Statement +parseTokeniseAndApplyRules statements ws intype tmode mode prev = + case tokeniseAccordingToInputFormat intype tmode statements ws of + Left e -> ParseError e + Right toks -> case mode of + ReportRulesApplied -> + AppliedRulesTable $ mapMaybe toPWordLog $ concat $ + getWords $ componentise WordsOnlyOutput $ + applyChangesWithLog statements <$> toks + ApplyRules DifferentToLastRun mdfout -> + let result = concatMap (splitMultipleResults " ") $ + componentise mdfout $ applyChanges statements <$> toks + in HighlightedWords $ + zipWithComponents result (fromMaybe [] prev) [] $ \thisWord prevWord -> + (thisWord, thisWord /= prevWord) + ApplyRules DifferentToInput mdfout -> + HighlightedWords $ concatMap (splitMultipleResults " ") $ + componentise mdfout $ applyChangesWithChanges statements <$> toks + ApplyRules NoHighlight mdfout -> + HighlightedWords $ (fmap.fmap) (,False) $ concatMap (splitMultipleResults " ") $ + componentise mdfout $ applyChanges statements <$> toks + where + -- Zips two tokenised input strings. Compared to normal 'zipWith' + -- this has two special properties: + -- + -- * It only zips v'Word's. Any non-v'Word's in the first argument + -- will be passed unaltered to the output; any in the second + -- argument will be ignored. + -- + -- * The returned list will have the same number of elements as does + -- the first argument. If a v'Word' in the first argument has no + -- corresponding v'Word' in the second, the zipping function is + -- called using the default @b@ value given as the third argument. + -- Such a v'Word' in the second argument will simply be ignored. + -- + -- Note the persistent assymetry in the definition: each 'Component' + -- in the first argument will be reflected in the output, but each in + -- the second argument may be ignored. + zipWithComponents :: [Component a] -> [Component b] -> b -> (a -> b -> c) -> [Component c] + zipWithComponents [] _ _ _ = [] + zipWithComponents as [] bd f = (fmap.fmap) (`f` bd) as + zipWithComponents (Word a:as) (Word b:bs) bd f = Word (f a b) : zipWithComponents as bs bd f + zipWithComponents as@(Word _:_) (_:bs) bd f = zipWithComponents as bs bd f + zipWithComponents (a:as) bs@(Word _:_) bd f = unsafeCastComponent a : zipWithComponents as bs bd f + zipWithComponents (a:as) (_:bs) bd f = unsafeCastComponent a : zipWithComponents as bs bd f + + unsafeCastComponent :: Component a -> Component b + unsafeCastComponent (Word _) = error "unsafeCastComponent: attempted to cast a word!" + unsafeCastComponent (Separator s) = Separator s + unsafeCastComponent (Gloss s) = Gloss s diff --git a/src/Brassica/SoundChange/Parse.hs b/src/Brassica/SoundChange/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Brassica/SoundChange/Parse.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} + +module Brassica.SoundChange.Parse + ( parseRule + , parseRuleWithCategories + , parseSoundChanges + -- ** Re-export + , errorBundlePretty + ) where + +import Data.Char (isSpace) +import Data.Foldable (asum) +import Data.List (transpose) +import Data.Maybe (isNothing, isJust, fromJust) +import Data.Void (Void) + +import Control.Applicative.Permutations +import Control.Monad.State +import qualified Data.Map.Strict as M + +import Text.Megaparsec hiding (State) +import Text.Megaparsec.Char +import qualified Text.Megaparsec.Char.Lexer as L + +import Brassica.SoundChange.Types +import qualified Brassica.SoundChange.Category as C + +newtype Config = Config + { categories :: C.Categories Grapheme + } +type Parser = ParsecT Void String (State Config) + +class ParseLexeme (a :: LexemeType) where + parseLexeme :: Parser (Lexeme a) + parseCategoryElement :: Parser (CategoryElement a) + +-- space consumer which does not match newlines +sc :: Parser () +sc = L.space space1' (L.skipLineComment ";") 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 +scn :: Parser () +scn = L.space space1 (L.skipLineComment ";") empty + +lexeme :: Parser a -> Parser a +lexeme = L.lexeme sc + +symbol :: String -> Parser String +symbol = L.symbol sc + +keyChars :: [Char] +keyChars = "#[](){}>\\→/_^%~*" + +parseGrapheme :: Parser (Grapheme, Bool) +parseGrapheme = lexeme $ (,) <$> takeWhile1P Nothing (not . ((||) <$> isSpace <*> (`elem` keyChars))) <*> (isJust <$> optional (char '~')) + +parseGrapheme' :: Parser Grapheme +parseGrapheme' = lexeme $ takeWhile1P Nothing (not . ((||) <$> isSpace <*> (=='='))) + +data CategoryModification a + = Union (CategoryElement a) + | Intersect (CategoryElement a) + | Subtract (CategoryElement a) + +parseGraphemeOrCategory :: ParseLexeme a => Parser (Lexeme a) +parseGraphemeOrCategory = do + (g, isntCat) <- parseGrapheme + if isntCat + then return $ Grapheme g + else do + cats <- gets categories + return $ case C.lookup g cats of + Nothing -> Grapheme g + Just c -> Category $ C.bake $ GraphemeEl <$> c + +parseCategory :: ParseLexeme a => Parser (Lexeme a) +parseCategory = do + mods <- symbol "[" *> someTill parseCategoryModification (symbol "]") + cats <- gets categories + return $ Category $ C.bake $ + C.expand (C.mapCategories GraphemeEl cats) (toCategory mods) + +parseCategoryStandalone :: Parser (Grapheme, C.Category 'C.Expanded Grapheme) +parseCategoryStandalone = do + g <- parseGrapheme' + _ <- symbol "=" + -- Use Target here because it only allows graphemes, not boundaries + mods <- some (parseCategoryModification @'Target) + cats <- gets categories + return (g, C.expand cats $ toGrapheme <$> toCategory mods) + +toGrapheme :: CategoryElement 'Target -> Grapheme +toGrapheme (GraphemeEl g) = g + +categoriesDeclParse :: Parser CategoriesDecl +categoriesDeclParse = do + overwrite <- isJust <$> optional (symbol "new") + when overwrite $ put $ Config M.empty + _ <- symbol "categories" <* scn + -- parse category declarations, adding to the set of known + -- categories as each is parsed + _ <- some $ parseFeature <|> parseCategoryDecl + _ <- symbol "end" <* scn + Config catsNew <- get + return $ CategoriesDecl (C.values catsNew) + where + parseFeature = do + _ <- symbol "feature" + namePlain <- optional $ try $ parseGrapheme' <* symbol "=" + modsPlain <- some (parseCategoryModification @'Target) + cats <- gets categories + let plainCat = C.expand cats $ toGrapheme <$> toCategory modsPlain + plain = C.bake plainCat + modifiedCats <- some (symbol "/" *> parseCategoryStandalone) <* scn + let modified = C.bake . snd <$> modifiedCats + syns = zipWith (\a b -> (a, C.UnionOf [C.Node a, C.categorise b])) plain $ transpose modified + modify $ \(Config cs) -> Config $ M.unions + [ M.fromList syns + , M.fromList modifiedCats + , case namePlain of + Nothing -> M.empty + Just n -> M.singleton n plainCat + , cs + ] + parseCategoryDecl = do + (k, c) <- try parseCategoryStandalone <* scn + modify $ \(Config cs) -> Config (M.insert k c cs) + +parseCategoryModification :: ParseLexeme a => Parser (CategoryModification a) +parseCategoryModification = parsePrefix <*> parseCategoryElement + where + parsePrefix = + (Intersect <$ char '+') + <|> (Subtract <$ char '-') + <|> pure Union + +toCategory :: [CategoryModification a] -> C.Category 'C.Unexpanded (CategoryElement a) +toCategory = go C.Empty + where + go c [] = c + go c (Union e :es) = go (C.UnionOf [c, C.Node e]) es + go c (Intersect e:es) = go (C.Intersect c (C.Node e)) es + go c (Subtract e :es) = go (C.Subtract c (C.Node e)) es + +parseOptional :: ParseLexeme a => Parser (Lexeme a) +parseOptional = Optional <$> between (symbol "(") (symbol ")") (some parseLexeme) + +parseGeminate :: Parser (Lexeme a) +parseGeminate = Geminate <$ symbol ">" + +parseMetathesis :: Parser (Lexeme 'Replacement) +parseMetathesis = Metathesis <$ symbol "\\" + +parseWildcard :: (ParseLexeme a, OneOf a 'Target 'Env) => Parser (Lexeme a) +parseWildcard = Wildcard <$> (symbol "^" *> parseLexeme) + +parseBoundary :: Parser () +parseBoundary = () <$ symbol "#" + +parseDiscard :: Parser (Lexeme 'Replacement) +parseDiscard = Discard <$ symbol "~" + +parseKleene :: OneOf a 'Target 'Env => Lexeme a -> Parser (Lexeme a) +parseKleene l = (Kleene l <$ symbol "*") <|> pure l + +instance ParseLexeme 'Target where + parseLexeme = asum + [ parseCategory + , parseOptional + , parseGeminate + , parseWildcard + , parseGraphemeOrCategory + ] >>= parseKleene + parseCategoryElement = GraphemeEl . fst <$> parseGrapheme + +instance ParseLexeme 'Replacement where + parseLexeme = asum + [ parseCategory + , parseOptional + , parseMetathesis + , parseDiscard + , parseGeminate + , parseGraphemeOrCategory + ] + parseCategoryElement = GraphemeEl . fst <$> parseGrapheme + +instance ParseLexeme 'Env where + parseLexeme = asum + [ parseCategory + , Boundary <$ parseBoundary + , parseOptional + , parseGeminate + , parseWildcard + , parseGraphemeOrCategory + ] >>= parseKleene + parseCategoryElement = asum + [ BoundaryEl <$ parseBoundary + , GraphemeEl . fst <$> parseGrapheme + ] + +parseLexemes :: ParseLexeme a => Parser [Lexeme a] +parseLexemes = many parseLexeme + +parseFlags :: Parser Flags +parseFlags = runPermutation $ Flags + <$> toPermutation (isNothing <$> optional (symbol "-x")) + <*> toPermutationWithDefault LTR ((LTR <$ symbol "-ltr") <|> (RTL <$ symbol "-rtl")) + <*> toPermutation (isJust <$> optional (symbol "-1")) + <*> toPermutation (isJust <$> optional (symbol "-?")) + +ruleParser :: Parser Rule +ruleParser = do + -- This is an inlined version of 'match' from @megaparsec@; + -- 'match' itself would be tricky to use here, since it would need + -- to wrap multiple parsers rather than just one + o <- getOffset + s <- getInput + + flags <- parseFlags + target <- parseLexemes + _ <- lexeme $ oneOf "/→" + replacement <- parseLexemes + + let parseEnvironment = do + _ <- symbol "/" + env1 <- parseLexemes + _ <- symbol "_" + env2 <- parseLexemes + exception <- optional $ (,) <$> (symbol "/" *> parseLexemes) <* symbol "_" <*> parseLexemes + return (env1, env2, exception) + + (env1, env2, exception) <- parseEnvironment <|> pure ([], [], Nothing) + + _ <- optional scn -- consume newline after rule if present + + o' <- getOffset + let plaintext = takeWhile notNewline $ (fst . fromJust) (takeN_ (o' - o) s) + return Rule{environment=(env1,env2), ..} + where + notNewline c = (c /= '\n') && (c /= '\r') + +-- | Parse a 'String' in Brassica sound change syntax into a +-- 'Rule'. Returns 'Left' if the input string is malformed. +-- +-- For details on the syntax, refer to . +parseRule :: String -> Either (ParseErrorBundle String Void) Rule +parseRule = parseRuleWithCategories M.empty + +-- | Same as 'parseRule', but also allows passing in some predefined +-- categories to substitute. +parseRuleWithCategories :: C.Categories Grapheme -> String -> Either (ParseErrorBundle String Void) Rule +parseRuleWithCategories cs s = flip evalState (Config cs) $ runParserT (scn *> ruleParser <* eof) "" s + +-- | Parse a list of 'SoundChanges'. +parseSoundChanges :: String -> Either (ParseErrorBundle String Void) SoundChanges +parseSoundChanges s = flip evalState (Config M.empty) $ runParserT (scn *> parser <* eof) "" s + where + parser = many $ + CategoriesDeclS <$> categoriesDeclParse + <|> RuleS <$> ruleParser diff --git a/src/Brassica/SoundChange/Tokenise.hs b/src/Brassica/SoundChange/Tokenise.hs new file mode 100644 --- /dev/null +++ b/src/Brassica/SoundChange/Tokenise.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Brassica.SoundChange.Tokenise + ( + -- * Components + Component(..) + , getWords + , splitMultipleResults + -- * High-level interface + , tokeniseWord + , tokeniseWords + , detokeniseWords' + , detokeniseWords + , findFirstCategoriesDecl + , withFirstCategoriesDecl + -- * Lower-level functions + , wordParser + , componentsParser + , sortByDescendingLength + ) where + +import Data.Char (isSpace) +import Data.Function (on) +import Data.Functor.Identity +import Data.List (intersperse, sortBy) +import Data.Maybe (mapMaybe) +import Data.Ord (Down(..)) +import Data.Void (Void) +import GHC.Generics (Generic) + +import Control.DeepSeq (NFData) +import Text.Megaparsec hiding (State) +import Text.Megaparsec.Char + +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 + deriving (Eq, Show, Functor, Foldable, Traversable, Generic, NFData) + +-- | Given a tokenised input string, return only the v'Word's within +-- it. +getWords :: [Component a] -> [a] +getWords = mapMaybe $ \case + Word a -> Just a + _ -> Nothing + +-- | Given a 'Component' containing multiple values in a v'Word', +-- split it apart into a list of 'Component's in which the given +-- 'String' is used as a 'Separator' between multiple results. +-- +-- For instance: +-- +-- >>> splitMultipleResults " " (Word ["abc", "def", "ghi"]) +-- [Word "abc", Separator " ", Word "def", Separator " ", Word "ghi"] +-- +-- >>> splitMultipleResults " " (Word ["abc"]) +-- [Word "abc"] +splitMultipleResults :: String -> Component [a] -> [Component a] +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. +-- +-- Note: the second parameter __must__ be 'sortByDescendingLength'-ed; +-- otherwise digraphs will not be parsed correctly. +wordParser :: [Char] -> [Grapheme] -> ParsecT Void String Identity PWord +wordParser excludes gs = some $ choice (chunk <$> gs) <|> (pure <$> satisfy (not . exclude)) + 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 [Component a] +componentsParser p = many $ + (Separator <$> takeWhile1P Nothing isSpace) <|> + (Gloss <$> gloss False) <|> + (Word <$> p) + where + gloss returnBracketed = do + _ <- char '[' + contents <- many $ gloss True <|> takeWhile1P Nothing (not . (`elem` "[]")) + _ <- char ']' + pure $ if returnBracketed + then '[' : concat contents ++ "]" + else concat contents + +sortByDescendingLength :: [[a]] -> [[a]] +sortByDescendingLength = sortBy (compare `on` Down . length) + +-- | Tokenise a 'String' input word into a 'PWord' by splitting it up +-- into t'Grapheme's. A list of available t'Grapheme's is supplied as +-- an argument. +-- +-- Note that this tokeniser is greedy: if one of the given +-- t'Grapheme's is a prefix of another, the tokeniser will prefer the +-- longest if possible. If there are no matching t'Grapheme's starting +-- at a particular character in the 'String', 'tokeniseWord' will +-- treat that character as its own t'Grapheme'. For instance: +-- +-- >>> tokeniseWord [] "cherish" +-- Right ["c","h","e","r","i","s","h"] +-- +-- >>> tokeniseWord ["e","h","i","r","s","sh"] "cherish" +-- Right ["c","h","e","r","i","sh"] +-- +-- >>> tokeniseWord ["c","ch","e","h","i","r","s","sh"] "cherish" +-- Right ["ch","e","r","i","sh"] +tokeniseWord :: [Grapheme] -> String -> Either (ParseErrorBundle String Void) PWord +tokeniseWord (sortByDescendingLength -> gs) = parse (wordParser "[" gs) "" + +-- | Given a list of available t'Grapheme's, tokenise an input string +-- into a list of words and other 'Component's. This uses the same +-- tokenisation strategy as 'tokeniseWords', but also recognises +-- 'Gloss'es (in square brackets) and 'Separator's (in the form of +-- whitespace). +tokeniseWords :: [Grapheme] -> String -> Either (ParseErrorBundle String Void) [Component PWord] +tokeniseWords (sortByDescendingLength -> gs) = + parse (componentsParser $ wordParser "[" gs) "" + +-- | Given a function to convert '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 + Separator w -> w + Gloss g -> '[':(g ++ "]") + +-- | Specialisation of 'detokeniseWords'' for 'PWord's, converting +-- words to strings using 'concat'. +detokeniseWords :: [Component PWord] -> String +detokeniseWords = detokeniseWords' concat + +-- | Given a list of sound changes, extract the list of graphemes +-- defined in the first categories declaration of the 'SoundChange's. +findFirstCategoriesDecl :: SoundChanges -> [Grapheme] +findFirstCategoriesDecl (CategoriesDeclS (CategoriesDecl gs):_) = gs +findFirstCategoriesDecl (_:ss) = findFirstCategoriesDecl ss +findFirstCategoriesDecl [] = [] + +-- | CPS'd form of 'findFirstCategoriesDecl'. Nice for doing things +-- like @'withFirstCategoriesDecl' 'tokeniseWords' changes words@ (to +-- tokenise using the graphemes from the first categories declaration) +-- and so on. +withFirstCategoriesDecl :: ([Grapheme] -> t) -> SoundChanges -> t +withFirstCategoriesDecl tok ss = tok (findFirstCategoriesDecl ss) diff --git a/src/Brassica/SoundChange/Types.hs b/src/Brassica/SoundChange/Types.hs new file mode 100644 --- /dev/null +++ b/src/Brassica/SoundChange/Types.hs @@ -0,0 +1,204 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Brassica.SoundChange.Types + ( + -- * Words and graphemes + Grapheme + , PWord + -- * Lexemes + , Lexeme(..) + , CategoryElement(..) + , LexemeType(..) + -- * Rules + , Rule(..) + , Environment + , Direction(..) + , Flags(..) + , defFlags + -- * Categories and statements + , CategoriesDecl(..) + , Statement(..) + , plaintext' + , SoundChanges + -- * Utility + , OneOf + ) where + +import Control.DeepSeq (NFData(..)) +import Data.Kind (Constraint) +import GHC.Generics (Generic) +import GHC.TypeLits + +-- | The constraint @OneOf a x y@ is satisfied if @a ~ x@ or @a ~ y@. +-- +-- (Note: the strange @() ~ Bool@ constraint is just a simple +-- unsatisfiable constraint, so as to not give ‘non-exhaustive pattern +-- match’ errors everywhere.) +type family OneOf a x y :: Constraint where + OneOf a a y = () + OneOf a x a = () + OneOf a b c = + ( () ~ Bool + , TypeError ('Text "Couldn't match type " + ':<>: 'ShowType a + ':<>: 'Text " with " + ':<>: 'ShowType b + ':<>: 'Text " or " + ':<>: 'ShowType c)) + +-- | The type of graphemes, or more accurately multigraphs: for +-- instance, @"a", "ch", "c̓" :: t'Grapheme'@. +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'@. +-- +-- (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'@.) +type PWord = [Grapheme] + +-- | The part of a 'Rule' in which a 'Lexeme' may occur: either the +-- target, the replacement or the environment. +data LexemeType = Target | Replacement | Env + +-- | A 'Lexeme' is the smallest part of a sound change. Both matches +-- and replacements are made up of 'Lexeme's: the phantom type +-- variable specifies where each different variety of 'Lexeme' may +-- occur. +data Lexeme (a :: LexemeType) where + -- | In Brassica sound-change syntax, one or more letters without intervening whitespace + Grapheme :: Grapheme -> Lexeme a + -- | In Brassica sound-change syntax, delimited by square brackets + Category :: [CategoryElement a] -> Lexeme a + -- | In Brassica sound-change syntax, specified as @#@ + Boundary :: Lexeme 'Env + -- | In Brassica sound-change syntax, delimited by parentheses + Optional :: [Lexeme a] -> Lexeme a + -- | In Brassica sound-change syntax, specified as @\@ + Metathesis :: Lexeme 'Replacement + -- | In Brassica sound-change syntax, specified as @>@ + Geminate :: Lexeme a + -- | In Brassica sound-change syntax, specified as @^@ before another 'Lexeme' + Wildcard :: OneOf a 'Target 'Env => Lexeme a -> Lexeme a + -- | In Brassica sound-change syntax, specified as @*@ after another 'Lexeme' + Kleene :: OneOf a 'Target 'Env => Lexeme a -> Lexeme a + -- | In Brassica sound-change syntax, specified as @~@ + Discard :: Lexeme 'Replacement + +deriving instance Show (Lexeme a) + +instance NFData (Lexeme a) where + rnf (Grapheme g) = rnf g + rnf (Category cs) = rnf cs + rnf Boundary = () + rnf (Optional ls) = rnf ls + rnf Metathesis = () + rnf Geminate = () + rnf (Wildcard l) = rnf l + rnf (Kleene l) = rnf l + rnf Discard = () + +-- | The elements allowed in a 'Category': currently, only +-- t'Grapheme's and word boundaries. +data CategoryElement (a :: LexemeType) where + GraphemeEl :: Grapheme -> CategoryElement a + BoundaryEl :: CategoryElement 'Env + +deriving instance Show (CategoryElement a) +deriving instance Eq (CategoryElement a) +deriving instance Ord (CategoryElement a) + +instance NFData (CategoryElement a) where + rnf (GraphemeEl a) = rnf a + rnf BoundaryEl = () + +-- | An 'Environment' is a tuple of @(before, after)@ components, +-- corresponding to a ‘/ before _ after’ component of a sound change. +-- +-- Note that an empty environment is just @([], [])@. +type Environment = ([Lexeme 'Env], [Lexeme 'Env]) + +-- | Specifies application direction of rule — either left-to-right or right-to-left. +data Direction = LTR | RTL + deriving (Eq, Show, Generic, NFData) + +-- | Flags which can be enabled, disabled or altered on a 'Rule' to +-- change how it is applied. +data Flags = Flags + { highlightChanges :: Bool + , applyDirection :: Direction + , applyOnceOnly :: Bool + , sporadic :: Bool + } deriving (Show, Generic, NFData) + +-- | A default selection of flags which are appropriate for most +-- rules: +-- +-- @ +-- 'defFlags' = 'Flags' +-- { 'highlightChanges' = 'True' +-- , 'applyDirection' = 'LTR' +-- , 'applyOnceOnly' = 'False' +-- , 'sporadic' = 'False' +-- } +-- @ +-- +-- That is: highlight changes, apply from left to right, apply +-- repeatedly, and don’t apply sporadically. +defFlags :: Flags +defFlags = Flags + { highlightChanges = True + , applyDirection = LTR + , applyOnceOnly = False + , sporadic = False + } + +-- | A single sound change rule: in Brassica sound-change syntax with all elements specified, +-- @-flags target / replacement \/ environment \/ exception@. +-- (And usually the 'plaintext' of the rule will contain a 'String' resembling that pattern.) +data Rule = Rule + { target :: [Lexeme 'Target] + , replacement :: [Lexeme 'Replacement] + , environment :: Environment + , exception :: Maybe Environment + , flags :: Flags + , plaintext :: String + } deriving (Show, Generic, NFData) + +-- | Corresponds to a category declaration in a set of sound +-- changes. Category declarations are mostly desugared away by the +-- parser, but for rule application we still need to be able to filter +-- out all unknown t'Grapheme's; thus, a 'CategoriesDecl' lists the +-- t'Grapheme's which are available at a given point. +newtype CategoriesDecl = CategoriesDecl { graphemes :: [Grapheme] } + deriving (Show, Generic, NFData) + +-- | A 'Statement' can be either a single sound change rule, or a +-- category declaration. +data Statement = RuleS Rule | CategoriesDeclS CategoriesDecl + deriving (Show, Generic, NFData) + +-- | A simple wrapper around 'plaintext' for 'Statement's. Returns +-- @"categories … end"@ for all 'CategoriesDecl' inputs. +plaintext' :: Statement -> String +plaintext' (RuleS r) = plaintext r +plaintext' (CategoriesDeclS _) = "categories … end" + +-- | A set of 'SoundChanges' is simply a list of 'Statement's. +type SoundChanges = [Statement] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +module Main where + +import Conduit +import Control.Category ((>>>)) +import Control.Monad.Trans.Except (runExceptT, throwE) +import System.IO (IOMode(..), withFile) +import Test.Tasty ( defaultMain, testGroup, TestTree ) +import Test.Tasty.Golden (goldenVsFile) + +import qualified Data.ByteString as B +import qualified Data.ByteString.UTF8 as B8 +import qualified Data.Text as T + +import Brassica.SoundChange (applyChanges, splitMultipleResults, applyChangesWithLogs, reportAsText) +import Brassica.SoundChange.Parse (parseSoundChanges, errorBundlePretty) +import Brassica.SoundChange.Tokenise (tokeniseWords, detokeniseWords, withFirstCategoriesDecl, Component, getWords) +import Brassica.SoundChange.Types (SoundChanges, PWord, plaintext') + +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" + ] + where + showWord = detokeniseWords . concatMap (splitMultipleResults " ") + + showLogs logs = unlines $ fmap (reportAsText plaintext') $ concat $ getWords logs + +proto21eTest + :: (SoundChanges -> PWord -> [a]) + -> ([Component [a]] -> String) + -> String + -> FilePath + -> FilePath + -> TestTree +proto21eTest 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") + soundChanges <- catchEither (parseSoundChanges soundChangesData) $ \err -> do + liftIO $ putStrLn $ + "Cannot parse the SCA file because:\n" ++ + errorBundlePretty err + throwE () + let output pre = B8.fromString . (++"\n") . (pre ++) + prettyError = output "SCA Error:" . errorBundlePretty + prettyOutput = output "SCA Output: " . showWord + evolve = + withFirstCategoriesDecl tokeniseWords soundChanges + >>> (fmap.fmap.fmap) (applyFn soundChanges) + >>> either prettyError prettyOutput + liftIO $ withSourceFile "test/proto21e.in" $ flip connect + $ decodeUtf8C + .| linesUnboundedC + .| mapC (evolve . T.unpack) + .| sinkHandle outFile + + +catchEither :: Applicative f => Either e a -> (e -> f a) -> f a +catchEither val f = either f pure val