diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,1 +1,11 @@ -# Changelog for brassica +# Brassica changelog + +## Unreleased changes + +- Allow category backreferencing with `@n` before category +- Allow forcing nondeterminism with `@?` before category +- Add ‘input→output’ format for output words +- Change default output format for MDF input to wordlist in CLI +- Add ‘or environments’ with syntax ‘target / replacement / env1 / env2 / env3 / …’. + Former rule exceptions with similar syntax have been changed to syntax ‘target / replacement / env // exception’. +- Improve documentation diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Brad Neimann (c) 2020-2022 +Copyright Brad Neimann (c) 2020-2023 All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,9 +1,11 @@ # Brassica +[![Hackage](https://img.shields.io/hackage/v/brassica.svg?logo=haskell)](https://hackage.haskell.org/package/brassica) + Brassica is a new sound change applier. Its features include: -- Can be used interactively both [online](http://bradrn.com/brassica/index.html) and as a desktop application, or non-interactively in batch mode on the command-line or as a Haskell library +- Can be used interactively both [online](http://bradrn.com/brassica/index.html) and as a desktop application, or non-interactively in batch mode on the command-line or as a [Haskell library](https://hackage.haskell.org/package/brassica) - Natively supports the MDF dictionary format, also used by tools including [SIL Toolbox](https://software.sil.org/toolbox/) and [Lexique Pro](https://software.sil.org/lexiquepro/) - First-class support for multigraphs - Easy control over rule application: apply sound changes sporadically, right-to-left, and in many more ways @@ -19,7 +21,7 @@ Download Brassica from the [releases page](https://github.com/bradrn/brassica/releases/latest). Alternately, try it online at http://bradrn.com/brassica. -As of the time of writing prebuilt binaries exist only for Windows. +As of the time of writing prebuilt binaries exist for Windows and Linux. Instructions for building from source are available at [`BUILDING.md`](./BUILDING.md). -![Image of Brassica with some example sound changes](https://raw.githubusercontent.com/bradrn/brassica/v0.0.3/gui-interface-example.png) +![Image of Brassica with some example sound changes](https://raw.githubusercontent.com/bradrn/brassica/v0.1.0/gui-interface-example.png) diff --git a/brassica.cabal b/brassica.cabal --- a/brassica.cabal +++ b/brassica.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: brassica -version: 0.0.3 +version: 0.1.0 synopsis: Featureful sound change applier description: The Brassica library for the simulation of sound changes in historical linguistics and language construction. @@ -44,7 +44,7 @@ base >=4.7 && <5 , containers >=0.6 && <0.7 , deepseq >=1.4 && <1.5 - , megaparsec >=8.0 && <8.1 + , megaparsec >=8.0 && <9.3 , mtl >=2.2 && <2.3 , parser-combinators >=1.2 && <1.3 , split >=0.2 && <0.3 @@ -59,10 +59,10 @@ build-depends: base >=4.7 && <5 , brassica - , bytestring ^>=0.10 + , bytestring >=0.10 && <0.12 , conduit ^>=1.3 , optparse-applicative ^>=0.17 - , text ^>=1.2 + , text >=1.2 && <2.1 default-language: Haskell2010 @@ -102,8 +102,8 @@ , brassica , tasty ^>=1.4 , tasty-golden ^>=2.3 - , bytestring ^>=0.10 - , text ^>=1.2 + , bytestring + , text >=1.2 && <2.1 , transformers ^>=0.5 , conduit ^>=1.3 , utf8-string ^>=1.0 diff --git a/cli/Main.hs b/cli/Main.hs --- a/cli/Main.hs +++ b/cli/Main.hs @@ -7,14 +7,13 @@ import Conduit import qualified Data.ByteString as B -import Data.Text (pack, unpack, Text) +import Data.Text (pack, unpack, snoc, Text) import Data.Text.Encoding (decodeUtf8) import Options.Applicative import Brassica.SoundChange import Brassica.SoundChange.Frontend.Internal - main :: IO () main = do Options{..} <- execParser opts @@ -28,7 +27,7 @@ withSinkFileIf outWordsFile $ \outC -> runConduit $ inC - .| processWords (incrFor wordsFormat) rules wordsFormat tokMode outMode + .| processWords (incrFor wordsFormat) rules wordsFormat outMode .| outC where @@ -39,13 +38,20 @@ (metavar "RULES" <> help "File containing sound changes") <*> flag Raw MDF (long "mdf" <> help "Parse input words in MDF format") - <*> flag Normal AddEtymons - (long "etymons" <> help "With --mdf, add etymologies to output") - <*> (flag' ReportRulesApplied + <*> asum + [ flag' ReportRulesApplied (long "report" <> help "Report rules applied rather than outputting words") - <|> - flag (ApplyRules NoHighlight MDFOutput) (ApplyRules NoHighlight WordsOnlyOutput) - (long "wordlist" <> help "With --mdf, output only a list of the derived words")) + , flag' (ApplyRules NoHighlight MDFOutput) + (long "mdf-out" <> help "With --mdf, output MDF dictionary") + , flag' (ApplyRules NoHighlight MDFOutputWithEtymons) + (long "etymons" <> help "With --mdf, output MDF dictionary with etymologies") + , flag' (ApplyRules NoHighlight WordsWithProtoOutput) + (long "show-input" <> help "Output an input→output wordlist") + , flag + (ApplyRules NoHighlight WordsOnlyOutput) + (ApplyRules NoHighlight WordsOnlyOutput) + (long "wordlist" <> help "Output only a list of the derived words (default)") + ] <*> optional (strOption (long "in" <> short 'i' <> help "File containing input words (if not specified will read from stdin)")) <*> optional (strOption @@ -63,7 +69,6 @@ data Options = Options { rulesFile :: String , wordsFormat :: InputLexiconFormat - , tokMode :: TokenisationMode , outMode :: ApplicationMode , inWordsFile :: Maybe String , outWordsFile :: Maybe String @@ -74,18 +79,16 @@ => Bool -- split into lines? -> SoundChanges -> InputLexiconFormat - -> TokenisationMode -> ApplicationMode -> ConduitT B.ByteString B.ByteString m () -processWords incr rules wordsFormat tokMode outMode = +processWords incr rules wordsFormat outMode = decodeUtf8C .| (if incr then linesUnboundedC else mapC id) - .| mapC (processApplicationOutput . evolve . unpack) + .| mapC (processApplicationOutput . evolve . unpack . (`snoc` '\n')) .| throwOnLeft - .| (if incr then unlinesC else mapC id) .| encodeUtf8C where - evolve ws = parseTokeniseAndApplyRules rules ws wordsFormat tokMode outMode Nothing + evolve ws = parseTokeniseAndApplyRules rules ws wordsFormat outMode Nothing throwOnLeft :: (MonadThrow m, Exception e) => ConduitT (Either e r) r m () throwOnLeft = awaitForever $ \case diff --git a/src/Brassica/MDF.hs b/src/Brassica/MDF.hs --- a/src/Brassica/MDF.hs +++ b/src/Brassica/MDF.hs @@ -34,7 +34,7 @@ import Text.Megaparsec.Char import Brassica.SoundChange.Tokenise -import Brassica.SoundChange.Types (Grapheme, PWord) +import Brassica.SoundChange.Types (PWord) import Data.Maybe (fromMaybe) -- | An MDF (Multi-Dictionary Formatter) file, represented as a list @@ -89,7 +89,7 @@ -- | Parse an MDF file to an 'MDF', parsing the 'Vernacular' fields -- into 'Component's in the process. parseMDFWithTokenisation - :: [Grapheme] + :: [String] -> String -> Either (ParseErrorBundle String Void) (MDF [Component PWord]) parseMDFWithTokenisation (sortByDescendingLength -> gs) = diff --git a/src/Brassica/Paradigm/Parse.hs b/src/Brassica/Paradigm/Parse.hs --- a/src/Brassica/Paradigm/Parse.hs +++ b/src/Brassica/Paradigm/Parse.hs @@ -86,6 +86,6 @@ -- | Parse a 'String' in Brassica paradigm syntax into a 'Paradigm'. -- Returns 'Left' if the input string is malformed. -- --- For details on the syntax, refer to . +-- For details on the syntax, refer to . parseParadigm :: String -> Either (ParseErrorBundle String Void) Paradigm parseParadigm = runParser (many statement) "" diff --git a/src/Brassica/SoundChange/Apply/Internal.hs b/src/Brassica/SoundChange/Apply/Internal.hs --- a/src/Brassica/SoundChange/Apply/Internal.hs +++ b/src/Brassica/SoundChange/Apply/Internal.hs @@ -31,6 +31,7 @@ -- * Lexeme matching , match , matchMany + , matchMany' , mkReplacement , exceptionAppliesAtPoint , matchRuleAtPoint @@ -55,6 +56,7 @@ ) where import Control.Applicative ((<|>)) +import Control.Category ((>>>)) import Data.Containers.ListUtils (nubOrd) import Data.Function ((&)) import Data.Functor ((<&>)) @@ -120,8 +122,8 @@ modifyMatchedGraphemes :: ([Grapheme] -> [Grapheme]) -> MatchOutput -> MatchOutput modifyMatchedGraphemes f MatchOutput{..} = MatchOutput{matchedGraphemes=f matchedGraphemes, ..} -prependGrapheme :: Grapheme -> MatchOutput -> MatchOutput -prependGrapheme g = modifyMatchedGraphemes (g:) +appendGrapheme :: MatchOutput -> Grapheme -> MatchOutput +appendGrapheme out g = modifyMatchedGraphemes (++[g]) out instance Semigroup MatchOutput where (MatchOutput a1 b1 c1) <> (MatchOutput a2 b2 c2) = MatchOutput (a1++a2) (b1++b2) (c1++c2) @@ -130,40 +132,47 @@ -- 'MultiZipper' past the match. For each match found, returns the -- 'MatchOutput' tupled with the updated 'MultiZipper'. match :: OneOf a 'Target 'Env - => Maybe Grapheme -- ^ The previously-matched grapheme, if any. (Used to match a 'Geminate'.) + => MatchOutput -- ^ The previous 'MatchOutput' + -> Maybe Grapheme -- ^ The previously-matched grapheme, if any. (Used to match a 'Geminate'.) -> Lexeme a -- ^ The lexeme to match. -> MultiZipper t Grapheme -- ^ The 'MultiZipper' to match against. -> [(MatchOutput, MultiZipper t Grapheme)] - -- ^ The output: a tuple @((i, g), mz)@ as described below. -match prev (Optional l) mz = - (MatchOutput [] [False] [], mz) : - (first (MatchOutput [] [True] [] <>) <$> matchMany prev l mz ) -match prev w@(Wildcard l) mz = case match prev l mz of - [] -> maybeToList (consume mz) >>= \(g, mz') -> - first (prependGrapheme g) <$> match prev w mz' + -- ^ The output: a tuple @(g, mz)@ as described below. +match out prev (Optional l) mz = + (out <> MatchOutput [] [False] [], mz) : + matchMany (out <> MatchOutput [] [True] []) prev l mz +match out prev w@(Wildcard l) mz = case match out prev l mz of + [] -> maybeToList (consume mz) >>= \case + (GBoundary, _) -> [] -- don't continue past word boundary + (g, mz') -> match (appendGrapheme out g) prev w mz' r -> r -match prev k@(Kleene l) mz = case match prev l mz of +match out prev k@(Kleene l) mz = case match out prev l mz of [] -> [(MatchOutput [] [] [], mz)] - r -> r >>= \(out, mz') -> case match prev k mz' of + r -> r >>= \(out', mz') -> case match out' prev k mz' of [] -> error "match: Kleene should never fail" - r' -> first (out <>) <$> r' -match _ (Grapheme g) mz = (MatchOutput [] [] [g],) <$> maybeToList (matchGrapheme g mz) -match _ (Category gs) mz = + r' -> r' +match out _ (Grapheme g) mz = (out <> MatchOutput [] [] [g],) <$> maybeToList (matchGrapheme g mz) +match out _ (Category gs) mz = gs -- Attempt to match each option in category... - & fmap (\case - BoundaryEl -> if atBoundary mz then Just ([], mz) else Nothing - GraphemeEl g -> ([g],) <$> matchGrapheme g mz) + & fmap (matchCategoryEl mz) -- ...get the index of each match... & zipWith (\i m -> fmap (i,) m) [0..] -- ...and take all matches & (>>= maybeToList) - & fmap (\(i, (g, mz')) -> (MatchOutput [i] [] g, mz')) -match _ Boundary mz = if atBoundary mz then [(MatchOutput [] [] [], mz)] else [] -match prev Geminate mz = case prev of + & fmap (\(i, (g, mz')) -> (out <> MatchOutput [i] [] g, mz')) +match out prev Geminate mz = case prev of Nothing -> [] - Just prev' -> (MatchOutput [] [] [prev'],) <$> maybeToList (matchGrapheme prev' mz) + Just prev' -> (out <> MatchOutput [] [] [prev'],) <$> maybeToList (matchGrapheme prev' mz) +match out _prev (Backreference i gs) mz = maybeToList $ do + catIx <- matchedCatIxs out !? (i-1) + g <- gs !? catIx + (matched, mz') <- matchCategoryEl mz g + pure (modifyMatchedGraphemes (++matched) out, mz') +matchCategoryEl :: MultiZipper t Grapheme -> Grapheme -> Maybe ([Grapheme], MultiZipper t Grapheme) +matchCategoryEl mz g = ([g],) <$> matchGrapheme g mz + matchGrapheme :: Grapheme -> MultiZipper t Grapheme -> Maybe (MultiZipper t Grapheme) matchGrapheme g = matchGraphemeP (==g) @@ -175,20 +184,61 @@ -- though the outputs are given as a list of indices and graphemes -- rather than as a single index and grapheme. matchMany :: OneOf a 'Target 'Env + => MatchOutput + -> Maybe Grapheme + -> [Lexeme a] + -> MultiZipper t Grapheme + -> [(MatchOutput, MultiZipper t Grapheme)] +matchMany out _ [] mz = [(out, mz)] +matchMany out prev (l:ls) mz = + match out prev l mz >>= \(out', mz') -> + matchMany out' (lastMay (matchedGraphemes out') <|> prev) ls mz' + +-- | 'matchMany' without any previous match output. +matchMany' :: OneOf a 'Target 'Env => Maybe Grapheme -> [Lexeme a] -> MultiZipper t Grapheme -> [(MatchOutput, MultiZipper t Grapheme)] -matchMany = go (MatchOutput [] [] []) - where - go out _ [] mz = [(out, mz)] - go out prev (l:ls) mz = match prev l mz >>= \(out', mz') -> - go (out <> out') (lastMay (matchedGraphemes out') <|> prev) ls mz' +matchMany' = matchMany (MatchOutput [] [] []) -- Small utility function, not exported lastMay :: [a] -> Maybe a lastMay l = if null l then Nothing else Just (last l) +data ReplacementIndices = ReplacementIndices + { ixInCategories :: Int + , ixInOptionals :: Int + , forcedCategory :: Maybe CategoryNumber + } deriving (Show) + +data CategoryNumber = CategoryNumber Int | Nondeterministic + deriving (Show) + +advanceCategory :: ReplacementIndices -> Int -> (CategoryNumber, ReplacementIndices) +advanceCategory ix cslen = + case forcedCategory ix of + Just i -> (i, ix { forcedCategory = Nothing }) + Nothing -> + let i = ixInCategories ix in + ( if i < cslen then CategoryNumber i else Nondeterministic + , ix { ixInCategories = i+1 } + ) + +advanceOptional :: ReplacementIndices -> (Int, ReplacementIndices) +advanceOptional ix = + let i = ixInOptionals ix + in (i, ix { ixInOptionals = i+1 }) + +forceCategory :: CategoryNumber -> ReplacementIndices -> ReplacementIndices +forceCategory i ixs = ixs { forcedCategory = Just i } + +-- | Partially safe list indexing +(!?) :: [a] -> Int -> Maybe a +(x:_ ) !? 0 = Just x +(_:xs) !? n = xs !? (n-1) +[] !? _ = Nothing + -- | Given a list of 'Lexeme's specifying a replacement, generate all -- possible replacements and apply them to the given input. mkReplacement @@ -196,39 +246,59 @@ -> [Lexeme 'Replacement] -- ^ The 'Lexeme's specifying the replacement. -> MultiZipper t Grapheme -> [MultiZipper t Grapheme] -mkReplacement = \out ls -> fmap (fst . snd) . go out ls . (,Nothing) +mkReplacement out = \ls -> fmap (fst . snd) . go startIxs ls . (,Nothing) where - go out [] (mz, prev) = [(out, (mz, prev))] - go out (l:ls) (mz, prev) = do - (out', (mz', prev')) <- replaceLex out l mz prev - go out' ls (mz', prev') + startIxs = ReplacementIndices 0 0 Nothing + go + :: ReplacementIndices + -> [Lexeme 'Replacement] + -> (MultiZipper t Grapheme, Maybe Grapheme) + -> [(ReplacementIndices, (MultiZipper t Grapheme, Maybe Grapheme))] + go ixs [] (mz, prev) = [(ixs, (mz, prev))] + go ixs (l:ls) (mz, prev) = do + (ixs', (mz', prev')) <- replaceLex ixs l mz prev + go ixs' ls (mz', prev') + + numCatsMatched = length $ matchedCatIxs out + replaceLex - :: MatchOutput + :: ReplacementIndices -> Lexeme 'Replacement -> MultiZipper t Grapheme -> Maybe Grapheme - -> [(MatchOutput, (MultiZipper t Grapheme, Maybe Grapheme))] - replaceLex out (Grapheme g) mz _prev = [(out, (insert g mz, Just g))] - replaceLex out@MatchOutput{matchedCatIxs=(i:is)} (Category gs) mz _prev = - fmap (out{matchedCatIxs=is},) $ - if i < length gs - then case gs !! i of GraphemeEl g -> [(insert g mz, Just g)] - else [(insert "\xfffd" mz, Nothing)] -- Unicode replacement character - replaceLex out (Category gs) mz _prev = - gs <&> \(GraphemeEl g) -> (out, (insert g mz, Just g)) - replaceLex MatchOutput{matchedOptionals=(o:os), ..} (Optional ls) mz prev = - let out' = MatchOutput{matchedOptionals=os, ..} - in if o - then go out' ls (mz, prev) - else [(out', (mz, Nothing))] - replaceLex out (Optional ls) mz prev = (out, (mz, Nothing)) : go out ls (mz, prev) - replaceLex out@MatchOutput{matchedGraphemes} Metathesis mz _prev = - [(out, (flip insertMany mz $ reverse matchedGraphemes, listToMaybe matchedGraphemes))] - replaceLex out Geminate mz prev = - [(out, (flip insertMany mz $ maybeToList prev, prev))] - replaceLex out@MatchOutput{matchedCatIxs=(_:is)} Discard mz prev = [(out{matchedCatIxs=is}, (mz, prev))] - replaceLex out@MatchOutput{matchedCatIxs=[]} Discard mz prev = [(out, (mz, prev))] + -> [(ReplacementIndices, (MultiZipper t Grapheme, Maybe Grapheme))] + replaceLex ixs (Grapheme g) mz _prev = [(ixs, (insert g mz, Just g))] + replaceLex ixs (Category gs) mz _prev = + case advanceCategory ixs numCatsMatched of + (CategoryNumber ci, ixs') -> + let i = matchedCatIxs out !! ci in + case gs !? i of + Just g -> [(ixs', (insert g mz, Just g))] + Nothing -> [(ixs', (insert (GMulti "\xfffd") mz, Nothing))] -- Unicode replacement character + (Nondeterministic, ixs') -> gs <&> \g -> (ixs', (insert g mz, Just g)) + replaceLex ixs (Optional ls) mz prev = + let (co, ixs') = advanceOptional ixs in + case matchedOptionals out !? co of + Just True -> go ixs' ls (mz, prev) + Just False -> [(ixs', (mz, Nothing))] + Nothing -> (ixs', (mz, Nothing)) : go ixs ls (mz, prev) + replaceLex ixs Metathesis mz _prev = + [( ixs + , ( flip insertMany mz $ reverse $ matchedGraphemes out + , listToMaybe $ matchedGraphemes out) + )] + replaceLex ixs Geminate mz prev = + [(ixs, (flip insertMany mz $ maybeToList prev, prev))] + replaceLex ixs Discard mz prev = + let (_, ixs') = advanceCategory ixs numCatsMatched + in [(ixs', (mz, prev))] + replaceLex ixs (Backreference i c) mz prev = + let ixs' = forceCategory (CategoryNumber $ i-1) ixs -- 1-based indexing! + in replaceLex ixs' (Category c) mz prev + replaceLex ixs (Multiple c) mz prev = + let ixs' = forceCategory Nondeterministic ixs + in replaceLex ixs' (Category c) mz prev -- | Given a 'Rule' and a 'MultiZipper', determines whether the -- 'exception' of that rule (if any) applies starting at the current @@ -236,55 +306,66 @@ -- first element of each matching 'target'. exceptionAppliesAtPoint :: [Lexeme 'Target] -> Environment -> MultiZipper RuleTag Grapheme -> [Int] exceptionAppliesAtPoint target (ex1, ex2) mz = fmap fst $ flip runRuleAp mz $ do - _ <- RuleAp $ matchMany Nothing ex1 + _ <- RuleAp $ matchMany' Nothing ex1 pos <- gets curPos - MatchOutput{matchedGraphemes} <- RuleAp $ matchMany Nothing target - _ <- RuleAp $ matchMany (listToMaybe matchedGraphemes) ex2 + MatchOutput{matchedGraphemes} <- RuleAp $ matchMany' Nothing target + _ <- RuleAp $ matchMany' (listToMaybe matchedGraphemes) ex2 return pos --- | Given a 'Rule', determine if that rule matches. If so, for each --- match, set the appropriate 'RuleTag's and return a tuple of @(is, --- gs)@, where @gs@ is a list of matched t'Grapheme's, and @is@ is a --- list of indices, one for each 'Category' lexeme matched. +-- | Given a target and environment, determine if they rule +-- matches. If so, for each match, set the appropriate 'RuleTag's and +-- return a tuple of @(is, gs)@, where @gs@ is a list of matched +-- t'Grapheme's, and @is@ is a list of indices, one for each +-- 'Category' lexeme matched. matchRuleAtPoint - :: Rule + :: [Lexeme 'Target] + -> Environment -> MultiZipper RuleTag Grapheme -> [(MatchOutput, MultiZipper RuleTag Grapheme)] -matchRuleAtPoint Rule{environment = (env1, env2), ..} mz = flip runRuleAp mz $ do - _ <- RuleAp $ matchMany Nothing env1 - modify $ tag TargetStart - matchResult <- RuleAp $ matchMany Nothing target - modify $ tag TargetEnd - _ <- RuleAp $ matchMany (listToMaybe $ matchedGraphemes matchResult) env2 - return matchResult +matchRuleAtPoint target (env1,env2) mz = flip runRuleAp mz $ do + _ <- RuleAp $ matchMany' Nothing env1 + -- start of target needs to be INSIDE 'MultiZipper'! + -- otherwise get weird things like /x/#_ resulting in + -- #abc#→#xabd#x when it should be #abc#→#xabc# + gets atBoundary >>= \case + True -> RuleAp $ const [] + False -> do + modify $ tag TargetStart + matchResult <- RuleAp $ matchMany' Nothing target + modify $ tag TargetEnd + _ <- RuleAp $ matchMany' (listToMaybe $ matchedGraphemes matchResult) env2 + return matchResult -- | Given a 'Rule', determine if the rule matches at the current -- point; if so, apply the rule, adding appropriate tags. applyOnce :: Rule -> StateT (MultiZipper RuleTag Grapheme) [] Bool -applyOnce r@Rule{target, replacement, exception} = do - modify $ tag AppStart - result <- try (matchRuleAtPoint r) - case result of - Just out -> do - exs <- case exception of - Nothing -> pure [] - Just ex -> gets $ join . toList . - extend' (exceptionAppliesAtPoint target ex) - gets (locationOf TargetStart) >>= \p -> - if maybe True (`elem` exs) p - then return False - else do - modifyMay $ modifyBetween (TargetStart, TargetEnd) $ const [] - modifyMay $ seek TargetStart - modifyM $ mkReplacement out replacement - return True - Nothing -> return False +applyOnce r@Rule{target, replacement, exception} = + modify (tag AppStart) >> go (environment r) + where + go [] = return False + go (env:envs) = do + result <- try (matchRuleAtPoint target env) + case result of + Just out -> do + exs <- case exception of + Nothing -> pure [] + Just ex -> gets $ join . toList . + extend' (exceptionAppliesAtPoint target ex) + gets (locationOf TargetStart) >>= \p -> + if maybe True (`elem` exs) p + then return False + else do + modifyMay $ modifyBetween (TargetStart, TargetEnd) $ const [] + modifyMay $ seek TargetStart + modifyM $ mkReplacement out replacement + return True + Nothing -> modifyMay (seek AppStart) >> go envs -- | Remove tags and advance the current index to the next t'Grapheme' -- after the rule application. setupForNextApplication :: Bool -> Rule -> MultiZipper RuleTag Grapheme -> Maybe (MultiZipper RuleTag Grapheme) -setupForNextApplication success r@Rule{flags=Flags{applyDirection}} = fmap untag . - case applyDirection of +setupForNextApplication success r@Rule{flags=Flags{applyDirection}} = + fmap untag . case applyDirection of RTL -> seek AppStart >=> bwd LTR -> if success @@ -323,7 +404,9 @@ -- the given 'CategoriesDecl', replacing all unlisted graphemes with -- U+FFFD. checkGraphemes :: CategoriesDecl -> MultiZipper RuleTag Grapheme -> MultiZipper RuleTag Grapheme -checkGraphemes (CategoriesDecl gs) = fmap $ \g -> if g `elem` gs then g else "\xfffd" +checkGraphemes (CategoriesDecl gs) = fmap $ \case + GBoundary -> GBoundary + g -> if g `elem` gs then g else GMulti "\xfffd" -- | Apply a 'Statement' to a 'MultiZipper'. This is a simple wrapper -- around 'applyRule' and 'checkGraphemes'. @@ -346,7 +429,12 @@ -- are removed. To keep duplicates, use the lower-level internal -- function 'applyStatement' directly. applyStatementStr :: Statement -> PWord -> [PWord] -applyStatementStr st s = nubOrd $ fmap toList $ applyStatement st $ fromListStart s +applyStatementStr st = + addBoundaries + >>> fromListStart + >>> applyStatement st + >>> fmap (toList >>> removeBoundaries) + >>> nubOrd -- | A log item representing a single application of an action. (In -- practise this will usually be a 'Statement'.) Specifies the action @@ -390,12 +478,12 @@ -- +------+---+-------+-------------+ reportAsHtmlRows :: (r -> String) -> PWordLog r -> String -reportAsHtmlRows render item = go (concat $ initialWord item) (derivations item) +reportAsHtmlRows render item = go (concatWithBoundary $ initialWord item) (derivations item) where go _ [] = "" go cell1 ((output, action) : ds) = ("" ++ cell1 ++ "→" - ++ concat output + ++ concatWithBoundary output ++ "(" ++ render action ++ ")") ++ go "" ds @@ -416,10 +504,10 @@ -- > -> tazh (V / / _ #) reportAsText :: (r -> String) -> PWordLog r -> String reportAsText render item = unlines $ - concat (initialWord item) : fmap toLine (alignWithPadding $ derivations item) + concatWithBoundary (initialWord item) : fmap toLine (alignWithPadding $ derivations item) where alignWithPadding ds = - let (fmap concat -> outputs, actions) = unzip ds + let (fmap concatWithBoundary -> outputs, actions) = unzip ds maxlen = maximum $ length <$> outputs padded = outputs <&> \o -> o ++ replicate (maxlen - length o) ' ' in zip padded actions diff --git a/src/Brassica/SoundChange/Frontend/Internal.hs b/src/Brassica/SoundChange/Frontend/Internal.hs --- a/src/Brassica/SoundChange/Frontend/Internal.hs +++ b/src/Brassica/SoundChange/Frontend/Internal.hs @@ -26,7 +26,7 @@ -- | Rule application mode of the SCA. data ApplicationMode - = ApplyRules HighlightMode MDFOutputMode + = ApplyRules HighlightMode OutputMode | ReportRulesApplied deriving (Show, Eq) @@ -46,15 +46,23 @@ toEnum 2 = DifferentToInput toEnum _ = undefined -data MDFOutputMode = MDFOutput | WordsOnlyOutput +data OutputMode + = MDFOutput + | WordsOnlyOutput + | MDFOutputWithEtymons + | WordsWithProtoOutput deriving (Show, Eq) -instance Enum MDFOutputMode where +instance Enum OutputMode where -- used for conversion to and from C, so want control over values fromEnum MDFOutput = 0 fromEnum WordsOnlyOutput = 1 + fromEnum MDFOutputWithEtymons = 2 + fromEnum WordsWithProtoOutput = 3 toEnum 0 = MDFOutput toEnum 1 = WordsOnlyOutput + toEnum 2 = MDFOutputWithEtymons + toEnum 3 = WordsWithProtoOutput toEnum _ = undefined data TokenisationMode = Normal | AddEtymons @@ -68,6 +76,10 @@ toEnum 1 = AddEtymons toEnum _ = undefined +tokenisationModeFor :: ApplicationMode -> TokenisationMode +tokenisationModeFor (ApplyRules _ MDFOutputWithEtymons) = AddEtymons +tokenisationModeFor _ = Normal + -- | Output of a single application of rules to a wordlist: either a -- list of possibly highlighted words, an applied rules table, or a -- parse error. @@ -92,11 +104,21 @@ data ParseOutput a = ParsedRaw [Component a] | ParsedMDF (MDF [Component a]) deriving (Show, Functor) -componentise :: MDFOutputMode -> ParseOutput a -> [Component a] -componentise _ (ParsedRaw cs) = cs -componentise MDFOutput (ParsedMDF mdf) = componentiseMDF mdf -componentise WordsOnlyOutput (ParsedMDF mdf) = componentiseMDFWordsOnly mdf +componentise :: OutputMode -> [a] -> ParseOutput a -> [Component a] +componentise WordsWithProtoOutput ws (ParsedRaw cs) = intersperseWords ws cs +componentise _ _ (ParsedRaw cs) = cs +componentise MDFOutput _ (ParsedMDF mdf) = componentiseMDF mdf +componentise MDFOutputWithEtymons _ (ParsedMDF mdf) = componentiseMDF mdf +componentise WordsOnlyOutput _ (ParsedMDF mdf) = componentiseMDFWordsOnly mdf +componentise WordsWithProtoOutput ws (ParsedMDF mdf) = intersperseWords ws $ componentiseMDFWordsOnly mdf +intersperseWords :: [a] -> [Component a] -> [Component a] +intersperseWords (w:ws) (Word c:cs) = + Word w : Separator " → " : Word c : Separator "\n" : intersperseWords ws cs +intersperseWords ws (_:cs) = intersperseWords ws cs +intersperseWords [] cs = cs +intersperseWords _ [] = [] + tokeniseAccordingToInputFormat :: InputLexiconFormat -> TokenisationMode @@ -112,6 +134,10 @@ . second (duplicateEtymologies $ ('*':) . detokeniseWords) . withFirstCategoriesDecl parseMDFWithTokenisation cs +getParsedWords :: ParseOutput a -> [a] +getParsedWords (ParsedRaw cs) = getWords cs +getParsedWords (ParsedMDF mdf) = getWords $ componentiseMDF mdf + -- | Top-level dispatcher for an interactive frontend: given a textual -- wordlist and a list of sound changes, returns the result of running -- the changes in the specified mode. @@ -119,30 +145,34 @@ :: SoundChanges -- ^ changes -> String -- ^ words -> InputLexiconFormat - -> TokenisationMode -> ApplicationMode -> Maybe [Component PWord] -- ^ previous results -> ApplicationOutput PWord Statement -parseTokeniseAndApplyRules statements ws intype tmode mode prev = +parseTokeniseAndApplyRules statements ws intype mode prev = + let tmode = tokenisationModeFor mode in case tokeniseAccordingToInputFormat intype tmode statements ws of Left e -> ParseError e - Right toks -> case mode of + Right toks + | ws' <- getParsedWords toks + -> case mode of ReportRulesApplied -> AppliedRulesTable $ mapMaybe toPWordLog $ concat $ - getWords $ componentise WordsOnlyOutput $ + getWords $ componentise WordsOnlyOutput [] $ applyChangesWithLog statements <$> toks ApplyRules DifferentToLastRun mdfout -> let result = concatMap (splitMultipleResults " ") $ - componentise mdfout $ applyChanges statements <$> toks + componentise mdfout (fmap pure ws') $ applyChanges statements <$> toks in HighlightedWords $ zipWithComponents result (fromMaybe [] prev) [] $ \thisWord prevWord -> (thisWord, thisWord /= prevWord) ApplyRules DifferentToInput mdfout -> HighlightedWords $ concatMap (splitMultipleResults " ") $ - componentise mdfout $ applyChangesWithChanges statements <$> toks + componentise mdfout (fmap (pure . (,False)) ws') $ + applyChangesWithChanges statements <$> toks ApplyRules NoHighlight mdfout -> HighlightedWords $ (fmap.fmap) (,False) $ concatMap (splitMultipleResults " ") $ - componentise mdfout $ applyChanges statements <$> toks + componentise mdfout (fmap pure ws') $ + applyChanges statements <$> toks where -- Zips two tokenised input strings. Compared to normal 'zipWith' -- this has two special properties: diff --git a/src/Brassica/SoundChange/Parse.hs b/src/Brassica/SoundChange/Parse.hs --- a/src/Brassica/SoundChange/Parse.hs +++ b/src/Brassica/SoundChange/Parse.hs @@ -1,7 +1,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module Brassica.SoundChange.Parse @@ -36,7 +38,6 @@ class ParseLexeme (a :: LexemeType) where parseLexeme :: Parser (Lexeme a) - parseCategoryElement :: Parser (CategoryElement a) -- space consumer which does not match newlines sc :: Parser () @@ -57,18 +58,30 @@ symbol = L.symbol sc keyChars :: [Char] -keyChars = "#[](){}>\\→/_^%~*" +keyChars = "#[](){}>\\→/_^%~*@" +nonzero :: Parser Int +nonzero = label "nonzero postive number" $ try $ do + n <- lexeme L.decimal + guard $ n>0 + pure n + parseGrapheme :: Parser (Grapheme, Bool) -parseGrapheme = lexeme $ (,) <$> takeWhile1P Nothing (not . ((||) <$> isSpace <*> (`elem` keyChars))) <*> (isJust <$> optional (char '~')) +parseGrapheme = lexeme $ parseBoundary <|> parseMulti + where + parseBoundary = (GBoundary,False) <$ char '#' + parseMulti = (,) + <$> fmap GMulti (takeWhile1P Nothing (not . ((||) <$> isSpace <*> (`elem` keyChars)))) + <*> (isJust <$> optional (char '~')) + parseGrapheme' :: Parser Grapheme -parseGrapheme' = lexeme $ takeWhile1P Nothing (not . ((||) <$> isSpace <*> (=='='))) +parseGrapheme' = lexeme $ GMulti <$> takeWhile1P Nothing (not . ((||) <$> isSpace <*> (=='='))) -data CategoryModification a - = Union (CategoryElement a) - | Intersect (CategoryElement a) - | Subtract (CategoryElement a) +data CategoryModification + = Union Grapheme + | Intersect Grapheme + | Subtract Grapheme parseGraphemeOrCategory :: ParseLexeme a => Parser (Lexeme a) parseGraphemeOrCategory = do @@ -79,26 +92,26 @@ cats <- gets categories return $ case C.lookup g cats of Nothing -> Grapheme g - Just c -> Category $ C.bake $ GraphemeEl <$> c + Just c -> Category $ C.bake c parseCategory :: ParseLexeme a => Parser (Lexeme a) -parseCategory = do +parseCategory = Category <$> parseCategory' + +parseCategory' :: Parser [Grapheme] +parseCategory' = do mods <- symbol "[" *> someTill parseCategoryModification (symbol "]") cats <- gets categories - return $ Category $ C.bake $ - C.expand (C.mapCategories GraphemeEl cats) (toCategory mods) + return $ C.bake $ + C.expand cats (toCategory mods) parseCategoryStandalone :: Parser (Grapheme, C.Category 'C.Expanded Grapheme) parseCategoryStandalone = do g <- parseGrapheme' _ <- symbol "=" -- Use Target here because it only allows graphemes, not boundaries - mods <- some (parseCategoryModification @'Target) + mods <- some parseCategoryModification cats <- gets categories - return (g, C.expand cats $ toGrapheme <$> toCategory mods) - -toGrapheme :: CategoryElement 'Target -> Grapheme -toGrapheme (GraphemeEl g) = g + return (g, C.expand cats $ toCategory mods) categoriesDeclParse :: Parser CategoriesDecl categoriesDeclParse = do @@ -115,9 +128,9 @@ parseFeature = do _ <- symbol "feature" namePlain <- optional $ try $ parseGrapheme' <* symbol "=" - modsPlain <- some (parseCategoryModification @'Target) + modsPlain <- some parseCategoryModification cats <- gets categories - let plainCat = C.expand cats $ toGrapheme <$> toCategory modsPlain + let plainCat = C.expand cats $ toCategory modsPlain plain = C.bake plainCat modifiedCats <- some (symbol "/" *> parseCategoryStandalone) <* scn let modified = C.bake . snd <$> modifiedCats @@ -134,15 +147,15 @@ (k, c) <- try parseCategoryStandalone <* scn modify $ \(Config cs) -> Config (M.insert k c cs) -parseCategoryModification :: ParseLexeme a => Parser (CategoryModification a) -parseCategoryModification = parsePrefix <*> parseCategoryElement +parseCategoryModification :: Parser CategoryModification +parseCategoryModification = parsePrefix <*> (fst <$> parseGrapheme) where parsePrefix = (Intersect <$ char '+') <|> (Subtract <$ char '-') <|> pure Union -toCategory :: [CategoryModification a] -> C.Category 'C.Unexpanded (CategoryElement a) +toCategory :: [CategoryModification] -> C.Category 'C.Unexpanded Grapheme toCategory = go C.Empty where go c [] = c @@ -162,24 +175,39 @@ parseWildcard :: (ParseLexeme a, OneOf a 'Target 'Env) => Parser (Lexeme a) parseWildcard = Wildcard <$> (symbol "^" *> parseLexeme) -parseBoundary :: Parser () -parseBoundary = () <$ symbol "#" - parseDiscard :: Parser (Lexeme 'Replacement) parseDiscard = Discard <$ symbol "~" parseKleene :: OneOf a 'Target 'Env => Lexeme a -> Parser (Lexeme a) parseKleene l = (Kleene l <$ symbol "*") <|> pure l +parseMultiple :: Parser (Lexeme 'Replacement) +parseMultiple = Multiple <$> (symbol "@?" *> parseCategory') + +parseBackreference + :: forall a. + (OneOf a 'Target 'Replacement, ParseLexeme a) + => Parser (Lexeme a) +parseBackreference = + Backreference + <$> (symbol "@" *> nonzero) + <*> (parseCategory' <|> parseGraphemeCategory) + where + parseGraphemeCategory :: Parser [Grapheme] + parseGraphemeCategory = label "category" $ try $ + (parseGraphemeOrCategory @a) >>= \case + Category gs -> pure gs + _ -> empty + instance ParseLexeme 'Target where parseLexeme = asum [ parseCategory , parseOptional , parseGeminate , parseWildcard + , parseBackreference , parseGraphemeOrCategory ] >>= parseKleene - parseCategoryElement = GraphemeEl . fst <$> parseGrapheme instance ParseLexeme 'Replacement where parseLexeme = asum @@ -188,23 +216,19 @@ , parseMetathesis , parseDiscard , parseGeminate + , parseMultiple + , parseBackreference , parseGraphemeOrCategory ] - parseCategoryElement = GraphemeEl . fst <$> parseGrapheme instance ParseLexeme 'Env where parseLexeme = asum [ parseCategory - , Boundary <$ parseBoundary , parseOptional , parseGeminate , parseWildcard , parseGraphemeOrCategory ] >>= parseKleene - parseCategoryElement = asum - [ BoundaryEl <$ parseBoundary - , GraphemeEl . fst <$> parseGrapheme - ] parseLexemes :: ParseLexeme a => Parser [Lexeme a] parseLexemes = many parseLexeme @@ -229,28 +253,29 @@ _ <- lexeme $ oneOf "/→" replacement <- parseLexemes - let parseEnvironment = do - _ <- symbol "/" - env1 <- parseLexemes - _ <- symbol "_" - env2 <- parseLexemes - exception <- optional $ (,) <$> (symbol "/" *> parseLexemes) <* symbol "_" <*> parseLexemes - return (env1, env2, exception) + envs' <- many $ do + notFollowedBy $ symbol "//" -- for exceptions + _ <- symbol "/" + env1 <- parseLexemes + _ <- symbol "_" + env2 <- parseLexemes + return (env1, env2) + let envs = if null envs' then [([], [])] else envs' - (env1, env2, exception) <- parseEnvironment <|> pure ([], [], Nothing) + exception <- optional $ (,) <$> (symbol "//" *> parseLexemes) <* symbol "_" <*> parseLexemes _ <- optional scn -- consume newline after rule if present o' <- getOffset let plaintext = takeWhile notNewline $ (fst . fromJust) (takeN_ (o' - o) s) - return Rule{environment=(env1,env2), ..} + return Rule{environment=envs, ..} where notNewline c = (c /= '\n') && (c /= '\r') -- | Parse a 'String' in Brassica sound change syntax into a -- 'Rule'. Returns 'Left' if the input string is malformed. -- --- For details on the syntax, refer to . +-- For details on the syntax, refer to . parseRule :: String -> Either (ParseErrorBundle String Void) Rule parseRule = parseRuleWithCategories M.empty diff --git a/src/Brassica/SoundChange/Tokenise.hs b/src/Brassica/SoundChange/Tokenise.hs --- a/src/Brassica/SoundChange/Tokenise.hs +++ b/src/Brassica/SoundChange/Tokenise.hs @@ -16,6 +16,7 @@ , tokeniseWords , detokeniseWords' , detokeniseWords + , concatWithBoundary , findFirstCategoriesDecl , withFirstCategoriesDecl -- * Lower-level functions @@ -74,12 +75,16 @@ -- 'wordParser' itself is only really useful in unusual situations -- (e.g. as part of a larger parser). The first parameter gives a list -- of characters (aside from whitespace) which should be excluded from --- words, i.e. the parser will stop if any of them are found. +-- words, i.e. the parser will stop if any of them are found. The second +-- gives a list of multigraphs which might be expected. -- -- Note: the second parameter __must__ be 'sortByDescendingLength'-ed; --- otherwise digraphs will not be parsed correctly. -wordParser :: [Char] -> [Grapheme] -> ParsecT Void String Identity PWord -wordParser excludes gs = some $ choice (chunk <$> gs) <|> (pure <$> satisfy (not . exclude)) +-- otherwise multigraphs will not be parsed correctly. +wordParser :: [Char] -> [String] -> ParsecT Void String Identity PWord +wordParser excludes gs = some $ + (GBoundary <$ single '#') + <|> choice (fmap GMulti . chunk <$> gs) + <|> (GMulti . pure <$> satisfy (not . exclude)) where exclude = (||) <$> isSpace <*> (`elem` excludes) @@ -105,34 +110,34 @@ sortByDescendingLength = sortBy (compare `on` Down . length) -- | Tokenise a 'String' input word into a 'PWord' by splitting it up --- into t'Grapheme's. A list of available t'Grapheme's is supplied as --- an argument. +-- into t'Grapheme's. A list of available multigraphs is supplied as +-- the first argument. -- -- Note that this tokeniser is greedy: if one of the given --- t'Grapheme's is a prefix of another, the tokeniser will prefer the --- longest if possible. If there are no matching t'Grapheme's starting +-- multigraphs is a prefix of another, the tokeniser will prefer the +-- longest if possible. If there are no matching multigraphs starting -- at a particular character in the 'String', 'tokeniseWord' will -- treat that character as its own t'Grapheme'. For instance: -- -- >>> tokeniseWord [] "cherish" --- Right ["c","h","e","r","i","s","h"] +-- Right [GMulti "c",GMulti "h",GMulti "e",GMulti "r",GMulti "i",GMulti "s",GMulti "h"] -- -- >>> tokeniseWord ["e","h","i","r","s","sh"] "cherish" --- Right ["c","h","e","r","i","sh"] +-- Right [GMulti "c",GMulti "h",GMulti "e",GMulti "r",GMulti "i",GMulti "sh"] -- -- >>> tokeniseWord ["c","ch","e","h","i","r","s","sh"] "cherish" --- Right ["ch","e","r","i","sh"] -tokeniseWord :: [Grapheme] -> String -> Either (ParseErrorBundle String Void) PWord +-- Right [GMulti "ch",GMulti "e",GMulti "r",GMulti "i",GMulti "sh"] +tokeniseWord :: [String] -> String -> Either (ParseErrorBundle String Void) PWord tokeniseWord (sortByDescendingLength -> gs) = parse (wordParser "[" gs) "" --- | Given a list of available t'Grapheme's, tokenise an input string +-- | Given a list of available multigraphs, tokenise an input string -- into a list of words and other 'Component's. This uses the same -- tokenisation strategy as 'tokeniseWords', but also recognises -- 'Gloss'es (in square brackets) and 'Separator's (in the form of -- whitespace). -tokeniseWords :: [Grapheme] -> String -> Either (ParseErrorBundle String Void) [Component PWord] +tokeniseWords :: [String] -> String -> Either (ParseErrorBundle String Void) [Component PWord] tokeniseWords (sortByDescendingLength -> gs) = - parse (componentsParser $ wordParser "[" gs) "" + parse (componentsParser $ wordParser "[" gs) "" -- | Given a function to convert 'Word's to strings, converts a list -- of 'Component's to strings. @@ -143,14 +148,17 @@ Gloss g -> '[':(g ++ "]") -- | Specialisation of 'detokeniseWords'' for 'PWord's, converting --- words to strings using 'concat'. +-- words to strings using 'concatWithBoundary'. detokeniseWords :: [Component PWord] -> String -detokeniseWords = detokeniseWords' concat +detokeniseWords = detokeniseWords' concatWithBoundary --- | Given a list of sound changes, extract the list of graphemes +-- | Given a list of sound changes, extract the list of multigraphs -- defined in the first categories declaration of the 'SoundChange's. -findFirstCategoriesDecl :: SoundChanges -> [Grapheme] -findFirstCategoriesDecl (CategoriesDeclS (CategoriesDecl gs):_) = gs +findFirstCategoriesDecl :: SoundChanges -> [String] +findFirstCategoriesDecl (CategoriesDeclS (CategoriesDecl gs):_) = + mapMaybe + (\case GBoundary -> Nothing; GMulti m -> Just m) + gs findFirstCategoriesDecl (_:ss) = findFirstCategoriesDecl ss findFirstCategoriesDecl [] = [] @@ -158,5 +166,5 @@ -- like @'withFirstCategoriesDecl' 'tokeniseWords' changes words@ (to -- tokenise using the graphemes from the first categories declaration) -- and so on. -withFirstCategoriesDecl :: ([Grapheme] -> t) -> SoundChanges -> t +withFirstCategoriesDecl :: ([String] -> t) -> SoundChanges -> t withFirstCategoriesDecl tok ss = tok (findFirstCategoriesDecl ss) diff --git a/src/Brassica/SoundChange/Types.hs b/src/Brassica/SoundChange/Types.hs --- a/src/Brassica/SoundChange/Types.hs +++ b/src/Brassica/SoundChange/Types.hs @@ -6,8 +6,10 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -17,11 +19,14 @@ module Brassica.SoundChange.Types ( -- * Words and graphemes - Grapheme + Grapheme(..) , PWord + , addBoundaries + , removeBoundaries + , concatWithBoundary -- * Lexemes , Lexeme(..) - , CategoryElement(..) + , pattern Boundary , LexemeType(..) -- * Rules , Rule(..) @@ -41,6 +46,7 @@ import Control.DeepSeq (NFData(..)) import Data.Kind (Constraint) import GHC.Generics (Generic) +import GHC.OldList (dropWhileEnd) import GHC.TypeLits -- | The constraint @OneOf a x y@ is satisfied if @a ~ x@ or @a ~ y@. @@ -60,9 +66,11 @@ ':<>: 'Text " or " ':<>: 'ShowType c)) --- | The type of graphemes, or more accurately multigraphs: for --- instance, @"a", "ch", "c̓" :: t'Grapheme'@. -type Grapheme = [Char] +-- | The type of graphemes within a word. +data Grapheme + = GMulti [Char] -- ^ A multigraph: for instance @GMulti "a", GMulti "ch", GMulti "c̓" :: t'Grapheme'@. + | GBoundary -- ^ A non-letter element representing a word boundary which sound changes can manipulate + deriving (Eq, Ord, Show, Generic, NFData) -- | A word (or a subsequence of one) can be viewed as a list of -- @Grapheme@s: e.g. Portuguese "filha" becomes @@ -73,6 +81,24 @@ -- with @Prelude.'Prelude.Word'@.) type PWord = [Grapheme] +-- Add a 'GBoundary' at the beginning and end of the 'PWord'. +addBoundaries :: PWord -> PWord +addBoundaries w = GBoundary : w ++ [GBoundary] + +-- Remove 'GBoundary's from the beginning and end of the 'PWord'. +removeBoundaries :: PWord -> PWord +removeBoundaries = dropWhile (==GBoundary) . dropWhileEnd (==GBoundary) + +-- | Render a 'PWord' as a 'String'. Very much like 'concat', but +-- treating 'GBoundary's specially. Word-external boundaries are +-- deleted, while word-internal boundaries are converted to @"#"@. +concatWithBoundary :: PWord -> String +concatWithBoundary = go . removeBoundaries + where + go = concatMap $ \case + GMulti g -> g + GBoundary -> "#" + -- | The part of a 'Rule' in which a 'Lexeme' may occur: either the -- target, the replacement or the environment. data LexemeType = Target | Replacement | Env @@ -82,12 +108,11 @@ -- variable specifies where each different variety of 'Lexeme' may -- occur. data Lexeme (a :: LexemeType) where - -- | In Brassica sound-change syntax, one or more letters without intervening whitespace + -- | In Brassica sound-change syntax, one or more letters without intervening whitespace, + -- or a word boundary specified as @#@ Grapheme :: Grapheme -> Lexeme a -- | In Brassica sound-change syntax, delimited by square brackets - Category :: [CategoryElement a] -> Lexeme a - -- | In Brassica sound-change syntax, specified as @#@ - Boundary :: Lexeme 'Env + Category :: [Grapheme] -> Lexeme a -- | In Brassica sound-change syntax, delimited by parentheses Optional :: [Lexeme a] -> Lexeme a -- | In Brassica sound-change syntax, specified as @\@ @@ -100,33 +125,28 @@ Kleene :: OneOf a 'Target 'Env => Lexeme a -> Lexeme a -- | In Brassica sound-change syntax, specified as @~@ Discard :: Lexeme 'Replacement + -- | In Brassica sound-change syntax, specified as \@i before a category + Backreference :: OneOf a 'Target 'Replacement => Int -> [Grapheme] -> Lexeme a + -- | In Brassica sound-change syntax, specified as \@? before a category + Multiple :: [Grapheme] -> Lexeme 'Replacement +-- | A 'Lexeme' matching a single word boundary, specified as @#@ in Brassica syntax. +pattern Boundary :: Lexeme a +pattern Boundary = Grapheme GBoundary + deriving instance Show (Lexeme a) instance NFData (Lexeme a) where rnf (Grapheme g) = rnf g rnf (Category cs) = rnf cs - rnf Boundary = () rnf (Optional ls) = rnf ls rnf Metathesis = () rnf Geminate = () rnf (Wildcard l) = rnf l rnf (Kleene l) = rnf l rnf Discard = () - --- | The elements allowed in a 'Category': currently, only --- t'Grapheme's and word boundaries. -data CategoryElement (a :: LexemeType) where - GraphemeEl :: Grapheme -> CategoryElement a - BoundaryEl :: CategoryElement 'Env - -deriving instance Show (CategoryElement a) -deriving instance Eq (CategoryElement a) -deriving instance Ord (CategoryElement a) - -instance NFData (CategoryElement a) where - rnf (GraphemeEl a) = rnf a - rnf BoundaryEl = () + rnf (Backreference i l) = seq i $ rnf l + rnf (Multiple l) = rnf l -- | An 'Environment' is a tuple of @(before, after)@ components, -- corresponding to a ‘/ before _ after’ component of a sound change. @@ -170,12 +190,12 @@ } -- | A single sound change rule: in Brassica sound-change syntax with all elements specified, --- @-flags target / replacement \/ environment \/ exception@. +-- @-flags target / replacement \/ environment1 | environment2 | … \/ exception@. -- (And usually the 'plaintext' of the rule will contain a 'String' resembling that pattern.) data Rule = Rule { target :: [Lexeme 'Target] , replacement :: [Lexeme 'Replacement] - , environment :: Environment + , environment :: [Environment] , exception :: Maybe Environment , flags :: Flags , plaintext :: String