{-# LANGUAGE DeriveAnyClass  #-}
{-# LANGUAGE DeriveGeneric   #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE RankNTypes      #-}
{-# 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 Control.Monad ((<=<))
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Void (Void)
import GHC.Generics (Generic)
import Myers.Diff (getDiff, PolyDiff(..))

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

import Brassica.SFM.MDF
import Brassica.SFM.SFM
import Brassica.SoundChange.Apply
import Brassica.SoundChange.Apply.Internal (applyChangesWithLog, toPWordLog)
import Brassica.SoundChange.Tokenise
import Brassica.SoundChange.Types
import Data.Bifunctor (first)

-- | Rule application mode of the SCA.

data ApplicationMode
    = ApplyRules HighlightMode OutputMode String
    | ReportRulesApplied
    deriving (Int -> ApplicationMode -> ShowS
[ApplicationMode] -> ShowS
ApplicationMode -> String
(Int -> ApplicationMode -> ShowS)
-> (ApplicationMode -> String)
-> ([ApplicationMode] -> ShowS)
-> Show ApplicationMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ApplicationMode -> ShowS
showsPrec :: Int -> ApplicationMode -> ShowS
$cshow :: ApplicationMode -> String
show :: ApplicationMode -> String
$cshowList :: [ApplicationMode] -> ShowS
showList :: [ApplicationMode] -> ShowS
Show, ApplicationMode -> ApplicationMode -> Bool
(ApplicationMode -> ApplicationMode -> Bool)
-> (ApplicationMode -> ApplicationMode -> Bool)
-> Eq ApplicationMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ApplicationMode -> ApplicationMode -> Bool
== :: ApplicationMode -> ApplicationMode -> Bool
$c/= :: ApplicationMode -> ApplicationMode -> Bool
/= :: ApplicationMode -> ApplicationMode -> Bool
Eq)

getOutputMode :: ApplicationMode -> OutputMode
getOutputMode :: ApplicationMode -> OutputMode
getOutputMode (ApplyRules HighlightMode
_ OutputMode
o String
_) = OutputMode
o
getOutputMode ApplicationMode
ReportRulesApplied = OutputMode
WordsOnlyOutput  -- default option


data HighlightMode
    = NoHighlight
    | DifferentToLastRun
    | DifferentToInput
    deriving (Int -> HighlightMode -> ShowS
[HighlightMode] -> ShowS
HighlightMode -> String
(Int -> HighlightMode -> ShowS)
-> (HighlightMode -> String)
-> ([HighlightMode] -> ShowS)
-> Show HighlightMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HighlightMode -> ShowS
showsPrec :: Int -> HighlightMode -> ShowS
$cshow :: HighlightMode -> String
show :: HighlightMode -> String
$cshowList :: [HighlightMode] -> ShowS
showList :: [HighlightMode] -> ShowS
Show, HighlightMode -> HighlightMode -> Bool
(HighlightMode -> HighlightMode -> Bool)
-> (HighlightMode -> HighlightMode -> Bool) -> Eq HighlightMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HighlightMode -> HighlightMode -> Bool
== :: HighlightMode -> HighlightMode -> Bool
$c/= :: HighlightMode -> HighlightMode -> Bool
/= :: 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
_ = HighlightMode
forall a. HasCallStack => a
undefined

data OutputMode
    = MDFOutput
    | WordsOnlyOutput
    | MDFOutputWithEtymons
    | WordsWithProtoOutput
    deriving (Int -> OutputMode -> ShowS
[OutputMode] -> ShowS
OutputMode -> String
(Int -> OutputMode -> ShowS)
-> (OutputMode -> String)
-> ([OutputMode] -> ShowS)
-> Show OutputMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OutputMode -> ShowS
showsPrec :: Int -> OutputMode -> ShowS
$cshow :: OutputMode -> String
show :: OutputMode -> String
$cshowList :: [OutputMode] -> ShowS
showList :: [OutputMode] -> ShowS
Show, OutputMode -> OutputMode -> Bool
(OutputMode -> OutputMode -> Bool)
-> (OutputMode -> OutputMode -> Bool) -> Eq OutputMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OutputMode -> OutputMode -> Bool
== :: OutputMode -> OutputMode -> Bool
$c/= :: OutputMode -> OutputMode -> Bool
/= :: OutputMode -> OutputMode -> Bool
Eq)
instance Enum OutputMode where
    -- used for conversion to and from C, so want control over values

    fromEnum :: OutputMode -> Int
fromEnum OutputMode
MDFOutput = Int
0
    fromEnum OutputMode
WordsOnlyOutput = Int
1
    fromEnum OutputMode
MDFOutputWithEtymons = Int
2
    fromEnum OutputMode
WordsWithProtoOutput = Int
3

    toEnum :: Int -> OutputMode
toEnum Int
0 = OutputMode
MDFOutput
    toEnum Int
1 = OutputMode
WordsOnlyOutput
    toEnum Int
2 = OutputMode
MDFOutputWithEtymons
    toEnum Int
3 = OutputMode
WordsWithProtoOutput
    toEnum Int
_ = OutputMode
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
[ApplicationOutput a r] -> ShowS
ApplicationOutput a r -> String
(Int -> ApplicationOutput a r -> ShowS)
-> (ApplicationOutput a r -> String)
-> ([ApplicationOutput a r] -> ShowS)
-> Show (ApplicationOutput a r)
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
$cshowsPrec :: forall a r.
(Show a, Show r) =>
Int -> ApplicationOutput a r -> ShowS
showsPrec :: Int -> ApplicationOutput a r -> ShowS
$cshow :: forall a r. (Show a, Show r) => ApplicationOutput a r -> String
show :: ApplicationOutput a r -> String
$cshowList :: forall a r. (Show a, Show r) => [ApplicationOutput a r] -> ShowS
showList :: [ApplicationOutput a r] -> ShowS
Show, (forall x. ApplicationOutput a r -> Rep (ApplicationOutput a r) x)
-> (forall x.
    Rep (ApplicationOutput a r) x -> ApplicationOutput a r)
-> Generic (ApplicationOutput a r)
forall x. Rep (ApplicationOutput a r) x -> ApplicationOutput a r
forall x. ApplicationOutput a r -> Rep (ApplicationOutput a r) x
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
$cfrom :: forall a r x.
ApplicationOutput a r -> Rep (ApplicationOutput a r) x
from :: forall x. ApplicationOutput a r -> Rep (ApplicationOutput a r) x
$cto :: forall a r x.
Rep (ApplicationOutput a r) x -> ApplicationOutput a r
to :: forall x. Rep (ApplicationOutput a r) x -> ApplicationOutput a r
Generic, ApplicationOutput a r -> ()
(ApplicationOutput a r -> ()) -> NFData (ApplicationOutput a r)
forall a. (a -> ()) -> NFData a
forall a r. (NFData a, NFData r) => ApplicationOutput a r -> ()
$crnf :: forall a r. (NFData a, NFData r) => ApplicationOutput a r -> ()
rnf :: 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
(Int -> InputLexiconFormat -> ShowS)
-> (InputLexiconFormat -> String)
-> ([InputLexiconFormat] -> ShowS)
-> Show InputLexiconFormat
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> InputLexiconFormat -> ShowS
showsPrec :: Int -> InputLexiconFormat -> ShowS
$cshow :: InputLexiconFormat -> String
show :: InputLexiconFormat -> String
$cshowList :: [InputLexiconFormat] -> ShowS
showList :: [InputLexiconFormat] -> ShowS
Show, InputLexiconFormat -> InputLexiconFormat -> Bool
(InputLexiconFormat -> InputLexiconFormat -> Bool)
-> (InputLexiconFormat -> InputLexiconFormat -> Bool)
-> Eq InputLexiconFormat
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InputLexiconFormat -> InputLexiconFormat -> Bool
== :: InputLexiconFormat -> InputLexiconFormat -> Bool
$c/= :: InputLexiconFormat -> InputLexiconFormat -> Bool
/= :: 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
_ = InputLexiconFormat
forall a. HasCallStack => a
undefined

data ParseOutput a = ParsedRaw [Component a] | ParsedMDF SFM
    deriving (Int -> ParseOutput a -> ShowS
[ParseOutput a] -> ShowS
ParseOutput a -> String
(Int -> ParseOutput a -> ShowS)
-> (ParseOutput a -> String)
-> ([ParseOutput a] -> ShowS)
-> Show (ParseOutput a)
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
$cshowsPrec :: forall a. Show a => Int -> ParseOutput a -> ShowS
showsPrec :: Int -> ParseOutput a -> ShowS
$cshow :: forall a. Show a => ParseOutput a -> String
show :: ParseOutput a -> String
$cshowList :: forall a. Show a => [ParseOutput a] -> ShowS
showList :: [ParseOutput a] -> ShowS
Show, (forall a b. (a -> b) -> ParseOutput a -> ParseOutput b)
-> (forall a b. a -> ParseOutput b -> ParseOutput a)
-> Functor ParseOutput
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
$cfmap :: forall a b. (a -> b) -> ParseOutput a -> ParseOutput b
fmap :: forall a b. (a -> b) -> ParseOutput a -> ParseOutput b
$c<$ :: forall a b. a -> ParseOutput b -> ParseOutput a
<$ :: forall a b. a -> ParseOutput b -> ParseOutput a
Functor, (forall m. Monoid m => ParseOutput m -> m)
-> (forall m a. Monoid m => (a -> m) -> ParseOutput a -> m)
-> (forall m a. Monoid m => (a -> m) -> ParseOutput a -> m)
-> (forall a b. (a -> b -> b) -> b -> ParseOutput a -> b)
-> (forall a b. (a -> b -> b) -> b -> ParseOutput a -> b)
-> (forall b a. (b -> a -> b) -> b -> ParseOutput a -> b)
-> (forall b a. (b -> a -> b) -> b -> ParseOutput a -> b)
-> (forall a. (a -> a -> a) -> ParseOutput a -> a)
-> (forall a. (a -> a -> a) -> ParseOutput a -> a)
-> (forall a. ParseOutput a -> [a])
-> (forall a. ParseOutput a -> Bool)
-> (forall a. ParseOutput a -> Int)
-> (forall a. Eq a => a -> ParseOutput a -> Bool)
-> (forall a. Ord a => ParseOutput a -> a)
-> (forall a. Ord a => ParseOutput a -> a)
-> (forall a. Num a => ParseOutput a -> a)
-> (forall a. Num a => ParseOutput a -> a)
-> Foldable ParseOutput
forall a. Eq a => a -> ParseOutput a -> Bool
forall a. Num a => ParseOutput a -> a
forall a. Ord a => ParseOutput a -> a
forall m. Monoid m => ParseOutput m -> m
forall a. ParseOutput a -> Bool
forall a. ParseOutput a -> Int
forall a. ParseOutput a -> [a]
forall a. (a -> a -> a) -> ParseOutput a -> a
forall m a. Monoid m => (a -> m) -> ParseOutput a -> m
forall b a. (b -> a -> b) -> b -> ParseOutput a -> b
forall a b. (a -> b -> b) -> b -> ParseOutput a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => ParseOutput m -> m
fold :: forall m. Monoid m => ParseOutput m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> ParseOutput a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> ParseOutput a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> ParseOutput a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> ParseOutput a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> ParseOutput a -> b
foldr :: forall a b. (a -> b -> b) -> b -> ParseOutput a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> ParseOutput a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> ParseOutput a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> ParseOutput a -> b
foldl :: forall b a. (b -> a -> b) -> b -> ParseOutput a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> ParseOutput a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> ParseOutput a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> ParseOutput a -> a
foldr1 :: forall a. (a -> a -> a) -> ParseOutput a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> ParseOutput a -> a
foldl1 :: forall a. (a -> a -> a) -> ParseOutput a -> a
$ctoList :: forall a. ParseOutput a -> [a]
toList :: forall a. ParseOutput a -> [a]
$cnull :: forall a. ParseOutput a -> Bool
null :: forall a. ParseOutput a -> Bool
$clength :: forall a. ParseOutput a -> Int
length :: forall a. ParseOutput a -> Int
$celem :: forall a. Eq a => a -> ParseOutput a -> Bool
elem :: forall a. Eq a => a -> ParseOutput a -> Bool
$cmaximum :: forall a. Ord a => ParseOutput a -> a
maximum :: forall a. Ord a => ParseOutput a -> a
$cminimum :: forall a. Ord a => ParseOutput a -> a
minimum :: forall a. Ord a => ParseOutput a -> a
$csum :: forall a. Num a => ParseOutput a -> a
sum :: forall a. Num a => ParseOutput a -> a
$cproduct :: forall a. Num a => ParseOutput a -> a
product :: forall a. Num a => ParseOutput a -> a
Foldable, Functor ParseOutput
Foldable ParseOutput
(Functor ParseOutput, Foldable ParseOutput) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> ParseOutput a -> f (ParseOutput b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    ParseOutput (f a) -> f (ParseOutput a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> ParseOutput a -> m (ParseOutput b))
-> (forall (m :: * -> *) a.
    Monad m =>
    ParseOutput (m a) -> m (ParseOutput a))
-> Traversable ParseOutput
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
ParseOutput (m a) -> m (ParseOutput a)
forall (f :: * -> *) a.
Applicative f =>
ParseOutput (f a) -> f (ParseOutput a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ParseOutput a -> m (ParseOutput b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ParseOutput a -> f (ParseOutput b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ParseOutput a -> f (ParseOutput b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> ParseOutput a -> f (ParseOutput b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
ParseOutput (f a) -> f (ParseOutput a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
ParseOutput (f a) -> f (ParseOutput a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ParseOutput a -> m (ParseOutput b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ParseOutput a -> m (ParseOutput b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
ParseOutput (m a) -> m (ParseOutput a)
sequence :: forall (m :: * -> *) a.
Monad m =>
ParseOutput (m a) -> m (ParseOutput a)
Traversable)

componentise :: OutputMode -> [a] -> [Component a] -> [Component a]
componentise :: forall a. OutputMode -> [a] -> [Component a] -> [Component a]
componentise OutputMode
WordsWithProtoOutput [a]
ws [Component a]
cs = [a] -> [Component a] -> [Component a]
forall a. [a] -> [Component a] -> [Component a]
intersperseWords [a]
ws [Component a]
cs
componentise OutputMode
_                    [a]
_  [Component a]
cs = [Component a]
cs

intersperseWords :: [a] -> [Component a] -> [Component a]
intersperseWords :: forall a. [a] -> [Component a] -> [Component a]
intersperseWords (a
w:[a]
ws) (Word a
c:[Component a]
cs) =
    a -> Component a
forall a. a -> Component a
Word a
w Component a -> [Component a] -> [Component a]
forall a. a -> [a] -> [a]
: String -> Component a
forall a. String -> Component a
Separator String
" → " Component a -> [Component a] -> [Component a]
forall a. a -> [a] -> [a]
: a -> Component a
forall a. a -> Component a
Word a
c Component a -> [Component a] -> [Component a]
forall a. a -> [a] -> [a]
: String -> Component a
forall a. String -> Component a
Separator String
"\n" Component a -> [Component a] -> [Component a]
forall a. a -> [a] -> [a]
: [a] -> [Component a] -> [Component a]
forall a. [a] -> [Component a] -> [Component a]
intersperseWords [a]
ws [Component a]
cs
intersperseWords [a]
ws (Component a
_:[Component a]
cs) = [a] -> [Component a] -> [Component a]
forall a. [a] -> [Component a] -> [Component a]
intersperseWords [a]
ws [Component a]
cs
intersperseWords [] [Component a]
cs = [Component a]
cs
intersperseWords [a]
_ [] = []

tokeniseAccordingToInputFormat
    :: InputLexiconFormat
    -> OutputMode
    -> SoundChanges Expanded [Grapheme]
    -> String
    -> Either (ParseErrorBundle String Void) [Component PWord]
tokeniseAccordingToInputFormat :: InputLexiconFormat
-> OutputMode
-> SoundChanges Expanded PWord
-> String
-> Either (ParseErrorBundle String Void) [Component PWord]
tokeniseAccordingToInputFormat InputLexiconFormat
Raw OutputMode
_ SoundChanges Expanded PWord
cs =
    ([String]
 -> String
 -> Either (ParseErrorBundle String Void) [Component PWord])
-> SoundChanges Expanded PWord
-> String
-> Either (ParseErrorBundle String Void) [Component PWord]
forall t (c :: LexemeType -> *).
([String] -> t) -> SoundChanges c PWord -> t
withFirstCategoriesDecl [String]
-> String
-> Either (ParseErrorBundle String Void) [Component PWord]
tokeniseWords SoundChanges Expanded PWord
cs
tokeniseAccordingToInputFormat InputLexiconFormat
MDF OutputMode
MDFOutputWithEtymons SoundChanges Expanded PWord
cs =
    ([String]
 -> SFM -> Either (ParseErrorBundle String Void) [Component PWord])
-> SoundChanges Expanded PWord
-> SFM
-> Either (ParseErrorBundle String Void) [Component PWord]
forall t (c :: LexemeType -> *).
([String] -> t) -> SoundChanges c PWord -> t
withFirstCategoriesDecl [String]
-> SFM -> Either (ParseErrorBundle String Void) [Component PWord]
tokeniseMDF SoundChanges Expanded PWord
cs (SFM -> Either (ParseErrorBundle String Void) [Component PWord])
-> (String -> Either (ParseErrorBundle String Void) SFM)
-> String
-> Either (ParseErrorBundle String Void) [Component PWord]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=<
    -- TODO don't hard-code hierarchy and filename

    (SFM -> SFM)
-> Either (ParseErrorBundle String Void) SFM
-> Either (ParseErrorBundle String Void) SFM
forall a b.
(a -> b)
-> Either (ParseErrorBundle String Void) a
-> Either (ParseErrorBundle String Void) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SFMTree -> SFM
fromTree (SFMTree -> SFM) -> (SFM -> SFMTree) -> SFM -> SFM
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> SFMTree -> SFMTree
duplicateEtymologies (Char
'*'Char -> ShowS
forall a. a -> [a] -> [a]
:) (SFMTree -> SFMTree) -> (SFM -> SFMTree) -> SFM -> SFMTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hierarchy -> SFM -> SFMTree
toTree Hierarchy
mdfHierarchy)
    (Either (ParseErrorBundle String Void) SFM
 -> Either (ParseErrorBundle String Void) SFM)
-> (String -> Either (ParseErrorBundle String Void) SFM)
-> String
-> Either (ParseErrorBundle String Void) SFM
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Either (ParseErrorBundle String Void) SFM
parseSFM String
""
tokeniseAccordingToInputFormat InputLexiconFormat
MDF OutputMode
o SoundChanges Expanded PWord
cs = \String
input -> do
    SFM
sfm <- String -> String -> Either (ParseErrorBundle String Void) SFM
parseSFM String
"" String
input
    [Component PWord]
ws <- ([String]
 -> SFM -> Either (ParseErrorBundle String Void) [Component PWord])
-> SoundChanges Expanded PWord
-> SFM
-> Either (ParseErrorBundle String Void) [Component PWord]
forall t (c :: LexemeType -> *).
([String] -> t) -> SoundChanges c PWord -> t
withFirstCategoriesDecl [String]
-> SFM -> Either (ParseErrorBundle String Void) [Component PWord]
tokeniseMDF SoundChanges Expanded PWord
cs SFM
sfm
    [Component PWord]
-> Either (ParseErrorBundle String Void) [Component PWord]
forall a. a -> Either (ParseErrorBundle String Void) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Component PWord]
 -> Either (ParseErrorBundle String Void) [Component PWord])
-> [Component PWord]
-> Either (ParseErrorBundle String Void) [Component PWord]
forall a b. (a -> b) -> a -> b
$ case OutputMode
o of
        OutputMode
MDFOutput -> [Component PWord]
ws
        OutputMode
_ ->  -- need to extract words for other output modes

            PWord -> Component PWord
forall a. a -> Component a
Word (PWord -> Component PWord) -> [PWord] -> [Component PWord]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Component PWord] -> [PWord]
forall a. [Component a] -> [a]
getWords [Component PWord]
ws

-- | 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
    :: (forall a b. (a -> b) -> [Component a] -> [Component b])  -- ^ mapping function to use (for parallelism)

    -> SoundChanges Expanded [Grapheme] -- ^ changes

    -> String       -- ^ words

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

    -> ApplicationOutput PWord (Statement Expanded [Grapheme])
parseTokeniseAndApplyRules :: (forall a b. (a -> b) -> [Component a] -> [Component b])
-> SoundChanges Expanded PWord
-> String
-> InputLexiconFormat
-> ApplicationMode
-> Maybe [Component PWord]
-> ApplicationOutput PWord (Statement Expanded PWord)
parseTokeniseAndApplyRules forall a b. (a -> b) -> [Component a] -> [Component b]
parFmap SoundChanges Expanded PWord
statements String
ws InputLexiconFormat
intype ApplicationMode
mode Maybe [Component PWord]
prev =
    case InputLexiconFormat
-> OutputMode
-> SoundChanges Expanded PWord
-> String
-> Either (ParseErrorBundle String Void) [Component PWord]
tokeniseAccordingToInputFormat InputLexiconFormat
intype (ApplicationMode -> OutputMode
getOutputMode ApplicationMode
mode) SoundChanges Expanded PWord
statements String
ws of
        Left ParseErrorBundle String Void
e -> ParseErrorBundle String Void
-> ApplicationOutput PWord (Statement Expanded PWord)
forall a r. ParseErrorBundle String Void -> ApplicationOutput a r
ParseError ParseErrorBundle String Void
e
        Right [Component PWord]
toks
          | [PWord]
ws' <- [Component PWord] -> [PWord]
forall a. [Component a] -> [a]
getWords [Component PWord]
toks
          -> case ApplicationMode
mode of
            ApplicationMode
ReportRulesApplied ->
                [PWordLog (Statement Expanded PWord)]
-> ApplicationOutput PWord (Statement Expanded PWord)
forall a r. [PWordLog r] -> ApplicationOutput a r
AppliedRulesTable ([PWordLog (Statement Expanded PWord)]
 -> ApplicationOutput PWord (Statement Expanded PWord))
-> [PWordLog (Statement Expanded PWord)]
-> ApplicationOutput PWord (Statement Expanded PWord)
forall a b. (a -> b) -> a -> b
$ ([LogItem (Statement Expanded PWord)]
 -> Maybe (PWordLog (Statement Expanded PWord)))
-> [[LogItem (Statement Expanded PWord)]]
-> [PWordLog (Statement Expanded PWord)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [LogItem (Statement Expanded PWord)]
-> Maybe (PWordLog (Statement Expanded PWord))
forall r. [LogItem r] -> Maybe (PWordLog r)
toPWordLog ([[LogItem (Statement Expanded PWord)]]
 -> [PWordLog (Statement Expanded PWord)])
-> [[LogItem (Statement Expanded PWord)]]
-> [PWordLog (Statement Expanded PWord)]
forall a b. (a -> b) -> a -> b
$ [[[LogItem (Statement Expanded PWord)]]]
-> [[LogItem (Statement Expanded PWord)]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[LogItem (Statement Expanded PWord)]]]
 -> [[LogItem (Statement Expanded PWord)]])
-> [[[LogItem (Statement Expanded PWord)]]]
-> [[LogItem (Statement Expanded PWord)]]
forall a b. (a -> b) -> a -> b
$
                    [Component [[LogItem (Statement Expanded PWord)]]]
-> [[[LogItem (Statement Expanded PWord)]]]
forall a. [Component a] -> [a]
getWords ([Component [[LogItem (Statement Expanded PWord)]]]
 -> [[[LogItem (Statement Expanded PWord)]]])
-> [Component [[LogItem (Statement Expanded PWord)]]]
-> [[[LogItem (Statement Expanded PWord)]]]
forall a b. (a -> b) -> a -> b
$ OutputMode
-> [[[LogItem (Statement Expanded PWord)]]]
-> [Component [[LogItem (Statement Expanded PWord)]]]
-> [Component [[LogItem (Statement Expanded PWord)]]]
forall a. OutputMode -> [a] -> [Component a] -> [Component a]
componentise OutputMode
WordsOnlyOutput [] ([Component [[LogItem (Statement Expanded PWord)]]]
 -> [Component [[LogItem (Statement Expanded PWord)]]])
-> [Component [[LogItem (Statement Expanded PWord)]]]
-> [Component [[LogItem (Statement Expanded PWord)]]]
forall a b. (a -> b) -> a -> b
$
                        (PWord -> [[LogItem (Statement Expanded PWord)]])
-> [Component PWord]
-> [Component [[LogItem (Statement Expanded PWord)]]]
forall a b. (a -> b) -> [Component a] -> [Component b]
parFmap (SoundChanges Expanded PWord
-> PWord -> [[LogItem (Statement Expanded PWord)]]
applyChangesWithLog SoundChanges Expanded PWord
statements) [Component PWord]
toks
            ApplyRules HighlightMode
DifferentToLastRun OutputMode
mdfout String
sep ->
                let result :: [Component PWord]
result = (Component [PWord] -> [Component PWord])
-> [Component [PWord]] -> [Component PWord]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> Component [PWord] -> [Component PWord]
forall a. String -> Component [a] -> [Component a]
splitMultipleResults String
sep) ([Component [PWord]] -> [Component PWord])
-> [Component [PWord]] -> [Component PWord]
forall a b. (a -> b) -> a -> b
$
                      OutputMode
-> [[PWord]] -> [Component [PWord]] -> [Component [PWord]]
forall a. OutputMode -> [a] -> [Component a] -> [Component a]
componentise OutputMode
mdfout ((PWord -> [PWord]) -> [PWord] -> [[PWord]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PWord -> [PWord]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [PWord]
ws') ([Component [PWord]] -> [Component [PWord]])
-> [Component [PWord]] -> [Component [PWord]]
forall a b. (a -> b) -> a -> b
$
                          (PWord -> [PWord]) -> [Component PWord] -> [Component [PWord]]
forall a b. (a -> b) -> [Component a] -> [Component b]
parFmap (SoundChanges Expanded PWord -> PWord -> [PWord]
applyChanges SoundChanges Expanded PWord
statements) [Component PWord]
toks
                in [Component (PWord, Bool)]
-> ApplicationOutput PWord (Statement Expanded PWord)
forall a r. [Component (a, Bool)] -> ApplicationOutput a r
HighlightedWords ([Component (PWord, Bool)]
 -> ApplicationOutput PWord (Statement Expanded PWord))
-> [Component (PWord, Bool)]
-> ApplicationOutput PWord (Statement Expanded PWord)
forall a b. (a -> b) -> a -> b
$
                    (PolyDiff (Component PWord) (Component PWord)
 -> Maybe (Component (PWord, Bool)))
-> [PolyDiff (Component PWord) (Component PWord)]
-> [Component (PWord, Bool)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe PolyDiff (Component PWord) (Component PWord)
-> Maybe (Component (PWord, Bool))
forall a.
PolyDiff (Component a) (Component a) -> Maybe (Component (a, Bool))
polyDiffToHighlight ([PolyDiff (Component PWord) (Component PWord)]
 -> [Component (PWord, Bool)])
-> [PolyDiff (Component PWord) (Component PWord)]
-> [Component (PWord, Bool)]
forall a b. (a -> b) -> a -> b
$ [Component PWord]
-> [Component PWord]
-> [PolyDiff (Component PWord) (Component PWord)]
forall a. Eq a => [a] -> [a] -> [Diff a]
getDiff ([Component PWord] -> Maybe [Component PWord] -> [Component PWord]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Component PWord]
prev) [Component PWord]
result
                    -- zipWithComponents result (fromMaybe [] prev) [] $ \thisWord prevWord ->

                    --     (thisWord, thisWord /= prevWord)

            ApplyRules HighlightMode
DifferentToInput OutputMode
mdfout String
sep ->
                [Component (PWord, Bool)]
-> ApplicationOutput PWord (Statement Expanded PWord)
forall a r. [Component (a, Bool)] -> ApplicationOutput a r
HighlightedWords ([Component (PWord, Bool)]
 -> ApplicationOutput PWord (Statement Expanded PWord))
-> [Component (PWord, Bool)]
-> ApplicationOutput PWord (Statement Expanded PWord)
forall a b. (a -> b) -> a -> b
$ (Component [(PWord, Bool)] -> [Component (PWord, Bool)])
-> [Component [(PWord, Bool)]] -> [Component (PWord, Bool)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> Component [(PWord, Bool)] -> [Component (PWord, Bool)]
forall a. String -> Component [a] -> [Component a]
splitMultipleResults String
sep) ([Component [(PWord, Bool)]] -> [Component (PWord, Bool)])
-> [Component [(PWord, Bool)]] -> [Component (PWord, Bool)]
forall a b. (a -> b) -> a -> b
$
                    ((Component [(Maybe PWord, Bool)] -> Component [(PWord, Bool)])
-> [Component [(Maybe PWord, Bool)]] -> [Component [(PWord, Bool)]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap((Component [(Maybe PWord, Bool)] -> Component [(PWord, Bool)])
 -> [Component [(Maybe PWord, Bool)]]
 -> [Component [(PWord, Bool)]])
-> (([(Maybe PWord, Bool)] -> [(PWord, Bool)])
    -> Component [(Maybe PWord, Bool)] -> Component [(PWord, Bool)])
-> ([(Maybe PWord, Bool)] -> [(PWord, Bool)])
-> [Component [(Maybe PWord, Bool)]]
-> [Component [(PWord, Bool)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.([(Maybe PWord, Bool)] -> [(PWord, Bool)])
-> Component [(Maybe PWord, Bool)] -> Component [(PWord, Bool)]
forall a b. (a -> b) -> Component a -> Component b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (((Maybe PWord, Bool) -> Maybe (PWord, Bool))
-> [(Maybe PWord, Bool)] -> [(PWord, Bool)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe PWord, Bool) -> Maybe (PWord, Bool)
forall {a} {b}. (Maybe a, b) -> Maybe (a, b)
extractMaybe) ([Component [(Maybe PWord, Bool)]] -> [Component [(PWord, Bool)]])
-> [Component [(Maybe PWord, Bool)]] -> [Component [(PWord, Bool)]]
forall a b. (a -> b) -> a -> b
$
                        OutputMode
-> [[(Maybe PWord, Bool)]]
-> [Component [(Maybe PWord, Bool)]]
-> [Component [(Maybe PWord, Bool)]]
forall a. OutputMode -> [a] -> [Component a] -> [Component a]
componentise OutputMode
mdfout ((PWord -> [(Maybe PWord, Bool)])
-> [PWord] -> [[(Maybe PWord, Bool)]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Maybe PWord, Bool) -> [(Maybe PWord, Bool)]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe PWord, Bool) -> [(Maybe PWord, Bool)])
-> (PWord -> (Maybe PWord, Bool)) -> PWord -> [(Maybe PWord, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PWord -> Maybe PWord) -> (PWord, Bool) -> (Maybe PWord, Bool)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first PWord -> Maybe PWord
forall a. a -> Maybe a
Just ((PWord, Bool) -> (Maybe PWord, Bool))
-> (PWord -> (PWord, Bool)) -> PWord -> (Maybe PWord, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,Bool
False)) [PWord]
ws') ([Component [(Maybe PWord, Bool)]]
 -> [Component [(Maybe PWord, Bool)]])
-> [Component [(Maybe PWord, Bool)]]
-> [Component [(Maybe PWord, Bool)]]
forall a b. (a -> b) -> a -> b
$
                            (PWord -> [(Maybe PWord, Bool)])
-> [Component PWord] -> [Component [(Maybe PWord, Bool)]]
forall a b. (a -> b) -> [Component a] -> [Component b]
parFmap (SoundChanges Expanded PWord -> PWord -> [(Maybe PWord, Bool)]
applyChangesWithChanges SoundChanges Expanded PWord
statements) [Component PWord]
toks
            ApplyRules HighlightMode
NoHighlight OutputMode
mdfout String
sep ->
                [Component (PWord, Bool)]
-> ApplicationOutput PWord (Statement Expanded PWord)
forall a r. [Component (a, Bool)] -> ApplicationOutput a r
HighlightedWords ([Component (PWord, Bool)]
 -> ApplicationOutput PWord (Statement Expanded PWord))
-> [Component (PWord, Bool)]
-> ApplicationOutput PWord (Statement Expanded PWord)
forall a b. (a -> b) -> a -> b
$ ((Component PWord -> Component (PWord, Bool))
-> [Component PWord] -> [Component (PWord, Bool)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap((Component PWord -> Component (PWord, Bool))
 -> [Component PWord] -> [Component (PWord, Bool)])
-> ((PWord -> (PWord, Bool))
    -> Component PWord -> Component (PWord, Bool))
-> (PWord -> (PWord, Bool))
-> [Component PWord]
-> [Component (PWord, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(PWord -> (PWord, Bool))
-> Component PWord -> Component (PWord, Bool)
forall a b. (a -> b) -> Component a -> Component b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (,Bool
False) ([Component PWord] -> [Component (PWord, Bool)])
-> [Component PWord] -> [Component (PWord, Bool)]
forall a b. (a -> b) -> a -> b
$ (Component [PWord] -> [Component PWord])
-> [Component [PWord]] -> [Component PWord]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String -> Component [PWord] -> [Component PWord]
forall a. String -> Component [a] -> [Component a]
splitMultipleResults String
sep) ([Component [PWord]] -> [Component PWord])
-> [Component [PWord]] -> [Component PWord]
forall a b. (a -> b) -> a -> b
$
                    OutputMode
-> [[PWord]] -> [Component [PWord]] -> [Component [PWord]]
forall a. OutputMode -> [a] -> [Component a] -> [Component a]
componentise OutputMode
mdfout ((PWord -> [PWord]) -> [PWord] -> [[PWord]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PWord -> [PWord]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [PWord]
ws') ([Component [PWord]] -> [Component [PWord]])
-> [Component [PWord]] -> [Component [PWord]]
forall a b. (a -> b) -> a -> b
$
                        (PWord -> [PWord]) -> [Component PWord] -> [Component [PWord]]
forall a b. (a -> b) -> [Component a] -> [Component b]
parFmap (SoundChanges Expanded PWord -> PWord -> [PWord]
applyChanges SoundChanges Expanded PWord
statements) [Component PWord]
toks
  where
    -- highlight words in 'Second' but not 'First'

    polyDiffToHighlight :: PolyDiff (Component a) (Component a) -> Maybe (Component (a, Bool))
    polyDiffToHighlight :: forall a.
PolyDiff (Component a) (Component a) -> Maybe (Component (a, Bool))
polyDiffToHighlight (First Component a
_) = Maybe (Component (a, Bool))
forall a. Maybe a
Nothing
    polyDiffToHighlight (Second (Word a
a)) = Component (a, Bool) -> Maybe (Component (a, Bool))
forall a. a -> Maybe a
Just (Component (a, Bool) -> Maybe (Component (a, Bool)))
-> Component (a, Bool) -> Maybe (Component (a, Bool))
forall a b. (a -> b) -> a -> b
$ (a, Bool) -> Component (a, Bool)
forall a. a -> Component a
Word (a
a, Bool
True)
    polyDiffToHighlight (Second Component a
c) = Component (a, Bool) -> Maybe (Component (a, Bool))
forall a. a -> Maybe a
Just (Component (a, Bool) -> Maybe (Component (a, Bool)))
-> Component (a, Bool) -> Maybe (Component (a, Bool))
forall a b. (a -> b) -> a -> b
$ Component a -> Component (a, Bool)
forall a b. Component a -> Component b
unsafeCastComponent Component a
c
    polyDiffToHighlight (Both Component a
_ (Word a
a)) = Component (a, Bool) -> Maybe (Component (a, Bool))
forall a. a -> Maybe a
Just (Component (a, Bool) -> Maybe (Component (a, Bool)))
-> Component (a, Bool) -> Maybe (Component (a, Bool))
forall a b. (a -> b) -> a -> b
$ (a, Bool) -> Component (a, Bool)
forall a. a -> Component a
Word (a
a, Bool
False)
    polyDiffToHighlight (Both Component a
_ Component a
c) = Component (a, Bool) -> Maybe (Component (a, Bool))
forall a. a -> Maybe a
Just (Component (a, Bool) -> Maybe (Component (a, Bool)))
-> Component (a, Bool) -> Maybe (Component (a, Bool))
forall a b. (a -> b) -> a -> b
$ Component a -> Component (a, Bool)
forall a b. Component a -> Component b
unsafeCastComponent Component a
c

    unsafeCastComponent :: Component a -> Component b
    unsafeCastComponent :: forall a b. Component a -> Component b
unsafeCastComponent (Word a
_) = String -> Component b
forall a. HasCallStack => String -> a
error String
"unsafeCastComponent: attempted to cast a word!"
    unsafeCastComponent (Separator String
s) = String -> Component b
forall a. String -> Component a
Separator String
s
    unsafeCastComponent (Gloss String
s) = String -> Component b
forall a. String -> Component a
Gloss String
s

    extractMaybe :: (Maybe a, b) -> Maybe (a, b)
extractMaybe (Just a
a, b
b) = (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
a, b
b)
    extractMaybe (Maybe a
Nothing, b
_) = Maybe (a, b)
forall a. Maybe a
Nothing