{-# LANGUAGE CPP                  #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DerivingVia           #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TupleSections         #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE ViewPatterns          #-}

{-| __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.Apply.Internal
       ( -- * Types

         RuleTag(..)
       -- * Lexeme matching

       , match
       , matchMany
       , mkReplacement
       , exceptionAppliesAtPoint
       , matchRuleAtPoint
       -- * Sound change application

       , applyOnce
       , applyRule
       , checkGraphemes
       , applyStatement
       , applyRuleStr
       , applyStatementStr
       , applyChanges
       -- * Logging

       , LogItem(..)
       , PWordLog(..)
       , toPWordLog
       , reportAsHtmlRows
       , reportAsText
       , applyStatementWithLog
       , applyChangesWithLog
       , applyChangesWithLogs
       , applyChangesWithChanges
       ) where

import Control.Applicative ((<|>))
import Data.Containers.ListUtils (nubOrd)
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.Maybe (maybeToList, fromMaybe, listToMaybe, mapMaybe)
import GHC.Generics (Generic)

import Control.DeepSeq (NFData)
import Control.Monad.State

import Brassica.SoundChange.Apply.Internal.MultiZipper
import Brassica.SoundChange.Types
import Data.Bifunctor (Bifunctor(first))

-- | Defines the tags used when applying a 'Rule'.

data RuleTag
    = AppStart     -- ^ The start of a rule application

    | TargetStart  -- ^ The start of the target

    | TargetEnd    -- ^ The end of the target

    deriving (RuleTag -> RuleTag -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RuleTag -> RuleTag -> Bool
$c/= :: RuleTag -> RuleTag -> Bool
== :: RuleTag -> RuleTag -> Bool
$c== :: RuleTag -> RuleTag -> Bool
Eq, Eq RuleTag
RuleTag -> RuleTag -> Bool
RuleTag -> RuleTag -> Ordering
RuleTag -> RuleTag -> RuleTag
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RuleTag -> RuleTag -> RuleTag
$cmin :: RuleTag -> RuleTag -> RuleTag
max :: RuleTag -> RuleTag -> RuleTag
$cmax :: RuleTag -> RuleTag -> RuleTag
>= :: RuleTag -> RuleTag -> Bool
$c>= :: RuleTag -> RuleTag -> Bool
> :: RuleTag -> RuleTag -> Bool
$c> :: RuleTag -> RuleTag -> Bool
<= :: RuleTag -> RuleTag -> Bool
$c<= :: RuleTag -> RuleTag -> Bool
< :: RuleTag -> RuleTag -> Bool
$c< :: RuleTag -> RuleTag -> Bool
compare :: RuleTag -> RuleTag -> Ordering
$ccompare :: RuleTag -> RuleTag -> Ordering
Ord, Int -> RuleTag -> ShowS
[RuleTag] -> ShowS
RuleTag -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RuleTag] -> ShowS
$cshowList :: [RuleTag] -> ShowS
show :: RuleTag -> [Char]
$cshow :: RuleTag -> [Char]
showsPrec :: Int -> RuleTag -> ShowS
$cshowsPrec :: Int -> RuleTag -> ShowS
Show)

-- | A monad in which to process a 'MultiZipper' over

-- 'Char's. Essentially a @StateT (MultiZipper RuleTag Grapheme) []@:

-- it stores the 'MultiZipper' as state, and allows failure,

-- backtracking and multiple answers (backtracking over the state

-- too).

newtype RuleAp a = RuleAp { forall a.
RuleAp a
-> MultiZipper RuleTag [Char] -> [(a, MultiZipper RuleTag [Char])]
runRuleAp :: MultiZipper RuleTag Grapheme -> [(a, MultiZipper RuleTag Grapheme)] }
    deriving (forall a b. a -> RuleAp b -> RuleAp a
forall a b. (a -> b) -> RuleAp a -> RuleAp 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 -> RuleAp b -> RuleAp a
$c<$ :: forall a b. a -> RuleAp b -> RuleAp a
fmap :: forall a b. (a -> b) -> RuleAp a -> RuleAp b
$cfmap :: forall a b. (a -> b) -> RuleAp a -> RuleAp b
Functor, Functor RuleAp
forall a. a -> RuleAp a
forall a b. RuleAp a -> RuleAp b -> RuleAp a
forall a b. RuleAp a -> RuleAp b -> RuleAp b
forall a b. RuleAp (a -> b) -> RuleAp a -> RuleAp b
forall a b c. (a -> b -> c) -> RuleAp a -> RuleAp b -> RuleAp c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. RuleAp a -> RuleAp b -> RuleAp a
$c<* :: forall a b. RuleAp a -> RuleAp b -> RuleAp a
*> :: forall a b. RuleAp a -> RuleAp b -> RuleAp b
$c*> :: forall a b. RuleAp a -> RuleAp b -> RuleAp b
liftA2 :: forall a b c. (a -> b -> c) -> RuleAp a -> RuleAp b -> RuleAp c
$cliftA2 :: forall a b c. (a -> b -> c) -> RuleAp a -> RuleAp b -> RuleAp c
<*> :: forall a b. RuleAp (a -> b) -> RuleAp a -> RuleAp b
$c<*> :: forall a b. RuleAp (a -> b) -> RuleAp a -> RuleAp b
pure :: forall a. a -> RuleAp a
$cpure :: forall a. a -> RuleAp a
Applicative, Applicative RuleAp
forall a. a -> RuleAp a
forall a b. RuleAp a -> RuleAp b -> RuleAp b
forall a b. RuleAp a -> (a -> RuleAp b) -> RuleAp b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> RuleAp a
$creturn :: forall a. a -> RuleAp a
>> :: forall a b. RuleAp a -> RuleAp b -> RuleAp b
$c>> :: forall a b. RuleAp a -> RuleAp b -> RuleAp b
>>= :: forall a b. RuleAp a -> (a -> RuleAp b) -> RuleAp b
$c>>= :: forall a b. RuleAp a -> (a -> RuleAp b) -> RuleAp b
Monad, MonadState (MultiZipper RuleTag Grapheme)
#if __GLASGOW_HASKELL__ > 806
    , Monad RuleAp
forall a. [Char] -> RuleAp a
forall (m :: * -> *).
Monad m -> (forall a. [Char] -> m a) -> MonadFail m
fail :: forall a. [Char] -> RuleAp a
$cfail :: forall a. [Char] -> RuleAp a
MonadFail
#endif
    )
      via (StateT (MultiZipper RuleTag Grapheme) [])

-- | Lift a partial modification function into a 'State'. Update state

-- if it succeeds, otherwise rollback.

modifyMay :: Monad m => (s -> Maybe s) -> StateT s m ()
modifyMay :: forall (m :: * -> *) s. Monad m => (s -> Maybe s) -> StateT s m ()
modifyMay s -> Maybe s
f = forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \s
s -> forall a. a -> Maybe a -> a
fromMaybe s
s (s -> Maybe s
f s
s)

-- | Monadic version of 'modify'.

modifyM :: Monad m => (s -> m s) -> StateT s m ()
modifyM :: forall (m :: * -> *) s. Monad m => (s -> m s) -> StateT s m ()
modifyM s -> m s
f = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((),) forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> m s
f)

-- | Given a nondeterministic stateful function, lift it into a

-- 'StateT' computation which returns 'Nothing' when the original

-- action would have failed with no results.

try :: (s -> [(a, s)]) -> StateT s [] (Maybe a)
try :: forall s a. (s -> [(a, s)]) -> StateT s [] (Maybe a)
try s -> [(a, s)]
p = forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
StateT forall a b. (a -> b) -> a -> b
$ \s
s ->
    case s -> [(a, s)]
p s
s of
        [] -> [(forall a. Maybe a
Nothing, s
s)]
        [(a, s)]
r -> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(a, s)]
r

-- | Describes the output of a 'match' operation.

data MatchOutput = MatchOutput
    { -- | For each category matched, the index of the matched

      -- grapheme in that category.

      MatchOutput -> [Int]
matchedCatIxs    :: [Int]
      -- | For each optional group whether it matched or not

    , MatchOutput -> [Bool]
matchedOptionals :: [Bool]
      -- | The graphemes which were matched

    , MatchOutput -> PWord
matchedGraphemes :: [Grapheme]
    } deriving (Int -> MatchOutput -> ShowS
[MatchOutput] -> ShowS
MatchOutput -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [MatchOutput] -> ShowS
$cshowList :: [MatchOutput] -> ShowS
show :: MatchOutput -> [Char]
$cshow :: MatchOutput -> [Char]
showsPrec :: Int -> MatchOutput -> ShowS
$cshowsPrec :: Int -> MatchOutput -> ShowS
Show)

modifyMatchedGraphemes :: ([Grapheme] -> [Grapheme]) -> MatchOutput -> MatchOutput
modifyMatchedGraphemes :: (PWord -> PWord) -> MatchOutput -> MatchOutput
modifyMatchedGraphemes PWord -> PWord
f MatchOutput{[Bool]
[Int]
PWord
matchedGraphemes :: PWord
matchedOptionals :: [Bool]
matchedCatIxs :: [Int]
matchedGraphemes :: MatchOutput -> PWord
matchedOptionals :: MatchOutput -> [Bool]
matchedCatIxs :: MatchOutput -> [Int]
..} = MatchOutput{matchedGraphemes :: PWord
matchedGraphemes=PWord -> PWord
f PWord
matchedGraphemes, [Bool]
[Int]
matchedOptionals :: [Bool]
matchedCatIxs :: [Int]
matchedOptionals :: [Bool]
matchedCatIxs :: [Int]
..}

prependGrapheme :: Grapheme -> MatchOutput -> MatchOutput
prependGrapheme :: [Char] -> MatchOutput -> MatchOutput
prependGrapheme [Char]
g = (PWord -> PWord) -> MatchOutput -> MatchOutput
modifyMatchedGraphemes ([Char]
gforall a. a -> [a] -> [a]
:)

instance Semigroup MatchOutput where
    (MatchOutput [Int]
a1 [Bool]
b1 PWord
c1) <> :: MatchOutput -> MatchOutput -> MatchOutput
<> (MatchOutput [Int]
a2 [Bool]
b2 PWord
c2) = [Int] -> [Bool] -> PWord -> MatchOutput
MatchOutput ([Int]
a1forall a. [a] -> [a] -> [a]
++[Int]
a2) ([Bool]
b1forall a. [a] -> [a] -> [a]
++[Bool]
b2) (PWord
c1forall a. [a] -> [a] -> [a]
++PWord
c2)

-- | 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
      => Maybe Grapheme       -- ^ The previously-matched grapheme, if any. (Used to match a 'Geminate'.)

      -> Lexeme a             -- ^ The lexeme to match.

      -> MultiZipper t Grapheme   -- ^ The 'MultiZipper' to match against.

      -> [(MatchOutput, MultiZipper t Grapheme)]
      -- ^ The output: a tuple @((i, g), mz)@ as described below.

match :: forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
Maybe [Char]
-> Lexeme a
-> MultiZipper t [Char]
-> [(MatchOutput, MultiZipper t [Char])]
match Maybe [Char]
prev (Optional [Lexeme a]
l) MultiZipper t [Char]
mz =
    ([Int] -> [Bool] -> PWord -> MatchOutput
MatchOutput [] [Bool
False] [], MultiZipper t [Char]
mz) forall a. a -> [a] -> [a]
:
    (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([Int] -> [Bool] -> PWord -> MatchOutput
MatchOutput [] [Bool
True] [] forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
Maybe [Char]
-> [Lexeme a]
-> MultiZipper t [Char]
-> [(MatchOutput, MultiZipper t [Char])]
matchMany Maybe [Char]
prev [Lexeme a]
l MultiZipper t [Char]
mz )
match Maybe [Char]
prev w :: Lexeme a
w@(Wildcard Lexeme a
l) MultiZipper t [Char]
mz = case forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
Maybe [Char]
-> Lexeme a
-> MultiZipper t [Char]
-> [(MatchOutput, MultiZipper t [Char])]
match Maybe [Char]
prev Lexeme a
l MultiZipper t [Char]
mz of
    [] -> forall a. Maybe a -> [a]
maybeToList (forall t a. MultiZipper t a -> Maybe (a, MultiZipper t a)
consume MultiZipper t [Char]
mz) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \([Char]
g, MultiZipper t [Char]
mz') ->
        forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([Char] -> MatchOutput -> MatchOutput
prependGrapheme [Char]
g) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
Maybe [Char]
-> Lexeme a
-> MultiZipper t [Char]
-> [(MatchOutput, MultiZipper t [Char])]
match Maybe [Char]
prev Lexeme a
w MultiZipper t [Char]
mz'
    [(MatchOutput, MultiZipper t [Char])]
r -> [(MatchOutput, MultiZipper t [Char])]
r
match Maybe [Char]
prev k :: Lexeme a
k@(Kleene Lexeme a
l) MultiZipper t [Char]
mz = case forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
Maybe [Char]
-> Lexeme a
-> MultiZipper t [Char]
-> [(MatchOutput, MultiZipper t [Char])]
match Maybe [Char]
prev Lexeme a
l MultiZipper t [Char]
mz of
    [] -> [([Int] -> [Bool] -> PWord -> MatchOutput
MatchOutput [] [] [], MultiZipper t [Char]
mz)]
    [(MatchOutput, MultiZipper t [Char])]
r -> [(MatchOutput, MultiZipper t [Char])]
r forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(MatchOutput
out, MultiZipper t [Char]
mz') -> case forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
Maybe [Char]
-> Lexeme a
-> MultiZipper t [Char]
-> [(MatchOutput, MultiZipper t [Char])]
match Maybe [Char]
prev Lexeme a
k MultiZipper t [Char]
mz' of
        [] -> forall a. HasCallStack => [Char] -> a
error [Char]
"match: Kleene should never fail"
        [(MatchOutput, MultiZipper t [Char])]
r' -> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (MatchOutput
out forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(MatchOutput, MultiZipper t [Char])]
r'
match Maybe [Char]
_ (Grapheme [Char]
g) MultiZipper t [Char]
mz = ([Int] -> [Bool] -> PWord -> MatchOutput
MatchOutput [] [] [[Char]
g],) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Maybe a -> [a]
maybeToList (forall t.
[Char] -> MultiZipper t [Char] -> Maybe (MultiZipper t [Char])
matchGrapheme [Char]
g MultiZipper t [Char]
mz)
match Maybe [Char]
_ (Category [CategoryElement a]
gs) MultiZipper t [Char]
mz =
    [CategoryElement a]
gs
    -- Attempt to match each option in category...

    forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\case
               CategoryElement a
BoundaryEl -> if forall t a. MultiZipper t a -> Bool
atBoundary MultiZipper t [Char]
mz then forall a. a -> Maybe a
Just ([], MultiZipper t [Char]
mz) else forall a. Maybe a
Nothing
               GraphemeEl [Char]
g -> ([[Char]
g],) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t.
[Char] -> MultiZipper t [Char] -> Maybe (MultiZipper t [Char])
matchGrapheme [Char]
g MultiZipper t [Char]
mz)
    -- ...get the index of each match...

    forall a b. a -> (a -> b) -> b
& forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i Maybe (PWord, MultiZipper t [Char])
m -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int
i,) Maybe (PWord, MultiZipper t [Char])
m) [Int
0..]
    -- ...and take all matches

    forall a b. a -> (a -> b) -> b
& (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Maybe a -> [a]
maybeToList)
    forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Int
i, (PWord
g, MultiZipper t [Char]
mz')) -> ([Int] -> [Bool] -> PWord -> MatchOutput
MatchOutput [Int
i] [] PWord
g, MultiZipper t [Char]
mz'))
match Maybe [Char]
_ Lexeme a
Boundary MultiZipper t [Char]
mz = if forall t a. MultiZipper t a -> Bool
atBoundary MultiZipper t [Char]
mz then [([Int] -> [Bool] -> PWord -> MatchOutput
MatchOutput [] [] [], MultiZipper t [Char]
mz)] else []
match Maybe [Char]
prev Lexeme a
Geminate MultiZipper t [Char]
mz = case Maybe [Char]
prev of
    Maybe [Char]
Nothing -> []
    Just [Char]
prev' -> ([Int] -> [Bool] -> PWord -> MatchOutput
MatchOutput [] [] [[Char]
prev'],) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Maybe a -> [a]
maybeToList (forall t.
[Char] -> MultiZipper t [Char] -> Maybe (MultiZipper t [Char])
matchGrapheme [Char]
prev' MultiZipper t [Char]
mz)

matchGrapheme :: Grapheme -> MultiZipper t Grapheme -> Maybe (MultiZipper t Grapheme)
matchGrapheme :: forall t.
[Char] -> MultiZipper t [Char] -> Maybe (MultiZipper t [Char])
matchGrapheme [Char]
g = forall t.
([Char] -> Bool)
-> MultiZipper t [Char] -> Maybe (MultiZipper t [Char])
matchGraphemeP (forall a. Eq a => a -> a -> Bool
==[Char]
g)

matchGraphemeP :: (Grapheme -> Bool) -> MultiZipper t Grapheme -> Maybe (MultiZipper t Grapheme)
matchGraphemeP :: forall t.
([Char] -> Bool)
-> MultiZipper t [Char] -> Maybe (MultiZipper t [Char])
matchGraphemeP [Char] -> Bool
p MultiZipper t [Char]
mz = forall t a. MultiZipper t a -> Maybe a
value MultiZipper t [Char]
mz forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Char]
cs -> if [Char] -> Bool
p [Char]
cs then forall t a. MultiZipper t a -> Maybe (MultiZipper t a)
fwd MultiZipper t [Char]
mz else forall a. Maybe a
Nothing

-- | Match a list of several 'Lexeme's against a

-- 'MultiZipper'. Arguments and output are the same as with 'match',

-- though the outputs are given as a list of indices and graphemes

-- rather than as a single index and grapheme.

matchMany :: OneOf a 'Target 'Env
          => Maybe Grapheme
          -> [Lexeme a]
          -> MultiZipper t Grapheme
          -> [(MatchOutput, MultiZipper t Grapheme)]
matchMany :: forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
Maybe [Char]
-> [Lexeme a]
-> MultiZipper t [Char]
-> [(MatchOutput, MultiZipper t [Char])]
matchMany = forall {a :: LexemeType} {t}.
OneOf a 'Target 'Env =>
MatchOutput
-> Maybe [Char]
-> [Lexeme a]
-> MultiZipper t [Char]
-> [(MatchOutput, MultiZipper t [Char])]
go ([Int] -> [Bool] -> PWord -> MatchOutput
MatchOutput [] [] [])
  where
    go :: MatchOutput
-> Maybe [Char]
-> [Lexeme a]
-> MultiZipper t [Char]
-> [(MatchOutput, MultiZipper t [Char])]
go MatchOutput
out Maybe [Char]
_ [] MultiZipper t [Char]
mz = [(MatchOutput
out, MultiZipper t [Char]
mz)]
    go MatchOutput
out Maybe [Char]
prev (Lexeme a
l:[Lexeme a]
ls) MultiZipper t [Char]
mz = forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
Maybe [Char]
-> Lexeme a
-> MultiZipper t [Char]
-> [(MatchOutput, MultiZipper t [Char])]
match Maybe [Char]
prev Lexeme a
l MultiZipper t [Char]
mz forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(MatchOutput
out', MultiZipper t [Char]
mz') ->
        MatchOutput
-> Maybe [Char]
-> [Lexeme a]
-> MultiZipper t [Char]
-> [(MatchOutput, MultiZipper t [Char])]
go (MatchOutput
out forall a. Semigroup a => a -> a -> a
<> MatchOutput
out') (forall a. [a] -> Maybe a
lastMay (MatchOutput -> PWord
matchedGraphemes MatchOutput
out') forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe [Char]
prev) [Lexeme a]
ls MultiZipper t [Char]
mz'

-- Small utility function, not exported

lastMay :: [a] -> Maybe a
lastMay :: forall a. [a] -> Maybe a
lastMay [a]
l = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
l then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (forall a. [a] -> a
last [a]
l)

-- | Given a list of 'Lexeme's specifying a replacement, generate all

-- 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.

    -> MultiZipper t Grapheme
    -> [MultiZipper t Grapheme]
mkReplacement :: forall t.
MatchOutput
-> [Lexeme 'Replacement]
-> MultiZipper t [Char]
-> [MultiZipper t [Char]]
mkReplacement = \MatchOutput
out [Lexeme 'Replacement]
ls -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {t}.
MatchOutput
-> [Lexeme 'Replacement]
-> (MultiZipper t [Char], Maybe [Char])
-> [(MatchOutput, (MultiZipper t [Char], Maybe [Char]))]
go MatchOutput
out [Lexeme 'Replacement]
ls forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,forall a. Maybe a
Nothing)
  where
    go :: MatchOutput
-> [Lexeme 'Replacement]
-> (MultiZipper t [Char], Maybe [Char])
-> [(MatchOutput, (MultiZipper t [Char], Maybe [Char]))]
go MatchOutput
out []     (MultiZipper t [Char]
mz, Maybe [Char]
prev) = [(MatchOutput
out, (MultiZipper t [Char]
mz, Maybe [Char]
prev))]
    go MatchOutput
out (Lexeme 'Replacement
l:[Lexeme 'Replacement]
ls) (MultiZipper t [Char]
mz, Maybe [Char]
prev) = do
        (MatchOutput
out', (MultiZipper t [Char]
mz', Maybe [Char]
prev')) <- forall t.
MatchOutput
-> Lexeme 'Replacement
-> MultiZipper t [Char]
-> Maybe [Char]
-> [(MatchOutput, (MultiZipper t [Char], Maybe [Char]))]
replaceLex MatchOutput
out Lexeme 'Replacement
l MultiZipper t [Char]
mz Maybe [Char]
prev
        MatchOutput
-> [Lexeme 'Replacement]
-> (MultiZipper t [Char], Maybe [Char])
-> [(MatchOutput, (MultiZipper t [Char], Maybe [Char]))]
go MatchOutput
out' [Lexeme 'Replacement]
ls (MultiZipper t [Char]
mz', Maybe [Char]
prev')

    replaceLex
        :: MatchOutput
        -> Lexeme 'Replacement
        -> MultiZipper t Grapheme
        -> Maybe Grapheme
        -> [(MatchOutput, (MultiZipper t Grapheme, Maybe Grapheme))]
    replaceLex :: forall t.
MatchOutput
-> Lexeme 'Replacement
-> MultiZipper t [Char]
-> Maybe [Char]
-> [(MatchOutput, (MultiZipper t [Char], Maybe [Char]))]
replaceLex MatchOutput
out (Grapheme [Char]
g) MultiZipper t [Char]
mz Maybe [Char]
_prev = [(MatchOutput
out, (forall a t. a -> MultiZipper t a -> MultiZipper t a
insert [Char]
g MultiZipper t [Char]
mz, forall a. a -> Maybe a
Just [Char]
g))]
    replaceLex out :: MatchOutput
out@MatchOutput{matchedCatIxs :: MatchOutput -> [Int]
matchedCatIxs=(Int
i:[Int]
is)} (Category [CategoryElement 'Replacement]
gs) MultiZipper t [Char]
mz Maybe [Char]
_prev =
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (MatchOutput
out{matchedCatIxs :: [Int]
matchedCatIxs=[Int]
is},) forall a b. (a -> b) -> a -> b
$
            if Int
i forall a. Ord a => a -> a -> Bool
< forall (t :: * -> *) a. Foldable t => t a -> Int
length [CategoryElement 'Replacement]
gs
            then case [CategoryElement 'Replacement]
gs forall a. [a] -> Int -> a
!! Int
i of GraphemeEl [Char]
g -> [(forall a t. a -> MultiZipper t a -> MultiZipper t a
insert [Char]
g MultiZipper t [Char]
mz, forall a. a -> Maybe a
Just [Char]
g)]
            else [(forall a t. a -> MultiZipper t a -> MultiZipper t a
insert [Char]
"\xfffd" MultiZipper t [Char]
mz, forall a. Maybe a
Nothing)]  -- Unicode replacement character

    replaceLex MatchOutput
out (Category [CategoryElement 'Replacement]
gs) MultiZipper t [Char]
mz Maybe [Char]
_prev =
        [CategoryElement 'Replacement]
gs forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \(GraphemeEl [Char]
g) -> (MatchOutput
out, (forall a t. a -> MultiZipper t a -> MultiZipper t a
insert [Char]
g MultiZipper t [Char]
mz, forall a. a -> Maybe a
Just [Char]
g))
    replaceLex MatchOutput{matchedOptionals :: MatchOutput -> [Bool]
matchedOptionals=(Bool
o:[Bool]
os), [Int]
PWord
matchedGraphemes :: PWord
matchedCatIxs :: [Int]
matchedGraphemes :: MatchOutput -> PWord
matchedCatIxs :: MatchOutput -> [Int]
..} (Optional [Lexeme 'Replacement]
ls) MultiZipper t [Char]
mz Maybe [Char]
prev =
        let out' :: MatchOutput
out' = MatchOutput{matchedOptionals :: [Bool]
matchedOptionals=[Bool]
os, [Int]
PWord
matchedGraphemes :: PWord
matchedCatIxs :: [Int]
matchedGraphemes :: PWord
matchedCatIxs :: [Int]
..}
        in if Bool
o
           then forall {t}.
MatchOutput
-> [Lexeme 'Replacement]
-> (MultiZipper t [Char], Maybe [Char])
-> [(MatchOutput, (MultiZipper t [Char], Maybe [Char]))]
go MatchOutput
out' [Lexeme 'Replacement]
ls (MultiZipper t [Char]
mz, Maybe [Char]
prev)
           else [(MatchOutput
out', (MultiZipper t [Char]
mz, forall a. Maybe a
Nothing))]
    replaceLex MatchOutput
out (Optional [Lexeme 'Replacement]
ls) MultiZipper t [Char]
mz Maybe [Char]
prev = (MatchOutput
out, (MultiZipper t [Char]
mz, forall a. Maybe a
Nothing)) forall a. a -> [a] -> [a]
: forall {t}.
MatchOutput
-> [Lexeme 'Replacement]
-> (MultiZipper t [Char], Maybe [Char])
-> [(MatchOutput, (MultiZipper t [Char], Maybe [Char]))]
go MatchOutput
out [Lexeme 'Replacement]
ls (MultiZipper t [Char]
mz, Maybe [Char]
prev)
    replaceLex out :: MatchOutput
out@MatchOutput{PWord
matchedGraphemes :: PWord
matchedGraphemes :: MatchOutput -> PWord
matchedGraphemes}     Lexeme 'Replacement
Metathesis  MultiZipper t [Char]
mz Maybe [Char]
_prev =
        [(MatchOutput
out, (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a t. [a] -> MultiZipper t a -> MultiZipper t a
insertMany MultiZipper t [Char]
mz forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse PWord
matchedGraphemes, forall a. [a] -> Maybe a
listToMaybe PWord
matchedGraphemes))]
    replaceLex MatchOutput
out                                   Lexeme 'Replacement
Geminate    MultiZipper t [Char]
mz Maybe [Char]
prev =
        [(MatchOutput
out, (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a t. [a] -> MultiZipper t a -> MultiZipper t a
insertMany MultiZipper t [Char]
mz forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> [a]
maybeToList Maybe [Char]
prev, Maybe [Char]
prev))]
    replaceLex out :: MatchOutput
out@MatchOutput{matchedCatIxs :: MatchOutput -> [Int]
matchedCatIxs=(Int
_:[Int]
is)} Lexeme 'Replacement
Discard MultiZipper t [Char]
mz Maybe [Char]
prev = [(MatchOutput
out{matchedCatIxs :: [Int]
matchedCatIxs=[Int]
is}, (MultiZipper t [Char]
mz, Maybe [Char]
prev))]
    replaceLex out :: MatchOutput
out@MatchOutput{matchedCatIxs :: MatchOutput -> [Int]
matchedCatIxs=[]} Lexeme 'Replacement
Discard MultiZipper t [Char]
mz Maybe [Char]
prev = [(MatchOutput
out, (MultiZipper t [Char]
mz, Maybe [Char]
prev))]

-- | Given a 'Rule' and a 'MultiZipper', determines whether the

-- '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 'Target]
-> Environment -> MultiZipper RuleTag [Char] -> [Int]
exceptionAppliesAtPoint [Lexeme 'Target]
target ([Lexeme 'Env]
ex1, [Lexeme 'Env]
ex2) MultiZipper RuleTag [Char]
mz = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a.
RuleAp a
-> MultiZipper RuleTag [Char] -> [(a, MultiZipper RuleTag [Char])]
runRuleAp MultiZipper RuleTag [Char]
mz forall a b. (a -> b) -> a -> b
$ do
    MatchOutput
_ <- forall a.
(MultiZipper RuleTag [Char] -> [(a, MultiZipper RuleTag [Char])])
-> RuleAp a
RuleAp forall a b. (a -> b) -> a -> b
$ forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
Maybe [Char]
-> [Lexeme a]
-> MultiZipper t [Char]
-> [(MatchOutput, MultiZipper t [Char])]
matchMany forall a. Maybe a
Nothing [Lexeme 'Env]
ex1
    Int
pos <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall t a. MultiZipper t a -> Int
curPos
    MatchOutput{PWord
matchedGraphemes :: PWord
matchedGraphemes :: MatchOutput -> PWord
matchedGraphemes} <- forall a.
(MultiZipper RuleTag [Char] -> [(a, MultiZipper RuleTag [Char])])
-> RuleAp a
RuleAp forall a b. (a -> b) -> a -> b
$ forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
Maybe [Char]
-> [Lexeme a]
-> MultiZipper t [Char]
-> [(MatchOutput, MultiZipper t [Char])]
matchMany forall a. Maybe a
Nothing [Lexeme 'Target]
target
    MatchOutput
_ <- forall a.
(MultiZipper RuleTag [Char] -> [(a, MultiZipper RuleTag [Char])])
-> RuleAp a
RuleAp forall a b. (a -> b) -> a -> b
$ forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
Maybe [Char]
-> [Lexeme a]
-> MultiZipper t [Char]
-> [(MatchOutput, MultiZipper t [Char])]
matchMany (forall a. [a] -> Maybe a
listToMaybe PWord
matchedGraphemes) [Lexeme 'Env]
ex2
    forall (m :: * -> *) a. Monad m => a -> m a
return Int
pos

-- | Given a 'Rule', determine if that rule matches. If so, for each

-- match, set the appropriate 'RuleTag's and return a tuple of @(is,

-- gs)@, where @gs@ is a list of matched t'Grapheme's, and @is@ is a

-- list of indices, one for each 'Category' lexeme matched.

matchRuleAtPoint
    :: Rule
    -> MultiZipper RuleTag Grapheme
    -> [(MatchOutput, MultiZipper RuleTag Grapheme)]
matchRuleAtPoint :: Rule
-> MultiZipper RuleTag [Char]
-> [(MatchOutput, MultiZipper RuleTag [Char])]
matchRuleAtPoint Rule{environment :: Rule -> Environment
environment = ([Lexeme 'Env]
env1, [Lexeme 'Env]
env2), [Char]
[Lexeme 'Target]
[Lexeme 'Replacement]
Maybe Environment
Flags
plaintext :: Rule -> [Char]
flags :: Rule -> Flags
exception :: Rule -> Maybe Environment
replacement :: Rule -> [Lexeme 'Replacement]
target :: Rule -> [Lexeme 'Target]
plaintext :: [Char]
flags :: Flags
exception :: Maybe Environment
replacement :: [Lexeme 'Replacement]
target :: [Lexeme 'Target]
..} MultiZipper RuleTag [Char]
mz = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a.
RuleAp a
-> MultiZipper RuleTag [Char] -> [(a, MultiZipper RuleTag [Char])]
runRuleAp MultiZipper RuleTag [Char]
mz forall a b. (a -> b) -> a -> b
$ do
    MatchOutput
_ <- forall a.
(MultiZipper RuleTag [Char] -> [(a, MultiZipper RuleTag [Char])])
-> RuleAp a
RuleAp forall a b. (a -> b) -> a -> b
$ forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
Maybe [Char]
-> [Lexeme a]
-> MultiZipper t [Char]
-> [(MatchOutput, MultiZipper t [Char])]
matchMany forall a. Maybe a
Nothing [Lexeme 'Env]
env1
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall t a. Ord t => t -> MultiZipper t a -> MultiZipper t a
tag RuleTag
TargetStart
    MatchOutput
matchResult <- forall a.
(MultiZipper RuleTag [Char] -> [(a, MultiZipper RuleTag [Char])])
-> RuleAp a
RuleAp forall a b. (a -> b) -> a -> b
$ forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
Maybe [Char]
-> [Lexeme a]
-> MultiZipper t [Char]
-> [(MatchOutput, MultiZipper t [Char])]
matchMany forall a. Maybe a
Nothing [Lexeme 'Target]
target
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall t a. Ord t => t -> MultiZipper t a -> MultiZipper t a
tag RuleTag
TargetEnd
    MatchOutput
_ <- forall a.
(MultiZipper RuleTag [Char] -> [(a, MultiZipper RuleTag [Char])])
-> RuleAp a
RuleAp forall a b. (a -> b) -> a -> b
$ forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
Maybe [Char]
-> [Lexeme a]
-> MultiZipper t [Char]
-> [(MatchOutput, MultiZipper t [Char])]
matchMany (forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ MatchOutput -> PWord
matchedGraphemes MatchOutput
matchResult) [Lexeme 'Env]
env2
    forall (m :: * -> *) a. Monad m => a -> m a
return MatchOutput
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 -> StateT (MultiZipper RuleTag [Char]) [] Bool
applyOnce r :: Rule
r@Rule{[Lexeme 'Target]
target :: [Lexeme 'Target]
target :: Rule -> [Lexeme 'Target]
target, [Lexeme 'Replacement]
replacement :: [Lexeme 'Replacement]
replacement :: Rule -> [Lexeme 'Replacement]
replacement, Maybe Environment
exception :: Maybe Environment
exception :: Rule -> Maybe Environment
exception} = do
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ forall t a. Ord t => t -> MultiZipper t a -> MultiZipper t a
tag RuleTag
AppStart
    Maybe MatchOutput
result <- forall s a. (s -> [(a, s)]) -> StateT s [] (Maybe a)
try (Rule
-> MultiZipper RuleTag [Char]
-> [(MatchOutput, MultiZipper RuleTag [Char])]
matchRuleAtPoint Rule
r)
    case Maybe MatchOutput
result of
        Just MatchOutput
out -> do
            [Int]
exs <- case Maybe Environment
exception of
                Maybe Environment
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                Just Environment
ex -> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. MultiZipper t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                    forall t a b.
(MultiZipper t a -> b) -> MultiZipper t a -> MultiZipper t b
extend' ([Lexeme 'Target]
-> Environment -> MultiZipper RuleTag [Char] -> [Int]
exceptionAppliesAtPoint [Lexeme 'Target]
target Environment
ex)
            forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (forall t a. Ord t => t -> MultiZipper t a -> Maybe Int
locationOf RuleTag
TargetStart) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe Int
p ->
                if forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
exs) Maybe Int
p
                then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                else do
                    forall (m :: * -> *) s. Monad m => (s -> Maybe s) -> StateT s m ()
modifyMay forall a b. (a -> b) -> a -> b
$ forall t a.
Ord t =>
(t, t)
-> ([a] -> [a]) -> MultiZipper t a -> Maybe (MultiZipper t a)
modifyBetween (RuleTag
TargetStart, RuleTag
TargetEnd) forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const []
                    forall (m :: * -> *) s. Monad m => (s -> Maybe s) -> StateT s m ()
modifyMay forall a b. (a -> b) -> a -> b
$ forall t a.
Ord t =>
t -> MultiZipper t a -> Maybe (MultiZipper t a)
seek RuleTag
TargetStart
                    forall (m :: * -> *) s. Monad m => (s -> m s) -> StateT s m ()
modifyM forall a b. (a -> b) -> a -> b
$ forall t.
MatchOutput
-> [Lexeme 'Replacement]
-> MultiZipper t [Char]
-> [MultiZipper t [Char]]
mkReplacement MatchOutput
out [Lexeme 'Replacement]
replacement
                    forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Maybe MatchOutput
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | 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
-> MultiZipper RuleTag [Char]
-> Maybe (MultiZipper RuleTag [Char])
setupForNextApplication Bool
success r :: Rule
r@Rule{flags :: Rule -> Flags
flags=Flags{Direction
applyDirection :: Flags -> Direction
applyDirection :: Direction
applyDirection}} = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall t a. MultiZipper t a -> MultiZipper t a
untag forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    case Direction
applyDirection of
        Direction
RTL -> forall t a.
Ord t =>
t -> MultiZipper t a -> Maybe (MultiZipper t a)
seek RuleTag
AppStart forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall t a. MultiZipper t a -> Maybe (MultiZipper t a)
bwd
        Direction
LTR ->
            if Bool
success
            then
                if forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Rule -> [Lexeme 'Target]
target Rule
r)
                then -- need to move forward if applying an epenthesis rule to avoid an infinite loop

                    forall t a.
Ord t =>
t -> MultiZipper t a -> Maybe (MultiZipper t a)
seek RuleTag
TargetEnd forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall t a. MultiZipper t a -> Maybe (MultiZipper t a)
fwd
                else forall t a.
Ord t =>
t -> MultiZipper t a -> Maybe (MultiZipper t a)
seek RuleTag
TargetEnd
            else forall t a.
Ord t =>
t -> MultiZipper t a -> Maybe (MultiZipper t a)
seek RuleTag
AppStart forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall t a. MultiZipper t a -> Maybe (MultiZipper t a)
fwd

-- | 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 -> MultiZipper RuleTag [Char] -> [MultiZipper RuleTag [Char]]
applyRule Rule
r = \MultiZipper RuleTag [Char]
mz ->    -- use a lambda so mz isn't shadowed in the where block

    let startingPos :: MultiZipper RuleTag [Char]
startingPos = case Flags -> Direction
applyDirection forall a b. (a -> b) -> a -> b
$ Rule -> Flags
flags Rule
r of
            Direction
LTR -> forall t a. MultiZipper t a -> MultiZipper t a
toBeginning MultiZipper RuleTag [Char]
mz
            Direction
RTL -> forall t a. MultiZipper t a -> MultiZipper t a
toEnd MultiZipper RuleTag [Char]
mz
        result :: [MultiZipper RuleTag [Char]]
result = StateT (MultiZipper RuleTag [Char]) [] Bool
-> MultiZipper RuleTag [Char] -> [MultiZipper RuleTag [Char]]
repeatRule (Rule -> StateT (MultiZipper RuleTag [Char]) [] Bool
applyOnce Rule
r) MultiZipper RuleTag [Char]
startingPos
    in if Flags -> Bool
sporadic forall a b. (a -> b) -> a -> b
$ Rule -> Flags
flags Rule
r
          then MultiZipper RuleTag [Char]
mz forall a. a -> [a] -> [a]
: [MultiZipper RuleTag [Char]]
result
          else [MultiZipper RuleTag [Char]]
result
  where
    repeatRule
        :: StateT (MultiZipper RuleTag Grapheme) [] Bool
        -> MultiZipper RuleTag Grapheme
        -> [MultiZipper RuleTag Grapheme]
    repeatRule :: StateT (MultiZipper RuleTag [Char]) [] Bool
-> MultiZipper RuleTag [Char] -> [MultiZipper RuleTag [Char]]
repeatRule StateT (MultiZipper RuleTag [Char]) [] Bool
m MultiZipper RuleTag [Char]
mz = forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT (MultiZipper RuleTag [Char]) [] Bool
m MultiZipper RuleTag [Char]
mz forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Bool
success, MultiZipper RuleTag [Char]
mz') ->
        if Bool
success Bool -> Bool -> Bool
&& Flags -> Bool
applyOnceOnly (Rule -> Flags
flags Rule
r)
        then [MultiZipper RuleTag [Char]
mz']
        else case Bool
-> Rule
-> MultiZipper RuleTag [Char]
-> Maybe (MultiZipper RuleTag [Char])
setupForNextApplication Bool
success Rule
r MultiZipper RuleTag [Char]
mz' of
            Just MultiZipper RuleTag [Char]
mz'' -> StateT (MultiZipper RuleTag [Char]) [] Bool
-> MultiZipper RuleTag [Char] -> [MultiZipper RuleTag [Char]]
repeatRule StateT (MultiZipper RuleTag [Char]) [] Bool
m MultiZipper RuleTag [Char]
mz''
            Maybe (MultiZipper RuleTag [Char])
Nothing -> [MultiZipper RuleTag [Char]
mz']

-- | 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
-> MultiZipper RuleTag [Char] -> MultiZipper RuleTag [Char]
checkGraphemes (CategoriesDecl PWord
gs) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ \[Char]
g -> if [Char]
g forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` PWord
gs then [Char]
g else [Char]
"\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
-> MultiZipper RuleTag [Char] -> [MultiZipper RuleTag [Char]]
applyStatement (RuleS Rule
r) MultiZipper RuleTag [Char]
mz = Rule -> MultiZipper RuleTag [Char] -> [MultiZipper RuleTag [Char]]
applyRule Rule
r MultiZipper RuleTag [Char]
mz
applyStatement (CategoriesDeclS CategoriesDecl
gs) MultiZipper RuleTag [Char]
mz = [CategoriesDecl
-> MultiZipper RuleTag [Char] -> MultiZipper RuleTag [Char]
checkGraphemes CategoriesDecl
gs MultiZipper RuleTag [Char]
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]
-- Note: 'fromJust' is safe here as 'apply' should always succeed

applyRuleStr :: Rule -> PWord -> [PWord]
applyRuleStr Rule
r PWord
s = forall a. Ord a => [a] -> [a]
nubOrd forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall t a. MultiZipper t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ Rule -> MultiZipper RuleTag [Char] -> [MultiZipper RuleTag [Char]]
applyRule Rule
r forall a b. (a -> b) -> a -> b
$ forall a t. [a] -> MultiZipper t a
fromListStart PWord
s

-- | Apply a single 'Statement' to a word.

--

-- 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 -> PWord -> [PWord]
applyStatementStr Statement
st PWord
s = forall a. Ord a => [a] -> [a]
nubOrd forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall t a. MultiZipper t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ Statement
-> MultiZipper RuleTag [Char] -> [MultiZipper RuleTag [Char]]
applyStatement Statement
st forall a b. (a -> b) -> a -> b
$ forall a t. [a] -> MultiZipper t a
fromListStart PWord
s

-- | A log item representing a single application of an action. (In

-- practise this will usually be a 'Statement'.) Specifies the action

-- which was applied, as well as the ‘before’ and ‘after’ states.

data LogItem r = ActionApplied
    { forall r. LogItem r -> r
action :: r
    , forall r. LogItem r -> PWord
input :: PWord
    , forall r. LogItem r -> PWord
output :: PWord
    } deriving (Int -> LogItem r -> ShowS
forall r. Show r => Int -> LogItem r -> ShowS
forall r. Show r => [LogItem r] -> ShowS
forall r. Show r => LogItem r -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [LogItem r] -> ShowS
$cshowList :: forall r. Show r => [LogItem r] -> ShowS
show :: LogItem r -> [Char]
$cshow :: forall r. Show r => LogItem r -> [Char]
showsPrec :: Int -> LogItem r -> ShowS
$cshowsPrec :: forall r. Show r => Int -> LogItem r -> ShowS
Show, forall a b. a -> LogItem b -> LogItem a
forall a b. (a -> b) -> LogItem a -> LogItem 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 -> LogItem b -> LogItem a
$c<$ :: forall a b. a -> LogItem b -> LogItem a
fmap :: forall a b. (a -> b) -> LogItem a -> LogItem b
$cfmap :: forall a b. (a -> b) -> LogItem a -> LogItem b
Functor, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall r x. Rep (LogItem r) x -> LogItem r
forall r x. LogItem r -> Rep (LogItem r) x
$cto :: forall r x. Rep (LogItem r) x -> LogItem r
$cfrom :: forall r x. LogItem r -> Rep (LogItem r) x
Generic, forall r. NFData r => LogItem r -> ()
forall a. (a -> ()) -> NFData a
rnf :: LogItem r -> ()
$crnf :: forall r. NFData r => LogItem r -> ()
NFData)

-- | Logs the evolution of a 'PWord' as various actions are applied to

-- it. The actions (usually 'Statement's) are of type @r@.

data PWordLog r = PWordLog
    { forall r. PWordLog r -> PWord
initialWord :: PWord
    -- ^ The initial word, before any actions have been applied

    , forall r. PWordLog r -> [(PWord, r)]
derivations :: [(PWord, r)]
    -- ^ The state of the word after each action @r@, stored alongside

    -- the action which was applied at each point

    } deriving (Int -> PWordLog r -> ShowS
forall r. Show r => Int -> PWordLog r -> ShowS
forall r. Show r => [PWordLog r] -> ShowS
forall r. Show r => PWordLog r -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PWordLog r] -> ShowS
$cshowList :: forall r. Show r => [PWordLog r] -> ShowS
show :: PWordLog r -> [Char]
$cshow :: forall r. Show r => PWordLog r -> [Char]
showsPrec :: Int -> PWordLog r -> ShowS
$cshowsPrec :: forall r. Show r => Int -> PWordLog r -> ShowS
Show, forall a b. a -> PWordLog b -> PWordLog a
forall a b. (a -> b) -> PWordLog a -> PWordLog 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 -> PWordLog b -> PWordLog a
$c<$ :: forall a b. a -> PWordLog b -> PWordLog a
fmap :: forall a b. (a -> b) -> PWordLog a -> PWordLog b
$cfmap :: forall a b. (a -> b) -> PWordLog a -> PWordLog b
Functor, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall r x. Rep (PWordLog r) x -> PWordLog r
forall r x. PWordLog r -> Rep (PWordLog r) x
$cto :: forall r x. Rep (PWordLog r) x -> PWordLog r
$cfrom :: forall r x. PWordLog r -> Rep (PWordLog r) x
Generic, forall r. NFData r => PWordLog r -> ()
forall a. (a -> ()) -> NFData a
rnf :: PWordLog r -> ()
$crnf :: forall r. NFData r => PWordLog r -> ()
NFData)

toPWordLog :: [LogItem r] -> Maybe (PWordLog r)
toPWordLog :: forall r. [LogItem r] -> Maybe (PWordLog r)
toPWordLog [] = forall a. Maybe a
Nothing
toPWordLog ls :: [LogItem r]
ls@(LogItem r
l : [LogItem r]
_) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PWordLog
    { initialWord :: PWord
initialWord = forall r. LogItem r -> PWord
input LogItem r
l
    , derivations :: [(PWord, r)]
derivations = (\ActionApplied{r
PWord
output :: PWord
input :: PWord
action :: r
output :: forall r. LogItem r -> PWord
input :: forall r. LogItem r -> PWord
action :: forall r. LogItem r -> r
..} -> (PWord
output, r
action)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [LogItem r]
ls
    }

-- | Render a single 'PWordLog' to rows of an HTML table. For

-- instance, the example log given in the documentation for

-- 'reportAsText' would be converted to the following HTML:

--

-- > "<tr><td>tara</td><td>&rarr;</td><td>tazha</td><td>(r / zh)</td></tr><tr><td></td><td>&rarr;</td><td>tazh</td><td>(V / / _ #)</td></tr>"

--

-- Which might be displayed in an HTML table as something like the

-- following:

--

-- +------+---+-------+-------------+ 

-- | tara | → | tazha | (r / zh)    |

-- +------+---+-------+-------------+ 

-- |      | → | tazh  | (V / / _ #) |

-- +------+---+-------+-------------+ 


reportAsHtmlRows :: (r -> String) -> PWordLog r -> String
reportAsHtmlRows :: forall r. (r -> [Char]) -> PWordLog r -> [Char]
reportAsHtmlRows r -> [Char]
render PWordLog r
item = [Char] -> [(PWord, r)] -> [Char]
go (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall r. PWordLog r -> PWord
initialWord PWordLog r
item) (forall r. PWordLog r -> [(PWord, r)]
derivations PWordLog r
item)
  where
    go :: [Char] -> [(PWord, r)] -> [Char]
go [Char]
_ [] = [Char]
""
    go [Char]
cell1 ((PWord
output, r
action) : [(PWord, r)]
ds) =
        ([Char]
"<tr><td>" forall a. [a] -> [a] -> [a]
++ [Char]
cell1 forall a. [a] -> [a] -> [a]
++ [Char]
"</td><td>&rarr;</td><td>"
         forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat PWord
output
         forall a. [a] -> [a] -> [a]
++ [Char]
"</td><td>(" forall a. [a] -> [a] -> [a]
++ r -> [Char]
render r
action forall a. [a] -> [a] -> [a]
++ [Char]
")</td></tr>")
        forall a. [a] -> [a] -> [a]
++ [Char] -> [(PWord, r)] -> [Char]
go [Char]
"" [(PWord, r)]
ds

-- | Render a single 'PWordLog' to plain text. For instance, this log:

--

-- > PWordLog

-- >   { initialWord = ["t", "a", "r", "a"]

-- >   , derivations =

-- >     [ (["t", "a", "zh", "a"], "r / zh")

-- >     , (["t", "a", "zh"], "V / / _ #")

-- >     ]

-- >   }

--

-- Would render as:

--

-- > tara

-- >   -> tazha  (r / zh)

-- >   -> tazh   (V / / _ #)

reportAsText :: (r -> String) -> PWordLog r -> String
reportAsText :: forall r. (r -> [Char]) -> PWordLog r -> [Char]
reportAsText r -> [Char]
render PWordLog r
item = PWord -> [Char]
unlines forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall r. PWordLog r -> PWord
initialWord PWordLog r
item) forall a. a -> [a] -> [a]
: forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char], r) -> [Char]
toLine (forall {t :: * -> *} {b}.
Foldable t =>
[(t [Char], b)] -> [([Char], b)]
alignWithPadding forall a b. (a -> b) -> a -> b
$ forall r. PWordLog r -> [(PWord, r)]
derivations PWordLog r
item)
  where
    alignWithPadding :: [(t [Char], b)] -> [([Char], b)]
alignWithPadding [(t [Char], b)]
ds =
        let (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat -> PWord
outputs, [b]
actions) = forall a b. [(a, b)] -> ([a], [b])
unzip [(t [Char], b)]
ds
            maxlen :: Int
maxlen = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PWord
outputs
            padded :: PWord
padded = PWord
outputs forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \[Char]
o -> [Char]
o forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
maxlen forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
o) Char
' '
        in forall a b. [a] -> [b] -> [(a, b)]
zip PWord
padded [b]
actions

    toLine :: ([Char], r) -> [Char]
toLine ([Char]
output, r
action) = [Char]
"  -> " forall a. [a] -> [a] -> [a]
++ [Char]
output forall a. [a] -> [a] -> [a]
++ [Char]
"  (" forall a. [a] -> [a] -> [a]
++ r -> [Char]
render r
action forall a. [a] -> [a] -> [a]
++ [Char]
")"

-- | 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 -> PWord -> [LogItem Statement]
applyStatementWithLog Statement
st PWord
w = case Statement -> PWord -> [PWord]
applyStatementStr Statement
st PWord
w of
    [PWord
w'] -> if PWord
w' forall a. Eq a => a -> a -> Bool
== PWord
w then [] else [forall r. r -> PWord -> PWord -> LogItem r
ActionApplied Statement
st PWord
w PWord
w']
    [PWord]
r -> forall r. r -> PWord -> PWord -> LogItem r
ActionApplied Statement
st PWord
w forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PWord]
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 -> PWord -> [[LogItem Statement]]
applyChangesWithLog [] PWord
_ = [[]]
applyChangesWithLog (Statement
st:SoundChanges
sts) PWord
w =
    case Statement -> PWord -> [LogItem Statement]
applyStatementWithLog Statement
st PWord
w of
        [] -> SoundChanges -> PWord -> [[LogItem Statement]]
applyChangesWithLog SoundChanges
sts PWord
w
        [LogItem Statement]
items -> [LogItem Statement]
items forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \l :: LogItem Statement
l@ActionApplied{output :: forall r. LogItem r -> PWord
output=PWord
w'} ->
            (LogItem Statement
l forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SoundChanges -> PWord -> [[LogItem Statement]]
applyChangesWithLog SoundChanges
sts PWord
w'

-- | Apply 'SoundChanges' to a word, returning an 'PWordLog'

-- for each possible result.

applyChangesWithLogs :: SoundChanges -> PWord -> [PWordLog Statement]
applyChangesWithLogs :: SoundChanges -> PWord -> [PWordLog Statement]
applyChangesWithLogs SoundChanges
scs PWord
w = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall r. [LogItem r] -> Maybe (PWordLog r)
toPWordLog forall a b. (a -> b) -> a -> b
$ SoundChanges -> PWord -> [[LogItem Statement]]
applyChangesWithLog  SoundChanges
scs PWord
w

-- | Apply a set of 'SoundChanges' to a word.

applyChanges :: SoundChanges -> PWord -> [PWord]
applyChanges :: SoundChanges -> PWord -> [PWord]
applyChanges SoundChanges
sts PWord
w =
    [LogItem Statement] -> PWord
lastOutput forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SoundChanges -> PWord -> [[LogItem Statement]]
applyChangesWithLog SoundChanges
sts PWord
w
  where
    lastOutput :: [LogItem Statement] -> PWord
lastOutput [] = PWord
w
    lastOutput [LogItem Statement]
ls = forall r. LogItem r -> PWord
output forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [LogItem Statement]
ls

-- | Apply 'SoundChanges' to a word returning the final results, as

-- 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 -> PWord -> [(PWord, Bool)]
applyChangesWithChanges SoundChanges
sts PWord
w = SoundChanges -> PWord -> [[LogItem Statement]]
applyChangesWithLog SoundChanges
sts PWord
w forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    [] -> (PWord
w, Bool
False)
    [LogItem Statement]
logs -> (forall r. LogItem r -> PWord
output forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [LogItem Statement]
logs, [LogItem Statement] -> Bool
hasChanged [LogItem Statement]
logs)
  where
    hasChanged :: [LogItem Statement] -> Bool
hasChanged = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a b. (a -> b) -> a -> b
$ \case
        ActionApplied{action :: forall r. LogItem r -> r
action=RuleS Rule
rule} -> Flags -> Bool
highlightChanges forall a b. (a -> b) -> a -> b
$ Rule -> Flags
flags Rule
rule
        ActionApplied{action :: forall r. LogItem r -> r
action=CategoriesDeclS CategoriesDecl
_} -> Bool
True