{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TupleSections #-}
module Brassica.SoundChange.Frontend.Internal where
import Data.Bifunctor (second)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Void (Void)
import GHC.Generics (Generic)
import Control.DeepSeq (NFData)
import Text.Megaparsec (ParseErrorBundle)
import Brassica.MDF (MDF, parseMDFWithTokenisation, componentiseMDF, componentiseMDFWordsOnly, duplicateEtymologies)
import Brassica.SoundChange.Apply
import Brassica.SoundChange.Apply.Internal (applyChangesWithLog, toPWordLog)
import Brassica.SoundChange.Tokenise
import Brassica.SoundChange.Types
data ApplicationMode
= ApplyRules HighlightMode MDFOutputMode
| ReportRulesApplied
deriving (Int -> ApplicationMode -> ShowS
[ApplicationMode] -> ShowS
ApplicationMode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApplicationMode] -> ShowS
$cshowList :: [ApplicationMode] -> ShowS
show :: ApplicationMode -> String
$cshow :: ApplicationMode -> String
showsPrec :: Int -> ApplicationMode -> ShowS
$cshowsPrec :: Int -> ApplicationMode -> ShowS
Show, ApplicationMode -> ApplicationMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApplicationMode -> ApplicationMode -> Bool
$c/= :: ApplicationMode -> ApplicationMode -> Bool
== :: ApplicationMode -> ApplicationMode -> Bool
$c== :: ApplicationMode -> ApplicationMode -> Bool
Eq)
data HighlightMode
= NoHighlight
| DifferentToLastRun
| DifferentToInput
deriving (Int -> HighlightMode -> ShowS
[HighlightMode] -> ShowS
HighlightMode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HighlightMode] -> ShowS
$cshowList :: [HighlightMode] -> ShowS
show :: HighlightMode -> String
$cshow :: HighlightMode -> String
showsPrec :: Int -> HighlightMode -> ShowS
$cshowsPrec :: Int -> HighlightMode -> ShowS
Show, HighlightMode -> HighlightMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HighlightMode -> HighlightMode -> Bool
$c/= :: HighlightMode -> HighlightMode -> Bool
== :: HighlightMode -> HighlightMode -> Bool
$c== :: HighlightMode -> HighlightMode -> Bool
Eq)
instance Enum HighlightMode where
fromEnum :: HighlightMode -> Int
fromEnum HighlightMode
NoHighlight = Int
0
fromEnum HighlightMode
DifferentToLastRun = Int
1
fromEnum HighlightMode
DifferentToInput = Int
2
toEnum :: Int -> HighlightMode
toEnum Int
0 = HighlightMode
NoHighlight
toEnum Int
1 = HighlightMode
DifferentToLastRun
toEnum Int
2 = HighlightMode
DifferentToInput
toEnum Int
_ = forall a. HasCallStack => a
undefined
data MDFOutputMode = MDFOutput | WordsOnlyOutput
deriving (Int -> MDFOutputMode -> ShowS
[MDFOutputMode] -> ShowS
MDFOutputMode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MDFOutputMode] -> ShowS
$cshowList :: [MDFOutputMode] -> ShowS
show :: MDFOutputMode -> String
$cshow :: MDFOutputMode -> String
showsPrec :: Int -> MDFOutputMode -> ShowS
$cshowsPrec :: Int -> MDFOutputMode -> ShowS
Show, MDFOutputMode -> MDFOutputMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MDFOutputMode -> MDFOutputMode -> Bool
$c/= :: MDFOutputMode -> MDFOutputMode -> Bool
== :: MDFOutputMode -> MDFOutputMode -> Bool
$c== :: MDFOutputMode -> MDFOutputMode -> Bool
Eq)
instance Enum MDFOutputMode where
fromEnum :: MDFOutputMode -> Int
fromEnum MDFOutputMode
MDFOutput = Int
0
fromEnum MDFOutputMode
WordsOnlyOutput = Int
1
toEnum :: Int -> MDFOutputMode
toEnum Int
0 = MDFOutputMode
MDFOutput
toEnum Int
1 = MDFOutputMode
WordsOnlyOutput
toEnum Int
_ = forall a. HasCallStack => a
undefined
data TokenisationMode = Normal | AddEtymons
deriving (Int -> TokenisationMode -> ShowS
[TokenisationMode] -> ShowS
TokenisationMode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TokenisationMode] -> ShowS
$cshowList :: [TokenisationMode] -> ShowS
show :: TokenisationMode -> String
$cshow :: TokenisationMode -> String
showsPrec :: Int -> TokenisationMode -> ShowS
$cshowsPrec :: Int -> TokenisationMode -> ShowS
Show, TokenisationMode -> TokenisationMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TokenisationMode -> TokenisationMode -> Bool
$c/= :: TokenisationMode -> TokenisationMode -> Bool
== :: TokenisationMode -> TokenisationMode -> Bool
$c== :: TokenisationMode -> TokenisationMode -> Bool
Eq)
instance Enum TokenisationMode where
fromEnum :: TokenisationMode -> Int
fromEnum TokenisationMode
Normal = Int
0
fromEnum TokenisationMode
AddEtymons = Int
1
toEnum :: Int -> TokenisationMode
toEnum Int
0 = TokenisationMode
Normal
toEnum Int
1 = TokenisationMode
AddEtymons
toEnum Int
_ = forall a. HasCallStack => a
undefined
data ApplicationOutput a r
= HighlightedWords [Component (a, Bool)]
| AppliedRulesTable [PWordLog r]
| ParseError (ParseErrorBundle String Void)
deriving (Int -> ApplicationOutput a r -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a r.
(Show a, Show r) =>
Int -> ApplicationOutput a r -> ShowS
forall a r. (Show a, Show r) => [ApplicationOutput a r] -> ShowS
forall a r. (Show a, Show r) => ApplicationOutput a r -> String
showList :: [ApplicationOutput a r] -> ShowS
$cshowList :: forall a r. (Show a, Show r) => [ApplicationOutput a r] -> ShowS
show :: ApplicationOutput a r -> String
$cshow :: forall a r. (Show a, Show r) => ApplicationOutput a r -> String
showsPrec :: Int -> ApplicationOutput a r -> ShowS
$cshowsPrec :: forall a r.
(Show a, Show r) =>
Int -> ApplicationOutput a r -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a r x.
Rep (ApplicationOutput a r) x -> ApplicationOutput a r
forall a r x.
ApplicationOutput a r -> Rep (ApplicationOutput a r) x
$cto :: forall a r x.
Rep (ApplicationOutput a r) x -> ApplicationOutput a r
$cfrom :: forall a r x.
ApplicationOutput a r -> Rep (ApplicationOutput a r) x
Generic, forall a. (a -> ()) -> NFData a
forall a r. (NFData a, NFData r) => ApplicationOutput a r -> ()
rnf :: ApplicationOutput a r -> ()
$crnf :: forall a r. (NFData a, NFData r) => ApplicationOutput a r -> ()
NFData)
data InputLexiconFormat = Raw | MDF
deriving (Int -> InputLexiconFormat -> ShowS
[InputLexiconFormat] -> ShowS
InputLexiconFormat -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InputLexiconFormat] -> ShowS
$cshowList :: [InputLexiconFormat] -> ShowS
show :: InputLexiconFormat -> String
$cshow :: InputLexiconFormat -> String
showsPrec :: Int -> InputLexiconFormat -> ShowS
$cshowsPrec :: Int -> InputLexiconFormat -> ShowS
Show, InputLexiconFormat -> InputLexiconFormat -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InputLexiconFormat -> InputLexiconFormat -> Bool
$c/= :: InputLexiconFormat -> InputLexiconFormat -> Bool
== :: InputLexiconFormat -> InputLexiconFormat -> Bool
$c== :: InputLexiconFormat -> InputLexiconFormat -> Bool
Eq)
instance Enum InputLexiconFormat where
fromEnum :: InputLexiconFormat -> Int
fromEnum InputLexiconFormat
Raw = Int
0
fromEnum InputLexiconFormat
MDF = Int
1
toEnum :: Int -> InputLexiconFormat
toEnum Int
0 = InputLexiconFormat
Raw
toEnum Int
1 = InputLexiconFormat
MDF
toEnum Int
_ = forall a. HasCallStack => a
undefined
data ParseOutput a = ParsedRaw [Component a] | ParsedMDF (MDF [Component a])
deriving (Int -> ParseOutput a -> ShowS
forall a. Show a => Int -> ParseOutput a -> ShowS
forall a. Show a => [ParseOutput a] -> ShowS
forall a. Show a => ParseOutput a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ParseOutput a] -> ShowS
$cshowList :: forall a. Show a => [ParseOutput a] -> ShowS
show :: ParseOutput a -> String
$cshow :: forall a. Show a => ParseOutput a -> String
showsPrec :: Int -> ParseOutput a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> ParseOutput a -> ShowS
Show, forall a b. a -> ParseOutput b -> ParseOutput a
forall a b. (a -> b) -> ParseOutput a -> ParseOutput b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ParseOutput b -> ParseOutput a
$c<$ :: forall a b. a -> ParseOutput b -> ParseOutput a
fmap :: forall a b. (a -> b) -> ParseOutput a -> ParseOutput b
$cfmap :: forall a b. (a -> b) -> ParseOutput a -> ParseOutput b
Functor)
componentise :: MDFOutputMode -> ParseOutput a -> [Component a]
componentise :: forall a. MDFOutputMode -> ParseOutput a -> [Component a]
componentise MDFOutputMode
_ (ParsedRaw [Component a]
cs) = [Component a]
cs
componentise MDFOutputMode
MDFOutput (ParsedMDF MDF [Component a]
mdf) = forall a. MDF [Component a] -> [Component a]
componentiseMDF MDF [Component a]
mdf
componentise MDFOutputMode
WordsOnlyOutput (ParsedMDF MDF [Component a]
mdf) = forall a. MDF [Component a] -> [Component a]
componentiseMDFWordsOnly MDF [Component a]
mdf
tokeniseAccordingToInputFormat
:: InputLexiconFormat
-> TokenisationMode
-> SoundChanges
-> String
-> Either (ParseErrorBundle String Void) (ParseOutput PWord)
tokeniseAccordingToInputFormat :: InputLexiconFormat
-> TokenisationMode
-> SoundChanges
-> String
-> Either (ParseErrorBundle String Void) (ParseOutput PWord)
tokeniseAccordingToInputFormat InputLexiconFormat
Raw TokenisationMode
_ SoundChanges
cs =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. [Component a] -> ParseOutput a
ParsedRaw forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. (PWord -> t) -> SoundChanges -> t
withFirstCategoriesDecl PWord
-> String
-> Either (ParseErrorBundle String Void) [Component PWord]
tokeniseWords SoundChanges
cs
tokeniseAccordingToInputFormat InputLexiconFormat
MDF TokenisationMode
Normal SoundChanges
cs =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. MDF [Component a] -> ParseOutput a
ParsedMDF forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. (PWord -> t) -> SoundChanges -> t
withFirstCategoriesDecl PWord
-> String
-> Either (ParseErrorBundle String Void) (MDF [Component PWord])
parseMDFWithTokenisation SoundChanges
cs
tokeniseAccordingToInputFormat InputLexiconFormat
MDF TokenisationMode
AddEtymons SoundChanges
cs =
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. MDF [Component a] -> ParseOutput a
ParsedMDF
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall v. (v -> String) -> MDF v -> MDF v
duplicateEtymologies forall a b. (a -> b) -> a -> b
$ (Char
'*'forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Component PWord] -> String
detokeniseWords)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. (PWord -> t) -> SoundChanges -> t
withFirstCategoriesDecl PWord
-> String
-> Either (ParseErrorBundle String Void) (MDF [Component PWord])
parseMDFWithTokenisation SoundChanges
cs
parseTokeniseAndApplyRules
:: SoundChanges
-> String
-> InputLexiconFormat
-> TokenisationMode
-> ApplicationMode
-> Maybe [Component PWord]
-> ApplicationOutput PWord Statement
parseTokeniseAndApplyRules :: SoundChanges
-> String
-> InputLexiconFormat
-> TokenisationMode
-> ApplicationMode
-> Maybe [Component PWord]
-> ApplicationOutput PWord Statement
parseTokeniseAndApplyRules SoundChanges
statements String
ws InputLexiconFormat
intype TokenisationMode
tmode ApplicationMode
mode Maybe [Component PWord]
prev =
case InputLexiconFormat
-> TokenisationMode
-> SoundChanges
-> String
-> Either (ParseErrorBundle String Void) (ParseOutput PWord)
tokeniseAccordingToInputFormat InputLexiconFormat
intype TokenisationMode
tmode SoundChanges
statements String
ws of
Left ParseErrorBundle String Void
e -> forall a r. ParseErrorBundle String Void -> ApplicationOutput a r
ParseError ParseErrorBundle String Void
e
Right ParseOutput PWord
toks -> case ApplicationMode
mode of
ApplicationMode
ReportRulesApplied ->
forall a r. [PWordLog r] -> ApplicationOutput a r
AppliedRulesTable forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall r. [LogItem r] -> Maybe (PWordLog r)
toPWordLog forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
forall a. [Component a] -> [a]
getWords forall a b. (a -> b) -> a -> b
$ forall a. MDFOutputMode -> ParseOutput a -> [Component a]
componentise MDFOutputMode
WordsOnlyOutput forall a b. (a -> b) -> a -> b
$
SoundChanges -> PWord -> [[LogItem Statement]]
applyChangesWithLog SoundChanges
statements forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseOutput PWord
toks
ApplyRules HighlightMode
DifferentToLastRun MDFOutputMode
mdfout ->
let result :: [Component PWord]
result = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. String -> Component [a] -> [Component a]
splitMultipleResults String
" ") forall a b. (a -> b) -> a -> b
$
forall a. MDFOutputMode -> ParseOutput a -> [Component a]
componentise MDFOutputMode
mdfout forall a b. (a -> b) -> a -> b
$ SoundChanges -> PWord -> [PWord]
applyChanges SoundChanges
statements forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseOutput PWord
toks
in forall a r. [Component (a, Bool)] -> ApplicationOutput a r
HighlightedWords forall a b. (a -> b) -> a -> b
$
forall a b c.
[Component a]
-> [Component b] -> b -> (a -> b -> c) -> [Component c]
zipWithComponents [Component PWord]
result (forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Component PWord]
prev) [] forall a b. (a -> b) -> a -> b
$ \PWord
thisWord PWord
prevWord ->
(PWord
thisWord, PWord
thisWord forall a. Eq a => a -> a -> Bool
/= PWord
prevWord)
ApplyRules HighlightMode
DifferentToInput MDFOutputMode
mdfout ->
forall a r. [Component (a, Bool)] -> ApplicationOutput a r
HighlightedWords forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. String -> Component [a] -> [Component a]
splitMultipleResults String
" ") forall a b. (a -> b) -> a -> b
$
forall a. MDFOutputMode -> ParseOutput a -> [Component a]
componentise MDFOutputMode
mdfout forall a b. (a -> b) -> a -> b
$ SoundChanges -> PWord -> [(PWord, Bool)]
applyChangesWithChanges SoundChanges
statements forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseOutput PWord
toks
ApplyRules HighlightMode
NoHighlight MDFOutputMode
mdfout ->
forall a r. [Component (a, Bool)] -> ApplicationOutput a r
HighlightedWords forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (,Bool
False) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. String -> Component [a] -> [Component a]
splitMultipleResults String
" ") forall a b. (a -> b) -> a -> b
$
forall a. MDFOutputMode -> ParseOutput a -> [Component a]
componentise MDFOutputMode
mdfout forall a b. (a -> b) -> a -> b
$ SoundChanges -> PWord -> [PWord]
applyChanges SoundChanges
statements forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseOutput PWord
toks
where
zipWithComponents :: [Component a] -> [Component b] -> b -> (a -> b -> c) -> [Component c]
zipWithComponents :: forall a b c.
[Component a]
-> [Component b] -> b -> (a -> b -> c) -> [Component c]
zipWithComponents [] [Component b]
_ b
_ a -> b -> c
_ = []
zipWithComponents [Component a]
as [] b
bd a -> b -> c
f = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (a -> b -> c
`f` b
bd) [Component a]
as
zipWithComponents (Word a
a:[Component a]
as) (Word b
b:[Component b]
bs) b
bd a -> b -> c
f = forall a. a -> Component a
Word (a -> b -> c
f a
a b
b) forall a. a -> [a] -> [a]
: forall a b c.
[Component a]
-> [Component b] -> b -> (a -> b -> c) -> [Component c]
zipWithComponents [Component a]
as [Component b]
bs b
bd a -> b -> c
f
zipWithComponents as :: [Component a]
as@(Word a
_:[Component a]
_) (Component b
_:[Component b]
bs) b
bd a -> b -> c
f = forall a b c.
[Component a]
-> [Component b] -> b -> (a -> b -> c) -> [Component c]
zipWithComponents [Component a]
as [Component b]
bs b
bd a -> b -> c
f
zipWithComponents (Component a
a:[Component a]
as) bs :: [Component b]
bs@(Word b
_:[Component b]
_) b
bd a -> b -> c
f = forall a b. Component a -> Component b
unsafeCastComponent Component a
a forall a. a -> [a] -> [a]
: forall a b c.
[Component a]
-> [Component b] -> b -> (a -> b -> c) -> [Component c]
zipWithComponents [Component a]
as [Component b]
bs b
bd a -> b -> c
f
zipWithComponents (Component a
a:[Component a]
as) (Component b
_:[Component b]
bs) b
bd a -> b -> c
f = forall a b. Component a -> Component b
unsafeCastComponent Component a
a forall a. a -> [a] -> [a]
: forall a b c.
[Component a]
-> [Component b] -> b -> (a -> b -> c) -> [Component c]
zipWithComponents [Component a]
as [Component b]
bs b
bd a -> b -> c
f
unsafeCastComponent :: Component a -> Component b
unsafeCastComponent :: forall a b. Component a -> Component b
unsafeCastComponent (Word a
_) = forall a. HasCallStack => String -> a
error String
"unsafeCastComponent: attempted to cast a word!"
unsafeCastComponent (Separator String
s) = forall a. String -> Component a
Separator String
s
unsafeCastComponent (Gloss String
s) = forall a. String -> Component a
Gloss String
s