{-# LANGUAGE DeriveAnyClass  #-}
{-# LANGUAGE DeriveFunctor   #-}
{-# LANGUAGE DeriveGeneric   #-}
{-# LANGUAGE TupleSections   #-}

{-| __Warning:__ This module is __internal__, and does __not__ follow
  the Package Versioning Policy. It may be useful for extending
  Brassica, but be prepared to track development closely if you import
  this module.
-}
module Brassica.SoundChange.Frontend.Internal where

import Data.Bifunctor (second)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Void (Void)
import GHC.Generics (Generic)

import Control.DeepSeq (NFData)
import Text.Megaparsec (ParseErrorBundle)

import Brassica.MDF (MDF, parseMDFWithTokenisation, componentiseMDF, componentiseMDFWordsOnly, duplicateEtymologies)
import Brassica.SoundChange.Apply
import Brassica.SoundChange.Apply.Internal (applyChangesWithLog, toPWordLog)
import Brassica.SoundChange.Tokenise
import Brassica.SoundChange.Types

-- | Rule application mode of the SCA.

data ApplicationMode
    = ApplyRules HighlightMode MDFOutputMode
    | ReportRulesApplied
    deriving (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
    -- used for conversion to and from C, so want control over values

    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
    -- used for conversion to and from C, so want control over values

    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
    -- used for conversion to and from C, so want control over values

    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

-- | Output of a single application of rules to a wordlist: either a

-- list of possibly highlighted words, an applied rules table, or a

-- parse error.

data ApplicationOutput a r
    = HighlightedWords [Component (a, Bool)]
    | AppliedRulesTable [PWordLog r]
    | ParseError (ParseErrorBundle String Void)
    deriving (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)

-- | Kind of input: either a raw wordlist, or an MDF file.

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
    -- used for conversion to and from C, so want control over values

    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

-- | Top-level dispatcher for an interactive frontend: given a textual

-- wordlist and a list of sound changes, returns the result of running

-- the changes in the specified mode.

parseTokeniseAndApplyRules
    :: SoundChanges -- ^ changes

    -> String       -- ^ words

    -> InputLexiconFormat
    -> TokenisationMode
    -> ApplicationMode
    -> Maybe [Component PWord]  -- ^ previous results

    -> ApplicationOutput PWord Statement
parseTokeniseAndApplyRules :: 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
    -- Zips two tokenised input strings. Compared to normal 'zipWith'

    -- this has two special properties:

    --

    --   * It only zips v'Word's. Any non-v'Word's in the first argument

    --     will be passed unaltered to the output; any in the second

    --     argument will be ignored.

    --

    --   * The returned list will have the same number of elements as does

    --     the first argument. If a v'Word' in the first argument has no

    --     corresponding v'Word' in the second, the zipping function is

    --     called using the default @b@ value given as the third argument.

    --     Such a v'Word' in the second argument will simply be ignored.

    --

    -- Note the persistent assymetry in the definition: each 'Component'

    -- in the first argument will be reflected in the output, but each in

    -- the second argument may be ignored.

    zipWithComponents :: [Component a] -> [Component b] -> b -> (a -> b -> c) -> [Component c]
    zipWithComponents :: 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