diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,18 @@ # Brassica changelog +## v0.2.0 + +- Allow grapheme to begin with star +- Allow lexeme sequences in categories using `{…}` syntax +- Allow backreferences to occur in the environment +- Allow user to choose separator used between multiple results (previously a space) +- Internal refactor: category expansion is now separate from parsing +- Add `--version` command-line option +- Store `MultiZipper` data in a `Vector` rather than a linked list (for performance) +- Bugfix: subtraction now removes all subtracted graphemes +- Store paradigm builder output in a tree data structure, allowing a more compact output format +- Documented abstract features in paradigm builder (previously present but undocumented) + ## v0.1.1 - Rewrote executables with a client/server architecture for better Windows support. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Brad Neimann (c) 2020-2023 +Copyright Brad Neimann (c) 2020-2024 All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -5,7 +5,7 @@ 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](https://hackage.haskell.org/package/brassica) +- Can be used interactively both [online](https://bradrn.com/brassica/index.html) and as a desktop application, or non-interactively in batch mode on the command-line or as a [Haskell library](https://hackage.haskell.org/package/brassica) - Natively supports the MDF dictionary format, also used by tools including [SIL Toolbox](https://software.sil.org/toolbox/) and [Lexique Pro](https://software.sil.org/lexiquepro/) - First-class support for multigraphs - Easy control over rule application: apply sound changes sporadically, right-to-left, between words, and in many more ways @@ -13,7 +13,7 @@ - Highlight and visualise results in numerous ways - Category operations allow phonetic rules to be written in both featural and character-based ways - Support for ‘features’ lets rules easily manipulate stress, tone and other suprasegmentals -- Comes with a paradigm builder for quickly investigating inflectional and other patterns +- Comes with a [paradigm builder](https://bradrn.com/brassica/builder.html) for quickly investigating inflectional and other patterns - Rich syntax for specifying phonetic rules, including wildcards, optional elements and more And many more! diff --git a/bench/Changes.hs b/bench/Changes.hs --- a/bench/Changes.hs +++ b/bench/Changes.hs @@ -1,13 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} module Main where -import Criterion.Main (defaultMain, bench, nf, bgroup) +import Criterion.Main (defaultMain, bench, nf, bgroup, Benchmark) import Data.FileEmbed (embedFile) import Data.Text (unpack) import Data.Text.Encoding (decodeUtf8) import Brassica.SoundChange +import Brassica.SoundChange.Frontend.Internal main :: IO () main = defaultMain @@ -33,16 +35,19 @@ [ 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 + Right cs -> nf (parseTokeniseAndApplyRules + cs + manyWords + Raw + (ApplyRules NoHighlight WordsOnlyOutput "/")) + Nothing ] ] where basic = Rule { target = [Grapheme "a"] , replacement = [Grapheme "b"] - , environment = ([], []) + , environment = [([], [])] , exception = Nothing , flags = defFlags , plaintext = "a/b" @@ -50,23 +55,24 @@ complex = Rule { target = - [ Category [GraphemeEl "t", GraphemeEl "d", GraphemeEl "n"] + [ Category $ FromElements $ Left <$> ["t", "d", "n"] , Optional [Grapheme "y"] - , Category [GraphemeEl "i", GraphemeEl "e"] + , Category $ FromElements $ Left <$> ["i", "e"] ] , replacement = - [ Category [GraphemeEl "c", GraphemeEl "j", GraphemeEl "nh"] + [ Category $ FromElements $ Left <$> ["c", "j", "nh"] , Optional [Geminate] ] - , environment = - ( [Category [BoundaryEl, GraphemeEl "a", GraphemeEl "e", GraphemeEl "i"]] - , [Category [GraphemeEl "a", GraphemeEl "e", GraphemeEl "i", GraphemeEl "o", GraphemeEl "u"]] + , environment = pure + ( [Category $ FromElements $ Left <$> [GBoundary, "a", "e", "i"]] + , [Category $ FromElements $ Left <$> ["a", "e", "i", "o", "u"]] ) , exception = Nothing , flags = defFlags , plaintext = "[t d n] (y) [i e] / [č j ñ] (>) / [# a e i] _ [a e i o u]" } + benchChanges :: Rule Expanded -> PWord -> [Benchmark] 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 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.1.1 +version: 0.2.0 synopsis: Featureful sound change applier description: The Brassica library for the simulation of sound changes in historical linguistics and language construction. @@ -43,12 +43,13 @@ build-depends: base >=4.7 && <5 , containers >=0.6 && <0.7 - , deepseq >=1.4 && <1.5 - , megaparsec >=8.0 && <9.3 - , mtl >=2.2 && <2.3 + , deepseq >=1.4 && <1.6 + , megaparsec >=8.0 && <9.7 + , mtl >=2.2 && <2.4 , parser-combinators >=1.2 && <1.3 , split >=0.2 && <0.3 - , transformers >=0.5 && <0.6 + , transformers >=0.5 && <0.7 + , vector >=0.13 && <0.14 default-language: Haskell2010 @@ -62,12 +63,12 @@ , brassica , aeson ^>=2.2 , attoparsec-aeson ^>=2.2 - , bytestring >=0.10 && <0.12 + , bytestring >=0.10 && <0.13 , conduit ^>=1.3 , conduit-extra ^>=1.3 - , deepseq >=1.4 && <1.5 - , optparse-applicative ^>=0.17 - , text >=1.2 && <2.1 + , deepseq >=1.4 && <1.6 + , optparse-applicative ^>=0.17 || ^>=0.18 + , text >=1.2 && <2.2 default-language: Haskell2010 @@ -79,7 +80,7 @@ build-depends: base >=4.7 && <5 , brassica - , criterion >=1.5 && <1.6 + , criterion >=1.5 && <1.7 , file-embed >=0.0.15 && <0.0.16 , text >=1.2 && <1.3 @@ -93,7 +94,7 @@ build-depends: base >=4.7 && <5 , brassica - , criterion >=1.5 && <1.6 + , criterion >=1.5 && <1.7 default-language: Haskell2010 diff --git a/cli/Main.hs b/cli/Main.hs --- a/cli/Main.hs +++ b/cli/Main.hs @@ -33,7 +33,7 @@ .| outC where - opts = info (args <**> helper) fullDesc + opts = info (args <**> helper <**> simpleVersioner "v0.2.0") fullDesc args = batchArgs <|> serverArgs serverArgs = flag' Server (long "server" <> help "Run server (for internal use only)") @@ -42,20 +42,22 @@ (metavar "RULES" <> help "File containing sound changes") <*> flag Raw MDF (long "mdf" <> help "Parse input words in MDF format") - <*> asum - [ flag' ReportRulesApplied - (long "report" <> help "Report rules applied rather than outputting 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)") - ] + <*> (asum + [ flag' (const ReportRulesApplied) + (long "report" <> help "Report rules applied rather than outputting 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)") + ] + <*> strOption + (long "separator" <> short 's' <> value "/" <> help "Separator between multiple results (default: /)")) <*> optional (strOption (long "in" <> short 'i' <> help "File containing input words (if not specified will read from stdin)")) <*> optional (strOption @@ -83,7 +85,7 @@ processWords :: (MonadIO m, MonadThrow m) => Bool -- split into lines? - -> SoundChanges + -> SoundChanges CategorySpec Directive -> InputLexiconFormat -> ApplicationMode -> ConduitT B.ByteString B.ByteString m () @@ -101,10 +103,14 @@ Left e -> throwM e Right r -> yield r - processApplicationOutput :: ApplicationOutput PWord Statement -> Either ParseException Text + processApplicationOutput :: ApplicationOutput PWord (Statement Expanded [Grapheme]) -> 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 + processApplicationOutput (ExpandError e) = Left $ ParseException $ case e of + (NotFound s) -> "Could not find category: " ++ s + InvalidBaseValue -> "Invalid value used as base grapheme in feature definition" + MismatchedLengths -> "Mismatched lengths in feature definition" newtype ParseException = ParseException String deriving Show diff --git a/cli/Server.hs b/cli/Server.hs --- a/cli/Server.hs +++ b/cli/Server.hs @@ -18,13 +18,14 @@ import Data.Aeson.TH (deriveJSON, defaultOptions, defaultTaggedObject, constructorTagModifier, sumEncoding, tagFieldName) import Data.ByteString (toStrict) import Data.Conduit.Attoparsec (conduitParser) +import Data.Foldable (toList) import GHC.Generics (Generic) import System.IO (hSetBuffering, stdin, stdout, BufferMode(NoBuffering)) import System.Timeout import Brassica.SoundChange import Brassica.SoundChange.Frontend.Internal -import Brassica.Paradigm (applyParadigm, parseParadigm) +import Brassica.Paradigm (applyParadigm, parseParadigm, formatNested, ResultsTree (..)) data Request = ReqRules @@ -35,10 +36,12 @@ , hlMode :: HighlightMode , outMode :: OutputMode , prev :: Maybe [Component PWord] + , sep :: String } | ReqParadigm { pText :: String , input :: String + , separateLines :: Bool } deriving (Show) @@ -95,7 +98,7 @@ let mode = if report then ReportRulesApplied - else ApplyRules hlMode outMode + else ApplyRules hlMode outMode sep in case parseSoundChanges changes of Left e -> RespError $ "
" ++ errorBundlePretty e ++ "
" Right statements -> @@ -108,6 +111,10 @@ (escape $ detokeniseWords' highlightWord result) AppliedRulesTable items -> RespRules Nothing $ surroundTable $ concatMap (reportAsHtmlRows plaintext') items + ExpandError err -> RespError $ ("
"++) $ (++"
") $ case err of + (NotFound s) -> "Could not find category: " ++ s + InvalidBaseValue -> "Invalid value used as base grapheme in feature definition" + MismatchedLengths -> "Mismatched lengths in feature definition" where highlightWord (s, False) = concatWithBoundary s highlightWord (s, True) = "" ++ concatWithBoundary s ++ "" @@ -120,7 +127,11 @@ parseAndBuildParadigmWrapper ReqParadigm{..} = case parseParadigm pText of Left e -> RespError $ "
" ++ errorBundlePretty e ++ "
" - Right p -> RespParadigm $ escape $ unlines $ concatMap (applyParadigm p) $ lines input + Right p -> RespParadigm $ escape $ + (if separateLines + then unlines . toList + else formatNested id) + $ Node $ applyParadigm p <$> lines input parseAndBuildParadigmWrapper _ = error "parseAndBuildParadigmWrapper: unexpected request!" escape :: String -> String diff --git a/src/Brassica/Paradigm.hs b/src/Brassica/Paradigm.hs --- a/src/Brassica/Paradigm.hs +++ b/src/Brassica/Paradigm.hs @@ -1,6 +1,5 @@ module Brassica.Paradigm ( - -- * Types Process(..) , Affix , Grammeme(..) @@ -10,10 +9,10 @@ , FeatureName(..) , Statement(..) , Paradigm - -- * Application + , ResultsTree(..) , applyParadigm - -- * Parsing , parseParadigm + , formatNested -- ** Re-export , errorBundlePretty ) where diff --git a/src/Brassica/Paradigm/Apply.hs b/src/Brassica/Paradigm/Apply.hs --- a/src/Brassica/Paradigm/Apply.hs +++ b/src/Brassica/Paradigm/Apply.hs @@ -1,16 +1,47 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} -module Brassica.Paradigm.Apply (applyParadigm) where +module Brassica.Paradigm.Apply + ( ResultsTree(..) + , applyParadigm + , formatNested + ) where import Brassica.Paradigm.Types -import Data.List (sortOn) +import Data.Functor ((<&>)) +import Data.List (sortOn, foldl', intercalate) import Data.Maybe (mapMaybe) import Data.Ord (Down(Down)) +data ResultsTree a = Node [ResultsTree a] | Result a + deriving (Show, Functor, Foldable) + +addLevel :: (a -> [a]) -> ResultsTree a -> ResultsTree a +addLevel f (Result r) = Node $ Result <$> f r +addLevel f (Node rs) = Node $ addLevel f <$> rs + +-- | Formats a 'ResultsTree' in a nested way, where the lowest-level +-- elements are separated by one space, the second-lowest are +-- separated by one newline, the third-lowest by two newlines, and so +-- on. +formatNested :: (a -> String) -> ResultsTree a -> String +formatNested f = snd . go + where + go (Result a) = (0, f a) + go (Node rts) = + let (depths, formatted) = unzip $ go <$> rts + depth = maximum depths + separator = + if depth == 0 + then " " + else replicate depth '\n' + in (1+depth, intercalate separator formatted) + -- | Apply the given 'Paradigm' to a root, to produce all possible -- derived forms. -applyParadigm :: Paradigm -> String -> [String] +applyParadigm :: Paradigm -> String -> ResultsTree String applyParadigm p w = let fs = mapMaybe getFeature p ms = mapMaybe getMapping p @@ -21,18 +52,25 @@ getMapping (NewMapping k v) = Just (k,v) getMapping _ = Nothing - -combinations :: [Feature] -> [[Grammeme]] -combinations = go [] + +combinations :: [Feature] -> ResultsTree [Grammeme] +combinations = + (fmap.fmap) snd . foldl' go (Result []) 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 + addFeature + :: Feature + -> [(Maybe FeatureName, Grammeme)] + -> [[(Maybe FeatureName, Grammeme)]] + addFeature (Feature c n gs) acc + | satisfied (flip lookup acc . Just) c + = gs <&> \g -> (n, g):acc + | otherwise + = [acc] + + go :: ResultsTree [(Maybe FeatureName, Grammeme)] + -> Feature + -> ResultsTree [(Maybe FeatureName, Grammeme)] + go rt f = addLevel (addFeature f) rt satisfied :: (FeatureName -> Maybe Grammeme) 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 @@ -57,8 +57,8 @@ import Control.Applicative ((<|>)) import Control.Category ((>>>)) +import Control.Monad ((>=>), join) -- needed for mtl>=2.3 import Data.Containers.ListUtils (nubOrd) -import Data.Function ((&)) import Data.Functor ((<&>)) import Data.Maybe (maybeToList, fromMaybe, listToMaybe, mapMaybe) import GHC.Generics (Generic) @@ -128,13 +128,17 @@ instance Semigroup MatchOutput where (MatchOutput a1 b1 c1) <> (MatchOutput a2 b2 c2) = MatchOutput (a1++a2) (b1++b2) (c1++c2) +zipWith' :: [a] -> [b] -> (a -> b -> c) -> [c] +zipWith' xs ys f = zipWith f xs ys + -- | 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 +match :: forall a t. + OneOf a 'Target 'Env => MatchOutput -- ^ The previous 'MatchOutput' -> Maybe Grapheme -- ^ The previously-matched grapheme, if any. (Used to match a 'Geminate'.) - -> Lexeme a -- ^ The lexeme to match. + -> Lexeme Expanded a -- ^ The lexeme to match. -> MultiZipper t Grapheme -- ^ The 'MultiZipper' to match against. -> [(MatchOutput, MultiZipper t Grapheme)] -- ^ The output: a tuple @(g, mz)@ as described below. @@ -152,26 +156,21 @@ [] -> error "match: Kleene should never fail" 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 (matchCategoryEl mz) - -- ...get the index of each match... - & zipWith (\i m -> fmap (i,) m) [0..] - -- ...and take all matches - & (>>= maybeToList) - & fmap (\(i, (g, mz')) -> (out <> MatchOutput [i] [] g, mz')) +match out prev (Category (FromElements gs)) mz = + concat $ zipWith' gs [0..] $ \e i -> + first (<> MatchOutput [i] [] []) <$> + case e of + Left g -> match out prev (Grapheme g :: Lexeme Expanded a) mz + Right ls -> matchMany out prev ls mz match out prev Geminate mz = case prev of Nothing -> [] Just prev' -> (out <> MatchOutput [] [] [prev'],) <$> maybeToList (matchGrapheme prev' mz) -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 +match out prev (Backreference i (FromElements gs)) mz = do + e <- maybeToList $ + (gs !?) =<< matchedCatIxs out !? (i-1) + case e of + Left g -> match out prev (Grapheme g :: Lexeme Expanded a) mz + Right ls -> matchMany out prev ls mz matchGrapheme :: Grapheme -> MultiZipper t Grapheme -> Maybe (MultiZipper t Grapheme) matchGrapheme g = matchGraphemeP (==g) @@ -186,7 +185,7 @@ matchMany :: OneOf a 'Target 'Env => MatchOutput -> Maybe Grapheme - -> [Lexeme a] + -> [Lexeme Expanded a] -> MultiZipper t Grapheme -> [(MatchOutput, MultiZipper t Grapheme)] matchMany out _ [] mz = [(out, mz)] @@ -197,7 +196,7 @@ -- | 'matchMany' without any previous match output. matchMany' :: OneOf a 'Target 'Env => Maybe Grapheme - -> [Lexeme a] + -> [Lexeme Expanded a] -> MultiZipper t Grapheme -> [(MatchOutput, MultiZipper t Grapheme)] matchMany' = matchMany (MatchOutput [] [] []) @@ -243,7 +242,7 @@ -- 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. + -> [Lexeme Expanded 'Replacement] -- ^ The 'Lexeme's specifying the replacement. -> MultiZipper t Grapheme -> [MultiZipper t Grapheme] mkReplacement out = \ls -> fmap (fst . snd) . go startIxs ls . (,Nothing) @@ -252,7 +251,7 @@ go :: ReplacementIndices - -> [Lexeme 'Replacement] + -> [Lexeme Expanded 'Replacement] -> (MultiZipper t Grapheme, Maybe Grapheme) -> [(ReplacementIndices, (MultiZipper t Grapheme, Maybe Grapheme))] go ixs [] (mz, prev) = [(ixs, (mz, prev))] @@ -264,19 +263,22 @@ replaceLex :: ReplacementIndices - -> Lexeme 'Replacement + -> Lexeme Expanded 'Replacement -> MultiZipper t Grapheme -> Maybe Grapheme -> [(ReplacementIndices, (MultiZipper t Grapheme, Maybe Grapheme))] replaceLex ixs (Grapheme g) mz _prev = [(ixs, (insert g mz, Just g))] - replaceLex ixs (Category gs) mz _prev = + replaceLex ixs (Category (FromElements gs)) mz prev = case advanceCategory ixs numCatsMatched of (CategoryNumber ci, ixs') -> let i = matchedCatIxs out !! ci in case gs !? i of - Just g -> [(ixs', (insert g mz, Just g))] + Just (Left g) -> [(ixs', (insert g mz, Just g))] + Just (Right ls) -> go ixs' ls (mz, prev) Nothing -> [(ixs', (insert (GMulti "\xfffd") mz, Nothing))] -- Unicode replacement character - (Nondeterministic, ixs') -> gs <&> \g -> (ixs', (insert g mz, Just g)) + (Nondeterministic, ixs') -> gs >>= \case + Left g -> [(ixs', (insert g mz, Just g))] + Right ls -> go ixs' ls (mz, prev) replaceLex ixs (Optional ls) mz prev = let (co, ixs') = advanceOptional ixs in case matchedOptionals out !? co of @@ -304,12 +306,15 @@ -- '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 + :: [Lexeme Expanded 'Target] + -> Environment Expanded + -> MultiZipper RuleTag Grapheme -> [Int] exceptionAppliesAtPoint target (ex1, ex2) mz = fmap fst $ flip runRuleAp mz $ do - _ <- RuleAp $ matchMany' Nothing ex1 + ex1Out <- RuleAp $ matchMany' Nothing ex1 pos <- gets curPos MatchOutput{matchedGraphemes} <- RuleAp $ matchMany' Nothing target - _ <- RuleAp $ matchMany' (listToMaybe matchedGraphemes) ex2 + _ <- RuleAp $ matchMany ex1Out (listToMaybe matchedGraphemes) ex2 return pos -- | Given a target and environment, determine if they rule @@ -318,12 +323,12 @@ -- t'Grapheme's, and @is@ is a list of indices, one for each -- 'Category' lexeme matched. matchRuleAtPoint - :: [Lexeme 'Target] - -> Environment + :: [Lexeme Expanded 'Target] + -> Environment Expanded -> MultiZipper RuleTag Grapheme -> [(MatchOutput, MultiZipper RuleTag Grapheme)] matchRuleAtPoint target (env1,env2) mz = flip runRuleAp mz $ do - _ <- RuleAp $ matchMany' Nothing env1 + env1Out <- 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# @@ -333,12 +338,12 @@ modify $ tag TargetStart matchResult <- RuleAp $ matchMany' Nothing target modify $ tag TargetEnd - _ <- RuleAp $ matchMany' (listToMaybe $ matchedGraphemes matchResult) env2 + _ <- RuleAp $ matchMany env1Out (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 :: Rule Expanded -> StateT (MultiZipper RuleTag Grapheme) [] Bool applyOnce r@Rule{target, replacement, exception} = modify (tag AppStart) >> go (environment r) where @@ -355,7 +360,7 @@ if maybe True (`elem` exs) p then return False else do - modifyMay $ modifyBetween (TargetStart, TargetEnd) $ const [] + modifyMay $ delete (TargetStart, TargetEnd) modifyMay $ seek TargetStart modifyM $ mkReplacement out replacement return True @@ -363,7 +368,11 @@ -- | 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 + :: Bool + -> Rule Expanded + -> MultiZipper RuleTag Grapheme + -> Maybe (MultiZipper RuleTag Grapheme) setupForNextApplication success r@Rule{flags=Flags{applyDirection}} = fmap untag . case applyDirection of RTL -> seek AppStart >=> bwd @@ -379,7 +388,7 @@ -- | 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 :: Rule Expanded -> MultiZipper RuleTag Grapheme -> [MultiZipper RuleTag Grapheme] applyRule r = \mz -> -- use a lambda so mz isn't shadowed in the where block let startingPos = case applyDirection $ flags r of LTR -> toBeginning mz @@ -403,23 +412,26 @@ -- | 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 $ \case +checkGraphemes :: [Grapheme] -> MultiZipper RuleTag Grapheme -> MultiZipper RuleTag Grapheme +checkGraphemes 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'. -applyStatement :: Statement -> MultiZipper RuleTag Grapheme -> [MultiZipper RuleTag Grapheme] +applyStatement + :: Statement Expanded [Grapheme] + -> MultiZipper RuleTag Grapheme + -> [MultiZipper RuleTag Grapheme] applyStatement (RuleS r) mz = applyRule r mz -applyStatement (CategoriesDeclS gs) mz = [checkGraphemes gs mz] +applyStatement (DirectiveS 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] +applyRuleStr :: Rule Expanded -> PWord -> [PWord] -- Note: 'fromJust' is safe here as 'apply' should always succeed applyRuleStr r s = nubOrd $ fmap toList $ applyRule r $ fromListStart s @@ -428,7 +440,7 @@ -- 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 :: Statement Expanded [Grapheme] -> PWord -> [PWord] applyStatementStr st = addBoundaries >>> fromListStart @@ -517,14 +529,20 @@ -- | 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 + :: Statement Expanded [Grapheme] + -> PWord + -> [LogItem (Statement Expanded [Grapheme])] applyStatementWithLog st w = case applyStatementStr st w of [w'] -> if w' == w then [] else [ActionApplied st w w'] r -> ActionApplied st w <$> r -- | 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 + :: SoundChanges Expanded [Grapheme] + -> PWord + -> [[LogItem (Statement Expanded [Grapheme])]] applyChangesWithLog [] _ = [[]] applyChangesWithLog (st:sts) w = case applyStatementWithLog st w of @@ -534,11 +552,14 @@ -- | Apply 'SoundChanges' to a word, returning an 'PWordLog' -- for each possible result. -applyChangesWithLogs :: SoundChanges -> PWord -> [PWordLog Statement] +applyChangesWithLogs + :: SoundChanges Expanded [Grapheme] + -> PWord + -> [PWordLog (Statement Expanded [Grapheme])] applyChangesWithLogs scs w = mapMaybe toPWordLog $ applyChangesWithLog scs w -- | Apply a set of 'SoundChanges' to a word. -applyChanges :: SoundChanges -> PWord -> [PWord] +applyChanges :: SoundChanges Expanded [Grapheme] -> PWord -> [PWord] applyChanges sts w = lastOutput <$> applyChangesWithLog sts w where @@ -549,11 +570,11 @@ -- 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 :: SoundChanges Expanded [Grapheme] -> 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 + ActionApplied{action=DirectiveS _} -> True diff --git a/src/Brassica/SoundChange/Apply/Internal/MultiZipper.hs b/src/Brassica/SoundChange/Apply/Internal/MultiZipper.hs --- a/src/Brassica/SoundChange/Apply/Internal/MultiZipper.hs +++ b/src/Brassica/SoundChange/Apply/Internal/MultiZipper.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TupleSections #-} {-| __Warning:__ This module is __internal__, and does __not__ follow the Package Versioning Policy. It may be useful for extending @@ -37,13 +38,16 @@ , query , untag , untagWhen - , modifyBetween + , delete , extend , extend' ) where import Control.Applicative (Alternative((<|>))) import Data.Foldable (Foldable(foldl')) +import Data.Vector ((!?), (!)) +import Data.Vector.Mutable (write) +import qualified Data.Vector as V import qualified Data.Map.Strict as M -- | A 'MultiZipper' is a list zipper (list+current index), with the @@ -64,25 +68,25 @@ -- '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) +data MultiZipper t a = MultiZipper (V.Vector 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 +fromListStart as = MultiZipper (V.fromList 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 + if invalid pos (length as) then Nothing - else Just $ MultiZipper as pos M.empty + else Just $ MultiZipper (V.fromList as) pos M.empty -- | Get the list stored in a 'MultiZipper'. toList :: MultiZipper t a -> [a] -toList (MultiZipper as _ _) = as +toList (MultiZipper as _ _) = V.toList as -- | The current position of the 'MultiZipper'. curPos :: MultiZipper t a -> Int @@ -108,10 +112,7 @@ -- 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 +value (MultiZipper as pos _) = as !? pos -- | @valueN n mz@ returns the next @n@ elements of @mz@ starting from -- the current position, as well as returning a new 'MultiZipper' @@ -122,9 +123,9 @@ 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 + if invalid pos' (V.length as) || i < 0 then Nothing - else Just (take i $ drop pos as, MultiZipper as pos' ts) + else Just (take i $ drop pos $ V.toList as, MultiZipper as pos' ts) -- | Given a tag, return its position locationOf :: Ord t => t -> MultiZipper t a -> Maybe Int @@ -136,7 +137,7 @@ seekIx :: Int -> MultiZipper t a -> Maybe (MultiZipper t a) seekIx i (MultiZipper as _ ts) = - if invalid i as + if invalid i (V.length as) then Nothing else Just (MultiZipper as i ts) @@ -159,9 +160,7 @@ -- 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) + fmap (,MultiZipper as (pos+1) ts) (as!?pos) -- | Move the 'MultiZipper' to be at the specified tag. Returns -- 'Nothing' if that tag is not present. @@ -186,8 +185,11 @@ -- | 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 + case V.splitAt pos as of + (as1, as2) -> MultiZipper + (as1 V.++ V.cons a as2) + (pos+1) + (correctIxsFrom pos (+1) ts) -- | Insert multiple elements at point and move after them. A simple -- wrapper around 'insert'. @@ -204,11 +206,9 @@ go _ (-1) = Nothing go as pos | pos == length as = go as (pos-1) - | otherwise = case p (as !! pos) of + | 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" + Just a' -> Just $ V.modify (\v -> write v pos a') as -- | Set a tag at the current position. tag :: Ord t => t -> MultiZipper t a -> MultiZipper t a @@ -217,7 +217,7 @@ -- | 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 + if invalid i (length as) then Nothing else Just $ MultiZipper as pos $ M.insert t i ts @@ -229,25 +229,23 @@ 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 +-- | Delete the portion of a 'MultiZipper' between the selected tags. +-- Returns 'Nothing' if a nonexistent tag is selected, else returns +-- the modified 'MultiZipper'. +delete + :: Ord t + => (t, t) + -- ^ Selected tags. Note that the resulting interval + -- will be [inclusive, exclusive). + -> MultiZipper t a + -> Maybe (MultiZipper t a) +delete (t1, t2) 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) + let (before_t1, after_t1) = V.splitAt i1 as + (cut_part, after_t2) = V.splitAt (i2-i1) after_t1 + removed = length cut_part + pos' = pos - removed + return $ MultiZipper (before_t1 V.++ after_t2) pos' (correctIxsFrom i2 (subtract removed) ts) where correctOrder (m, n) = if m <= n then (m, n) else (n, m) @@ -261,21 +259,18 @@ 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] + as' = V.map (\i -> f $ MultiZipper as i ts) $ V.enumFromN 0 (length as) -- | 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] + as' = V.map (\i -> f $ MultiZipper as i ts) $ V.enumFromN 0 (length as + 1) -- 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) +invalid :: Int -> Int -> Bool +invalid pos len = (pos < 0) || (pos > len) 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 --- a/src/Brassica/SoundChange/Category.hs +++ b/src/Brassica/SoundChange/Category.hs @@ -1,110 +1,163 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} module Brassica.SoundChange.Category - ( - -- * Category construction - Category(..) - , CategoryState(..) - , categorise - -- * Category expansion - , Categories + ( Categories , Brassica.SoundChange.Category.lookup - , mapCategories - , expand - -- * Obtaining values - , bake , values + , ExpandError(..) + , expand + , expandRule + , extend + , expandSoundChanges ) where -import Data.Coerce -import Data.List (intersect) -import Data.Maybe (fromMaybe) - -import qualified Data.Map.Strict as M +import Prelude hiding (lookup) +import Control.DeepSeq (NFData) +import Control.Monad (foldM, unless) +import Control.Monad.State.Strict (StateT, evalStateT, lift, get, put) import Data.Containers.ListUtils (nubOrd) +import Data.List (intersect, transpose, foldl') +import Data.Maybe (mapMaybe) +import GHC.Generics (Generic) --- | 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 +import qualified Data.Map.Strict as M --- | 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) +import Brassica.SoundChange.Types +import Data.Traversable (for) -- | A map from names to the (expanded) categories they -- reference. Used to resolve cross-references between categories. -type Categories 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 +type Categories = M.Map String (Expanded 'AnyPart) --- | 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 +-- | Lookup a category name in 'Categories'. +lookup :: String -> Categories -> Maybe (Expanded a) +lookup = (fmap generaliseExpanded .) . M.lookup --- | 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 +-- | Returns a list of every value mentioned in a set of +-- 'Categories' +values :: Categories -> [Either Grapheme [Lexeme Expanded 'AnyPart]] +values = nubOrd . concatMap elements . M.elems --- | 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) +-- Errors which can be emitted while inlining or expanding category +-- definitions. +data ExpandError + = NotFound String + -- ^ A category with that name was not found + | InvalidBaseValue + -- ^ A 'Lexeme' was used as a base value in a feature + | MismatchedLengths + -- ^ A 'FeatureSpec' contained a mismatched number of values + deriving (Show, Generic, NFData) --- | Given an 'Expanded' category, return the list of values which it +-- | Given a 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 +expand :: Categories -> CategorySpec a -> Either ExpandError (Expanded a) +expand cs (MustInline g) = maybe (Left $ NotFound g) Right $ lookup g cs +expand cs (CategorySpec spec) = FromElements <$> foldM go [] spec where - difference l m = filter (not . (`elem` m)) l + go es (modifier, e) = do + new <- case e of + Left (GMulti g) + | Just (FromElements c) <- lookup g cs + -> pure c + | otherwise -> pure [Left (GMulti g)] + Left GBoundary -> pure [Left GBoundary] + Right ls -> pure . Right <$> traverse (expandLexeme cs) ls + pure $ case modifier of + Union -> es ++ new + Intersect -> es `intersect` new + Subtract -> es `subtractAll` new --- | 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 + -- NB. normal (\\) only removes the first matching element + subtractAll xs ys = filter (`notElem` ys) xs + +expandLexeme :: Categories -> Lexeme CategorySpec a -> Either ExpandError (Lexeme Expanded a) +expandLexeme cs (Grapheme (GMulti g)) + | Just (g', '~') <- unsnoc g + = Right $ Grapheme $ GMulti g' + | otherwise = Right $ + case lookup g cs of + Just c -> Category c + Nothing -> Grapheme (GMulti g) where - 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 + -- taken from base-4.19 + unsnoc :: [a] -> Maybe ([a], a) + unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing + {-# INLINABLE unsnoc #-} + +expandLexeme _ (Grapheme GBoundary) = Right $ Grapheme GBoundary +expandLexeme cs (Category c) = Category <$> expand cs c +expandLexeme cs (Optional ls) = Optional <$> traverse (expandLexeme cs) ls +expandLexeme _ Metathesis = Right Metathesis +expandLexeme _ Geminate = Right Geminate +expandLexeme cs (Wildcard l) = Wildcard <$> expandLexeme cs l +expandLexeme cs (Kleene l) = Kleene <$> expandLexeme cs l +expandLexeme _ Discard = Right Discard +expandLexeme cs (Backreference i c) = Backreference i <$> expand cs c +expandLexeme cs (Multiple c) = Multiple <$> expand cs c + +expandRule :: Categories -> Rule CategorySpec -> Either ExpandError (Rule Expanded) +expandRule cs r = Rule + <$> traverse (expandLexeme cs) (target r) + <*> traverse (expandLexeme cs) (replacement r) + <*> traverse expandEnvironment (environment r) + <*> traverse expandEnvironment (exception r) + <*> pure (flags r) + <*> pure (plaintext r) + where + expandEnvironment (e1, e2) = (,) + <$> traverse (expandLexeme cs) e1 + <*> traverse (expandLexeme cs) e2 + +extend :: Categories -> Directive -> Either ExpandError Categories +extend cs' (Categories overwrite defs) = + foldM go (if overwrite then M.empty else cs') defs + where + go :: Categories -> CategoryDefinition -> Either ExpandError Categories + go cs (DefineCategory name val) = flip (M.insert name) cs <$> expand cs val + go cs (DefineFeature spec) = do + baseValues <- expand cs $ featureBaseValues spec + derivedCats <- traverse (traverse $ expand cs) $ featureDerived spec + + baseValues' <- for (elements baseValues) $ \case + Left (GMulti g) -> Right g + _ -> Left InvalidBaseValue + let baseLen = length baseValues' + derivedValues = elements . snd <$> derivedCats + unless (all ((==baseLen) . length) derivedValues) $ + Left MismatchedLengths + + let features = zipWith + (\base ds -> (base, FromElements $ Left (GMulti base) : ds)) + baseValues' + (transpose derivedValues) + newCats = + maybe [] (pure . (,baseValues)) (featureBaseName spec) + ++ derivedCats + ++ features + Right $ foldl' (flip $ uncurry M.insert) cs newCats + +expandSoundChanges + :: SoundChanges CategorySpec Directive + -> Either ExpandError (SoundChanges Expanded [Grapheme]) +expandSoundChanges = flip evalStateT M.empty . traverse go + where + go :: Statement CategorySpec Directive + -> StateT Categories (Either ExpandError) (Statement Expanded [Grapheme]) + go (RuleS r) = do + cs <- get + lift $ RuleS <$> expandRule cs r + go (DirectiveS d) = do + cs <- get + cs' <- lift $ extend cs d + put cs' + pure $ DirectiveS $ mapMaybe left $ values cs' + + left (Left l) = Just l + left (Right _) = Nothing diff --git a/src/Brassica/SoundChange/Frontend/Internal.hs b/src/Brassica/SoundChange/Frontend/Internal.hs --- a/src/Brassica/SoundChange/Frontend/Internal.hs +++ b/src/Brassica/SoundChange/Frontend/Internal.hs @@ -21,12 +21,13 @@ import Brassica.MDF (MDF, parseMDFWithTokenisation, componentiseMDF, componentiseMDFWordsOnly, duplicateEtymologies) import Brassica.SoundChange.Apply import Brassica.SoundChange.Apply.Internal (applyChangesWithLog, toPWordLog) +import Brassica.SoundChange.Category import Brassica.SoundChange.Tokenise import Brassica.SoundChange.Types -- | Rule application mode of the SCA. data ApplicationMode - = ApplyRules HighlightMode OutputMode + = ApplyRules HighlightMode OutputMode String | ReportRulesApplied deriving (Show, Eq) @@ -77,7 +78,7 @@ toEnum _ = undefined tokenisationModeFor :: ApplicationMode -> TokenisationMode -tokenisationModeFor (ApplyRules _ MDFOutputWithEtymons) = AddEtymons +tokenisationModeFor (ApplyRules _ MDFOutputWithEtymons _) = AddEtymons tokenisationModeFor _ = Normal -- | Output of a single application of rules to a wordlist: either a @@ -87,6 +88,7 @@ = HighlightedWords [Component (a, Bool)] | AppliedRulesTable [PWordLog r] | ParseError (ParseErrorBundle String Void) + | ExpandError ExpandError deriving (Show, Generic, NFData) -- | Kind of input: either a raw wordlist, or an MDF file. @@ -122,7 +124,7 @@ tokeniseAccordingToInputFormat :: InputLexiconFormat -> TokenisationMode - -> SoundChanges + -> SoundChanges Expanded [Grapheme] -> String -> Either (ParseErrorBundle String Void) (ParseOutput PWord) tokeniseAccordingToInputFormat Raw _ cs = @@ -142,37 +144,40 @@ -- wordlist and a list of sound changes, returns the result of running -- the changes in the specified mode. parseTokeniseAndApplyRules - :: SoundChanges -- ^ changes + :: SoundChanges CategorySpec Directive -- ^ changes -> String -- ^ words -> InputLexiconFormat -> ApplicationMode -> Maybe [Component PWord] -- ^ previous results - -> ApplicationOutput PWord Statement + -> ApplicationOutput PWord (Statement Expanded [Grapheme]) parseTokeniseAndApplyRules statements ws intype mode prev = - let tmode = tokenisationModeFor mode in - case tokeniseAccordingToInputFormat intype tmode statements ws of - Left e -> ParseError e - Right toks - | ws' <- getParsedWords toks - -> case mode of - ReportRulesApplied -> - AppliedRulesTable $ mapMaybe toPWordLog $ concat $ - getWords $ componentise WordsOnlyOutput [] $ - applyChangesWithLog statements <$> toks - ApplyRules DifferentToLastRun mdfout -> - let result = concatMap (splitMultipleResults " ") $ - 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 (fmap (pure . (,False)) ws') $ - applyChangesWithChanges statements <$> toks - ApplyRules NoHighlight mdfout -> - HighlightedWords $ (fmap.fmap) (,False) $ concatMap (splitMultipleResults " ") $ - componentise mdfout (fmap pure ws') $ - applyChanges statements <$> toks + case expandSoundChanges statements of + Left e -> ExpandError e + Right statements' -> + let tmode = tokenisationModeFor mode in + case tokeniseAccordingToInputFormat intype tmode statements' ws of + Left e -> ParseError e + Right toks + | ws' <- getParsedWords toks + -> case mode of + ReportRulesApplied -> + AppliedRulesTable $ mapMaybe toPWordLog $ concat $ + getWords $ componentise WordsOnlyOutput [] $ + applyChangesWithLog statements' <$> toks + ApplyRules DifferentToLastRun mdfout sep -> + let result = concatMap (splitMultipleResults sep) $ + componentise mdfout (fmap pure ws') $ applyChanges statements' <$> toks + in HighlightedWords $ + zipWithComponents result (fromMaybe [] prev) [] $ \thisWord prevWord -> + (thisWord, thisWord /= prevWord) + ApplyRules DifferentToInput mdfout sep -> + HighlightedWords $ concatMap (splitMultipleResults sep) $ + componentise mdfout (fmap (pure . (,False)) ws') $ + applyChangesWithChanges statements' <$> toks + ApplyRules NoHighlight mdfout sep -> + HighlightedWords $ (fmap.fmap) (,False) $ concatMap (splitMultipleResults sep) $ + componentise mdfout (fmap pure ws') $ + applyChanges statements' <$> toks 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,14 +1,12 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} module Brassica.SoundChange.Parse ( parseRule - , parseRuleWithCategories , parseSoundChanges -- ** Re-export , errorBundlePretty @@ -16,28 +14,22 @@ 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 Control.Monad (void, guard) 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) +type Parser = Parsec Void String class ParseLexeme (a :: LexemeType) where - parseLexeme :: Parser (Lexeme a) + parseLexeme :: Parser (Lexeme CategorySpec a) -- space consumer which does not match newlines sc :: Parser () @@ -66,171 +58,140 @@ guard $ n>0 pure n -parseGrapheme :: Parser (Grapheme, Bool) -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 $ + GBoundary <$ char '#' + <|> GMulti <$> parseGrapheme' -parseGrapheme' :: Parser Grapheme -parseGrapheme' = lexeme $ GMulti <$> takeWhile1P Nothing (not . ((||) <$> isSpace <*> (=='='))) +parseGrapheme' :: Parser String +parseGrapheme' = lexeme $ do + star <- optional (char '*') + rest <- takeWhile1P Nothing (not . ((||) <$> isSpace <*> (`elem` keyChars))) + nocat <- optional (char '~') + pure . + maybe id (const ('*':)) star . + maybe id (const (++"~")) nocat + $ rest -data CategoryModification - = Union Grapheme - | Intersect Grapheme - | Subtract Grapheme +parseExplicitCategory :: ParseLexeme a => Parser (Lexeme CategorySpec a) +parseExplicitCategory = Category <$> parseExplicitCategory' -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 c +parseExplicitCategory' :: ParseLexeme a => Parser (CategorySpec a) +parseExplicitCategory' = + CategorySpec <$> (symbol "[" *> someTill parseCategoryModification (symbol "]")) -parseCategory :: ParseLexeme a => Parser (Lexeme a) -parseCategory = Category <$> parseCategory' +-- This is unused currently, but convenient to keep around just in case +-- parseCategory :: ParseLexeme a => Parser (Lexeme CategorySpec a) +-- parseCategory = Category <$> parseCategory' -parseCategory' :: Parser [Grapheme] -parseCategory' = do - mods <- symbol "[" *> someTill parseCategoryModification (symbol "]") - cats <- gets categories - return $ C.bake $ - C.expand cats (toCategory mods) +parseCategory' :: ParseLexeme a => Parser (CategorySpec a) +parseCategory' = parseExplicitCategory' <|> MustInline <$> parseGrapheme' -parseCategoryStandalone :: Parser (Grapheme, C.Category 'C.Expanded Grapheme) +parseCategoryStandalone + :: Parser (String, CategorySpec 'AnyPart) parseCategoryStandalone = do g <- parseGrapheme' _ <- symbol "=" - -- Use Target here because it only allows graphemes, not boundaries mods <- some parseCategoryModification - cats <- gets categories - return (g, C.expand cats $ toCategory mods) + return (g, CategorySpec mods) -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 - cats <- gets categories - let plainCat = C.expand cats $ 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) +parseFeature :: Parser FeatureSpec +parseFeature = do + _ <- symbol "feature" + featureBaseName <- optional $ try $ parseGrapheme' <* symbol "=" + featureBaseValues <- CategorySpec <$> some parseCategoryModification + featureDerived <- some (symbol "/" *> parseCategoryStandalone) <* scn + pure FeatureSpec { featureBaseName, featureBaseValues, featureDerived } -parseCategoryModification :: Parser CategoryModification -parseCategoryModification = parsePrefix <*> (fst <$> parseGrapheme) +parseCategoryModification + :: ParseLexeme a + => Parser (CategoryModification, Either Grapheme [Lexeme CategorySpec a]) +parseCategoryModification = (,) + <$> parsePrefix + <*> ( (Right <$> (symbol "{" *> manyTill parseLexeme (symbol "}"))) + <|> (Left <$> parseGrapheme)) where parsePrefix = (Intersect <$ char '+') <|> (Subtract <$ char '-') <|> pure Union -toCategory :: [CategoryModification] -> C.Category 'C.Unexpanded Grapheme -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 +parseDirective :: Parser Directive +parseDirective = do + overwrite <- isJust <$> optional (symbol "new") + _ <- symbol "categories" <* scn + cs <- some $ + DefineFeature <$> parseFeature <|> + uncurry DefineCategory <$> (try parseCategoryStandalone <* scn) + _ <- symbol "end" <* scn + pure $ Categories overwrite cs -parseOptional :: ParseLexeme a => Parser (Lexeme a) +parseOptional :: ParseLexeme a => Parser (Lexeme CategorySpec a) parseOptional = Optional <$> between (symbol "(") (symbol ")") (some parseLexeme) -parseGeminate :: Parser (Lexeme a) +parseGeminate :: Parser (Lexeme CategorySpec a) parseGeminate = Geminate <$ symbol ">" -parseMetathesis :: Parser (Lexeme 'Replacement) +parseMetathesis :: Parser (Lexeme CategorySpec 'Replacement) parseMetathesis = Metathesis <$ symbol "\\" -parseWildcard :: (ParseLexeme a, OneOf a 'Target 'Env) => Parser (Lexeme a) +parseWildcard :: (ParseLexeme a, OneOf a 'Target 'Env) => Parser (Lexeme CategorySpec a) parseWildcard = Wildcard <$> (symbol "^" *> parseLexeme) -parseDiscard :: Parser (Lexeme 'Replacement) +parseDiscard :: Parser (Lexeme CategorySpec 'Replacement) parseDiscard = Discard <$ symbol "~" -parseKleene :: OneOf a 'Target 'Env => Lexeme a -> Parser (Lexeme a) -parseKleene l = (Kleene l <$ symbol "*") <|> pure l +parseKleene :: OneOf a 'Target 'Env => Lexeme CategorySpec a -> Parser (Lexeme CategorySpec a) +parseKleene l = + try (lexeme $ Kleene l <$ char '*' <* notFollowedBy parseGrapheme') + <|> pure l -parseMultiple :: Parser (Lexeme 'Replacement) +parseMultiple :: Parser (Lexeme CategorySpec '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 +parseBackreference :: forall a. ParseLexeme a => Parser (Lexeme CategorySpec a) +parseBackreference = Backreference <$> (symbol "@" *> nonzero) <*> parseCategory' instance ParseLexeme 'Target where parseLexeme = asum - [ parseCategory + [ parseExplicitCategory , parseOptional , parseGeminate , parseWildcard , parseBackreference - , parseGraphemeOrCategory + , Grapheme <$> parseGrapheme ] >>= parseKleene instance ParseLexeme 'Replacement where parseLexeme = asum - [ parseCategory + [ parseExplicitCategory , parseOptional , parseMetathesis , parseDiscard , parseGeminate , parseMultiple , parseBackreference - , parseGraphemeOrCategory + , Grapheme <$> parseGrapheme ] instance ParseLexeme 'Env where parseLexeme = asum - [ parseCategory + [ parseExplicitCategory , parseOptional , parseGeminate , parseWildcard - , parseGraphemeOrCategory + , parseBackreference + , Grapheme <$> parseGrapheme ] >>= parseKleene -parseLexemes :: ParseLexeme a => Parser [Lexeme a] +instance ParseLexeme 'AnyPart where + parseLexeme = asum + [ parseExplicitCategory + , parseOptional + , Grapheme <$> parseGrapheme + ] + +parseLexemes :: ParseLexeme a => Parser [Lexeme CategorySpec a] parseLexemes = many parseLexeme parseFlags :: Parser Flags @@ -240,7 +201,7 @@ <*> toPermutation (isJust <$> optional (symbol "-1")) <*> toPermutation (isJust <$> optional (symbol "-?")) -ruleParser :: Parser Rule +ruleParser :: Parser (Rule CategorySpec) ruleParser = do -- This is an inlined version of 'match' from @megaparsec@; -- 'match' itself would be tricky to use here, since it would need @@ -275,19 +236,14 @@ -- | 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 +-- For details on the syntax, refer to . +parseRule :: String -> Either (ParseErrorBundle String Void) (Rule CategorySpec) +parseRule = runParser (scn *> ruleParser <* eof) "" -- | Parse a list of 'SoundChanges'. -parseSoundChanges :: String -> Either (ParseErrorBundle String Void) SoundChanges -parseSoundChanges s = flip evalState (Config M.empty) $ runParserT (scn *> parser <* eof) "" s +parseSoundChanges :: String -> Either (ParseErrorBundle String Void) (SoundChanges CategorySpec Directive) +parseSoundChanges = runParser (scn *> parser <* eof) "" where parser = many $ - CategoriesDeclS <$> categoriesDeclParse + DirectiveS <$> parseDirective <|> RuleS <$> ruleParser diff --git a/src/Brassica/SoundChange/Tokenise.hs b/src/Brassica/SoundChange/Tokenise.hs --- a/src/Brassica/SoundChange/Tokenise.hs +++ b/src/Brassica/SoundChange/Tokenise.hs @@ -154,8 +154,8 @@ -- | Given a list of sound changes, extract the list of multigraphs -- defined in the first categories declaration of the 'SoundChange's. -findFirstCategoriesDecl :: SoundChanges -> [String] -findFirstCategoriesDecl (CategoriesDeclS (CategoriesDecl gs):_) = +findFirstCategoriesDecl :: SoundChanges c [Grapheme] -> [String] +findFirstCategoriesDecl (DirectiveS gs:_) = mapMaybe (\case GBoundary -> Nothing; GMulti m -> Just m) gs @@ -166,5 +166,5 @@ -- like @'withFirstCategoriesDecl' 'tokeniseWords' changes words@ (to -- tokenise using the graphemes from the first categories declaration) -- and so on. -withFirstCategoriesDecl :: ([String] -> t) -> SoundChanges -> t +withFirstCategoriesDecl :: ([String] -> t) -> SoundChanges c [Grapheme] -> 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 @@ -10,6 +10,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} @@ -28,23 +29,35 @@ , Lexeme(..) , pattern Boundary , LexemeType(..) + , generalise + -- * Categories + , mapCategory + , mapCategoryA + , Expanded(..) + , generaliseExpanded -- * Rules , Rule(..) , Environment , Direction(..) , Flags(..) , defFlags - -- * Categories and statements - , CategoriesDecl(..) + -- * Statements , Statement(..) , plaintext' , SoundChanges + -- * Directives + , CategoryModification(..) + , CategorySpec(..) + , FeatureSpec(..) + , CategoryDefinition(..) + , Directive(..) -- * Utility , OneOf ) where import Control.DeepSeq (NFData(..)) import Data.Kind (Constraint) +import Data.String (IsString(..)) import GHC.Generics (Generic) import GHC.OldList (dropWhileEnd) import GHC.TypeLits @@ -72,6 +85,9 @@ | GBoundary -- ^ A non-letter element representing a word boundary which sound changes can manipulate deriving (Eq, Ord, Show, Generic, NFData) +instance IsString Grapheme where + fromString = GMulti + -- | 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'@. @@ -100,43 +116,94 @@ 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 +-- target, the replacement or the environment, or in any of those. +data LexemeType = Target | Replacement | Env | AnyPart -- | 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 +-- variable @a@ specifies where each different variety of 'Lexeme' may +-- occur. 'Lexeme's are also parameterised by their category type, +-- which may be 'Expanded' or something else. +data Lexeme category (a :: LexemeType) where -- | In Brassica sound-change syntax, one or more letters without intervening whitespace, -- or a word boundary specified as @#@ - Grapheme :: Grapheme -> Lexeme a + Grapheme :: Grapheme -> Lexeme category a -- | In Brassica sound-change syntax, delimited by square brackets - Category :: [Grapheme] -> Lexeme a + Category :: category a -> Lexeme category a -- | In Brassica sound-change syntax, delimited by parentheses - Optional :: [Lexeme a] -> Lexeme a + Optional :: [Lexeme category a] -> Lexeme category a -- | In Brassica sound-change syntax, specified as @\@ - Metathesis :: Lexeme 'Replacement + Metathesis :: Lexeme category 'Replacement -- | In Brassica sound-change syntax, specified as @>@ - Geminate :: Lexeme a + Geminate :: Lexeme category a -- | In Brassica sound-change syntax, specified as @^@ before another 'Lexeme' - Wildcard :: OneOf a 'Target 'Env => Lexeme a -> Lexeme a + Wildcard :: OneOf a 'Target 'Env => Lexeme category a -> Lexeme category a -- | In Brassica sound-change syntax, specified as @*@ after another 'Lexeme' - Kleene :: OneOf a 'Target 'Env => Lexeme a -> Lexeme a + Kleene :: OneOf a 'Target 'Env => Lexeme category a -> Lexeme category a -- | In Brassica sound-change syntax, specified as @~@ - Discard :: Lexeme 'Replacement + Discard :: Lexeme category 'Replacement -- | In Brassica sound-change syntax, specified as \@i before a category - Backreference :: OneOf a 'Target 'Replacement => Int -> [Grapheme] -> Lexeme a + Backreference :: Int -> category a -> Lexeme category a -- | In Brassica sound-change syntax, specified as \@? before a category - Multiple :: [Grapheme] -> Lexeme 'Replacement + Multiple :: category 'Replacement -> Lexeme category 'Replacement +mapCategory :: (forall x. c x -> c' x) -> Lexeme c a -> Lexeme c' a +mapCategory _ (Grapheme g) = Grapheme g +mapCategory f (Category c) = Category (f c) +mapCategory f (Optional ls) = Optional (mapCategory f <$> ls) +mapCategory _ Metathesis = Metathesis +mapCategory _ Geminate = Geminate +mapCategory f (Wildcard l) = Wildcard (mapCategory f l) +mapCategory f (Kleene l) = Kleene (mapCategory f l) +mapCategory _ Discard = Discard +mapCategory f (Backreference i c) = Backreference i (f c) +mapCategory f (Multiple c) = Multiple (f c) + +mapCategoryA + :: Applicative t + => (forall x. c x -> t (c' x)) + -> Lexeme c a + -> t (Lexeme c' a) +mapCategoryA _ (Grapheme g) = pure $ Grapheme g +mapCategoryA f (Category c) = Category <$> f c +mapCategoryA f (Optional ls) = Optional <$> traverse (mapCategoryA f) ls +mapCategoryA _ Metathesis = pure Metathesis +mapCategoryA _ Geminate = pure Geminate +mapCategoryA f (Wildcard l) = Wildcard <$> mapCategoryA f l +mapCategoryA f (Kleene l) = Kleene <$> mapCategoryA f l +mapCategoryA _ Discard = pure Discard +mapCategoryA f (Backreference i c) = Backreference i <$> f c +mapCategoryA f (Multiple c) = Multiple <$> f c + +-- | The type of a category after expansion. +newtype Expanded a = FromElements { elements :: [Either Grapheme [Lexeme Expanded a]] } + deriving (Eq, Ord, Show, Generic, NFData) + +instance Semigroup (Expanded a) where + (FromElements es) <> (FromElements es') = FromElements (es <> es') + +instance Monoid (Expanded a) where + mempty = FromElements [] + +generalise :: (c 'AnyPart -> c a) -> Lexeme c 'AnyPart -> Lexeme c a +generalise _ (Grapheme g) = Grapheme g +generalise f (Category es) = Category $ f es +generalise f (Optional ls) = Optional $ generalise f <$> ls +generalise _ Geminate = Geminate +generalise f (Backreference i es) = Backreference i $ f es + +generaliseExpanded :: Expanded 'AnyPart -> Expanded a +generaliseExpanded = FromElements . (fmap.fmap.fmap) (generalise generaliseExpanded) . elements + -- | A 'Lexeme' matching a single word boundary, specified as @#@ in Brassica syntax. -pattern Boundary :: Lexeme a +pattern Boundary :: Lexeme c a pattern Boundary = Grapheme GBoundary -deriving instance Show (Lexeme a) +deriving instance (forall x. Show (c x)) => Show (Lexeme c a) +deriving instance (forall x. Eq (c x)) => Eq (Lexeme c a) +deriving instance (forall x. Ord (c x)) => Ord (Lexeme c a) -instance NFData (Lexeme a) where +instance (forall x. NFData (c x)) => NFData (Lexeme c a) where rnf (Grapheme g) = rnf g rnf (Category cs) = rnf cs rnf (Optional ls) = rnf ls @@ -152,7 +219,7 @@ -- corresponding to a ‘/ before _ after’ component of a sound change. -- -- Note that an empty environment is just @([], [])@. -type Environment = ([Lexeme 'Env], [Lexeme 'Env]) +type Environment c = ([Lexeme c 'Env], [Lexeme c 'Env]) -- | Specifies application direction of rule — either left-to-right or right-to-left. data Direction = LTR | RTL @@ -192,33 +259,62 @@ -- | A single sound change rule: in Brassica sound-change syntax with all elements specified, -- @-flags target / replacement \/ environment1 | environment2 | … \/ exception@. -- (And usually the 'plaintext' of the rule will contain a 'String' resembling that pattern.) -data Rule = Rule - { target :: [Lexeme 'Target] - , replacement :: [Lexeme 'Replacement] - , environment :: [Environment] - , exception :: Maybe Environment +data Rule c = Rule + { target :: [Lexeme c 'Target] + , replacement :: [Lexeme c 'Replacement] + , environment :: [Environment c] + , exception :: Maybe (Environment c) , flags :: Flags , plaintext :: String - } deriving (Show, Generic, NFData) + } deriving (Generic) --- | 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) +deriving instance (forall a. Show (c a)) => Show (Rule c) +deriving instance (forall a. NFData (c a)) => NFData (Rule c) -- | A 'Statement' can be either a single sound change rule, or a --- category declaration. -data Statement = RuleS Rule | CategoriesDeclS CategoriesDecl - deriving (Show, Generic, NFData) +-- directive (e.g. category definition). +data Statement c decl = RuleS (Rule c) | DirectiveS decl + deriving (Generic) +deriving instance (forall a. Show (c a), Show decl) => Show (Statement c decl) +deriving instance (forall a. NFData (c a), NFData decl) => NFData (Statement c decl) + -- | A simple wrapper around 'plaintext' for 'Statement's. Returns --- @"categories … end"@ for all 'CategoriesDecl' inputs. -plaintext' :: Statement -> String +-- @""@ for all 'DirectiveS' inputs. +plaintext' :: Statement c decl -> String plaintext' (RuleS r) = plaintext r -plaintext' (CategoriesDeclS _) = "categories … end" +plaintext' (DirectiveS _) = "" -- | A set of 'SoundChanges' is simply a list of 'Statement's. -type SoundChanges = [Statement] +type SoundChanges c decl = [Statement c decl] + +-- | The individual operations used to construct a category in +-- Brassica sound-change syntax. +data CategoryModification = Union | Intersect | Subtract + deriving (Show, Eq, Ord, Generic, NFData) + +-- | The specification of a category in Brassica sound-change syntax. +data CategorySpec a + = CategorySpec [(CategoryModification, Either Grapheme [Lexeme CategorySpec a])] + | MustInline String -- ^ A single grapheme assumed to have been specified earlier as a category + deriving (Show, Eq, Ord, Generic, NFData) + +-- | The specification of a suprasegmental feature in Brassica +-- sound-change syntax. +data FeatureSpec = FeatureSpec + { featureBaseName :: Maybe String + , featureBaseValues :: CategorySpec 'AnyPart + , featureDerived :: [(String, CategorySpec 'AnyPart)] + } + deriving (Show, Eq, Ord, Generic, NFData) + +-- | A definition of a new category, either directly or via features. +data CategoryDefinition + = DefineCategory String (CategorySpec 'AnyPart) + | DefineFeature FeatureSpec + deriving (Show, Eq, Ord, Generic, NFData) + +-- | A directive used in Brassica sound-change syntax: currently only +-- @categories … end@ or @new categories … end@ +data Directive = Categories Bool [CategoryDefinition] + deriving (Show, Eq, Ord, Generic, NFData) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -14,9 +14,10 @@ import qualified Data.Text as T import Brassica.SoundChange (applyChanges, splitMultipleResults, applyChangesWithLogs, reportAsText) +import Brassica.SoundChange.Category (expandSoundChanges) import Brassica.SoundChange.Parse (parseSoundChanges, errorBundlePretty) import Brassica.SoundChange.Tokenise (tokeniseWords, detokeniseWords, withFirstCategoriesDecl, Component, getWords) -import Brassica.SoundChange.Types (SoundChanges, PWord, plaintext') +import Brassica.SoundChange.Types (SoundChanges, PWord, plaintext', Expanded, Grapheme) main :: IO () main = defaultMain $ testGroup "brassica-tests" @@ -29,7 +30,7 @@ showLogs logs = unlines $ fmap (reportAsText plaintext') $ concat $ getWords logs proto21eTest - :: (SoundChanges -> PWord -> [a]) + :: (SoundChanges Expanded [Grapheme] -> PWord -> [a]) -> ([Component [a]] -> String) -> String -> FilePath @@ -41,10 +42,15 @@ 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 + soundChanges' <- catchEither (parseSoundChanges soundChangesData) $ \err -> do liftIO $ putStrLn $ "Cannot parse the SCA file because:\n" ++ errorBundlePretty err + throwE () + soundChanges <- catchEither (expandSoundChanges soundChanges') $ \err -> do + liftIO $ putStrLn $ + "Cannot expand the SCA file because:\n" ++ + show err throwE () let output pre = B8.fromString . (++"\n") . (pre ++) prettyError = output "SCA Error:" . errorBundlePretty