{-# 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
       , 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 Control.Category ((>>>))
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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RuleTag] -> ShowS
$cshowList :: [RuleTag] -> ShowS
show :: RuleTag -> String
$cshow :: RuleTag -> String
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 Grapheme
-> [(a, MultiZipper RuleTag Grapheme)]
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. String -> RuleAp a
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
fail :: forall a. String -> RuleAp a
$cfail :: forall a. String -> 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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MatchOutput] -> ShowS
$cshowList :: [MatchOutput] -> ShowS
show :: MatchOutput -> String
$cshow :: MatchOutput -> String
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]
..}

appendGrapheme :: MatchOutput -> Grapheme -> MatchOutput
appendGrapheme :: MatchOutput -> Grapheme -> MatchOutput
appendGrapheme MatchOutput
out Grapheme
g = (PWord -> PWord) -> MatchOutput -> MatchOutput
modifyMatchedGraphemes (forall a. [a] -> [a] -> [a]
++[Grapheme
g]) MatchOutput
out

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
      => MatchOutput          -- ^ The previous 'MatchOutput'

      -> 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 @(g, mz)@ as described below.

match :: forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
MatchOutput
-> Maybe Grapheme
-> Lexeme a
-> MultiZipper t Grapheme
-> [(MatchOutput, MultiZipper t Grapheme)]
match MatchOutput
out Maybe Grapheme
prev (Optional [Lexeme a]
l) MultiZipper t Grapheme
mz =
    (MatchOutput
out forall a. Semigroup a => a -> a -> a
<> [Int] -> [Bool] -> PWord -> MatchOutput
MatchOutput [] [Bool
False] [], MultiZipper t Grapheme
mz) forall a. a -> [a] -> [a]
:
    forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
MatchOutput
-> Maybe Grapheme
-> [Lexeme a]
-> MultiZipper t Grapheme
-> [(MatchOutput, MultiZipper t Grapheme)]
matchMany (MatchOutput
out forall a. Semigroup a => a -> a -> a
<> [Int] -> [Bool] -> PWord -> MatchOutput
MatchOutput [] [Bool
True] []) Maybe Grapheme
prev [Lexeme a]
l MultiZipper t Grapheme
mz
match MatchOutput
out Maybe Grapheme
prev w :: Lexeme a
w@(Wildcard Lexeme a
l) MultiZipper t Grapheme
mz = case forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
MatchOutput
-> Maybe Grapheme
-> Lexeme a
-> MultiZipper t Grapheme
-> [(MatchOutput, MultiZipper t Grapheme)]
match MatchOutput
out Maybe Grapheme
prev Lexeme a
l MultiZipper t Grapheme
mz of
    [] -> forall a. Maybe a -> [a]
maybeToList (forall t a. MultiZipper t a -> Maybe (a, MultiZipper t a)
consume MultiZipper t Grapheme
mz) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        (Grapheme
GBoundary, MultiZipper t Grapheme
_) -> []   -- don't continue past word boundary

        (Grapheme
g, MultiZipper t Grapheme
mz') -> forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
MatchOutput
-> Maybe Grapheme
-> Lexeme a
-> MultiZipper t Grapheme
-> [(MatchOutput, MultiZipper t Grapheme)]
match (MatchOutput -> Grapheme -> MatchOutput
appendGrapheme MatchOutput
out Grapheme
g) Maybe Grapheme
prev Lexeme a
w MultiZipper t Grapheme
mz'
    [(MatchOutput, MultiZipper t Grapheme)]
r -> [(MatchOutput, MultiZipper t Grapheme)]
r
match MatchOutput
out Maybe Grapheme
prev k :: Lexeme a
k@(Kleene Lexeme a
l) MultiZipper t Grapheme
mz = case forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
MatchOutput
-> Maybe Grapheme
-> Lexeme a
-> MultiZipper t Grapheme
-> [(MatchOutput, MultiZipper t Grapheme)]
match MatchOutput
out Maybe Grapheme
prev Lexeme a
l MultiZipper t Grapheme
mz of
    [] -> [([Int] -> [Bool] -> PWord -> MatchOutput
MatchOutput [] [] [], MultiZipper t Grapheme
mz)]
    [(MatchOutput, MultiZipper t Grapheme)]
r -> [(MatchOutput, MultiZipper t Grapheme)]
r forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(MatchOutput
out', MultiZipper t Grapheme
mz') -> case forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
MatchOutput
-> Maybe Grapheme
-> Lexeme a
-> MultiZipper t Grapheme
-> [(MatchOutput, MultiZipper t Grapheme)]
match MatchOutput
out' Maybe Grapheme
prev Lexeme a
k MultiZipper t Grapheme
mz' of
        [] -> forall a. HasCallStack => String -> a
error String
"match: Kleene should never fail"
        [(MatchOutput, MultiZipper t Grapheme)]
r' -> [(MatchOutput, MultiZipper t Grapheme)]
r'
match MatchOutput
out Maybe Grapheme
_ (Grapheme Grapheme
g) MultiZipper t Grapheme
mz = (MatchOutput
out forall a. Semigroup a => a -> a -> a
<> [Int] -> [Bool] -> PWord -> MatchOutput
MatchOutput [] [] [Grapheme
g],) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Maybe a -> [a]
maybeToList (forall t.
Grapheme
-> MultiZipper t Grapheme -> Maybe (MultiZipper t Grapheme)
matchGrapheme Grapheme
g MultiZipper t Grapheme
mz)
match MatchOutput
out Maybe Grapheme
_ (Category PWord
gs) MultiZipper t Grapheme
mz =
    PWord
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 (forall t.
MultiZipper t Grapheme
-> Grapheme -> Maybe (PWord, MultiZipper t Grapheme)
matchCategoryEl MultiZipper t Grapheme
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 Grapheme)
m -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int
i,) Maybe (PWord, MultiZipper t Grapheme)
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 Grapheme
mz')) -> (MatchOutput
out forall a. Semigroup a => a -> a -> a
<> [Int] -> [Bool] -> PWord -> MatchOutput
MatchOutput [Int
i] [] PWord
g, MultiZipper t Grapheme
mz'))
match MatchOutput
out Maybe Grapheme
prev Lexeme a
Geminate MultiZipper t Grapheme
mz = case Maybe Grapheme
prev of
    Maybe Grapheme
Nothing -> []
    Just Grapheme
prev' -> (MatchOutput
out forall a. Semigroup a => a -> a -> a
<> [Int] -> [Bool] -> PWord -> MatchOutput
MatchOutput [] [] [Grapheme
prev'],) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Maybe a -> [a]
maybeToList (forall t.
Grapheme
-> MultiZipper t Grapheme -> Maybe (MultiZipper t Grapheme)
matchGrapheme Grapheme
prev' MultiZipper t Grapheme
mz)
match MatchOutput
out Maybe Grapheme
_prev (Backreference Int
i PWord
gs) MultiZipper t Grapheme
mz = forall a. Maybe a -> [a]
maybeToList forall a b. (a -> b) -> a -> b
$ do
    Int
catIx <- MatchOutput -> [Int]
matchedCatIxs MatchOutput
out forall a. [a] -> Int -> Maybe a
!? (Int
iforall a. Num a => a -> a -> a
-Int
1)
    Grapheme
g <- PWord
gs forall a. [a] -> Int -> Maybe a
!? Int
catIx
    (PWord
matched, MultiZipper t Grapheme
mz') <- forall t.
MultiZipper t Grapheme
-> Grapheme -> Maybe (PWord, MultiZipper t Grapheme)
matchCategoryEl MultiZipper t Grapheme
mz Grapheme
g
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ((PWord -> PWord) -> MatchOutput -> MatchOutput
modifyMatchedGraphemes (forall a. [a] -> [a] -> [a]
++PWord
matched) MatchOutput
out, MultiZipper t Grapheme
mz')

matchCategoryEl :: MultiZipper t Grapheme -> Grapheme -> Maybe ([Grapheme], MultiZipper t Grapheme)
matchCategoryEl :: forall t.
MultiZipper t Grapheme
-> Grapheme -> Maybe (PWord, MultiZipper t Grapheme)
matchCategoryEl MultiZipper t Grapheme
mz Grapheme
g = ([Grapheme
g],) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t.
Grapheme
-> MultiZipper t Grapheme -> Maybe (MultiZipper t Grapheme)
matchGrapheme Grapheme
g MultiZipper t Grapheme
mz

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

matchGraphemeP :: (Grapheme -> Bool) -> MultiZipper t Grapheme -> Maybe (MultiZipper t Grapheme)
matchGraphemeP :: forall t.
(Grapheme -> Bool)
-> MultiZipper t Grapheme -> Maybe (MultiZipper t Grapheme)
matchGraphemeP Grapheme -> Bool
p MultiZipper t Grapheme
mz = forall t a. MultiZipper t a -> Maybe a
value MultiZipper t Grapheme
mz forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Grapheme
cs -> if Grapheme -> Bool
p Grapheme
cs then forall t a. MultiZipper t a -> Maybe (MultiZipper t a)
fwd MultiZipper t Grapheme
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
          => MatchOutput
          -> Maybe Grapheme
          -> [Lexeme a]
          -> MultiZipper t Grapheme
          -> [(MatchOutput, MultiZipper t Grapheme)]
matchMany :: forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
MatchOutput
-> Maybe Grapheme
-> [Lexeme a]
-> MultiZipper t Grapheme
-> [(MatchOutput, MultiZipper t Grapheme)]
matchMany MatchOutput
out Maybe Grapheme
_ [] MultiZipper t Grapheme
mz = [(MatchOutput
out, MultiZipper t Grapheme
mz)]
matchMany MatchOutput
out Maybe Grapheme
prev (Lexeme a
l:[Lexeme a]
ls) MultiZipper t Grapheme
mz =
    forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
MatchOutput
-> Maybe Grapheme
-> Lexeme a
-> MultiZipper t Grapheme
-> [(MatchOutput, MultiZipper t Grapheme)]
match MatchOutput
out Maybe Grapheme
prev Lexeme a
l MultiZipper t Grapheme
mz forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(MatchOutput
out', MultiZipper t Grapheme
mz') ->
    forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
MatchOutput
-> Maybe Grapheme
-> [Lexeme a]
-> MultiZipper t Grapheme
-> [(MatchOutput, MultiZipper t Grapheme)]
matchMany  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 Grapheme
prev) [Lexeme a]
ls MultiZipper t Grapheme
mz'

-- | 'matchMany' without any previous match output.

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 Grapheme
-> [Lexeme a]
-> MultiZipper t Grapheme
-> [(MatchOutput, MultiZipper t Grapheme)]
matchMany' = forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
MatchOutput
-> Maybe Grapheme
-> [Lexeme a]
-> MultiZipper t Grapheme
-> [(MatchOutput, MultiZipper t Grapheme)]
matchMany ([Int] -> [Bool] -> PWord -> MatchOutput
MatchOutput [] [] [])

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

data ReplacementIndices = ReplacementIndices
    { ReplacementIndices -> Int
ixInCategories :: Int
    , ReplacementIndices -> Int
ixInOptionals :: Int
    , ReplacementIndices -> Maybe CategoryNumber
forcedCategory :: Maybe CategoryNumber
    } deriving (Int -> ReplacementIndices -> ShowS
[ReplacementIndices] -> ShowS
ReplacementIndices -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReplacementIndices] -> ShowS
$cshowList :: [ReplacementIndices] -> ShowS
show :: ReplacementIndices -> String
$cshow :: ReplacementIndices -> String
showsPrec :: Int -> ReplacementIndices -> ShowS
$cshowsPrec :: Int -> ReplacementIndices -> ShowS
Show)

data CategoryNumber = CategoryNumber Int | Nondeterministic
    deriving (Int -> CategoryNumber -> ShowS
[CategoryNumber] -> ShowS
CategoryNumber -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CategoryNumber] -> ShowS
$cshowList :: [CategoryNumber] -> ShowS
show :: CategoryNumber -> String
$cshow :: CategoryNumber -> String
showsPrec :: Int -> CategoryNumber -> ShowS
$cshowsPrec :: Int -> CategoryNumber -> ShowS
Show)

advanceCategory :: ReplacementIndices -> Int -> (CategoryNumber, ReplacementIndices)
advanceCategory :: ReplacementIndices -> Int -> (CategoryNumber, ReplacementIndices)
advanceCategory ReplacementIndices
ix Int
cslen =
    case ReplacementIndices -> Maybe CategoryNumber
forcedCategory ReplacementIndices
ix of
        Just CategoryNumber
i -> (CategoryNumber
i, ReplacementIndices
ix { forcedCategory :: Maybe CategoryNumber
forcedCategory = forall a. Maybe a
Nothing })
        Maybe CategoryNumber
Nothing ->
            let i :: Int
i = ReplacementIndices -> Int
ixInCategories ReplacementIndices
ix in
                ( if Int
i forall a. Ord a => a -> a -> Bool
< Int
cslen then Int -> CategoryNumber
CategoryNumber Int
i else CategoryNumber
Nondeterministic
                , ReplacementIndices
ix { ixInCategories :: Int
ixInCategories = Int
iforall a. Num a => a -> a -> a
+Int
1 }
                )

advanceOptional :: ReplacementIndices -> (Int, ReplacementIndices)
advanceOptional :: ReplacementIndices -> (Int, ReplacementIndices)
advanceOptional ReplacementIndices
ix =
    let i :: Int
i = ReplacementIndices -> Int
ixInOptionals ReplacementIndices
ix
    in (Int
i, ReplacementIndices
ix { ixInOptionals :: Int
ixInOptionals = Int
iforall a. Num a => a -> a -> a
+Int
1 })

forceCategory :: CategoryNumber -> ReplacementIndices -> ReplacementIndices
forceCategory :: CategoryNumber -> ReplacementIndices -> ReplacementIndices
forceCategory CategoryNumber
i ReplacementIndices
ixs = ReplacementIndices
ixs { forcedCategory :: Maybe CategoryNumber
forcedCategory = forall a. a -> Maybe a
Just CategoryNumber
i }

-- | Partially safe list indexing

(!?) :: [a] -> Int -> Maybe a
(a
x:[a]
_ ) !? :: forall a. [a] -> Int -> Maybe a
!? Int
0 = forall a. a -> Maybe a
Just a
x
(a
_:[a]
xs) !? Int
n = [a]
xs forall a. [a] -> Int -> Maybe a
!? (Int
nforall a. Num a => a -> a -> a
-Int
1)
[]     !? Int
_ = forall a. Maybe a
Nothing

-- | 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 Grapheme
-> [MultiZipper t Grapheme]
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.
ReplacementIndices
-> [Lexeme 'Replacement]
-> (MultiZipper t Grapheme, Maybe Grapheme)
-> [(ReplacementIndices, (MultiZipper t Grapheme, Maybe Grapheme))]
go ReplacementIndices
startIxs [Lexeme 'Replacement]
ls forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,forall a. Maybe a
Nothing)
  where
    startIxs :: ReplacementIndices
startIxs = Int -> Int -> Maybe CategoryNumber -> ReplacementIndices
ReplacementIndices Int
0 Int
0 forall a. Maybe a
Nothing

    go
        :: ReplacementIndices
        -> [Lexeme 'Replacement]
        -> (MultiZipper t Grapheme, Maybe Grapheme)
        -> [(ReplacementIndices, (MultiZipper t Grapheme, Maybe Grapheme))]
    go :: forall t.
ReplacementIndices
-> [Lexeme 'Replacement]
-> (MultiZipper t Grapheme, Maybe Grapheme)
-> [(ReplacementIndices, (MultiZipper t Grapheme, Maybe Grapheme))]
go ReplacementIndices
ixs []     (MultiZipper t Grapheme
mz, Maybe Grapheme
prev) = [(ReplacementIndices
ixs, (MultiZipper t Grapheme
mz, Maybe Grapheme
prev))]
    go ReplacementIndices
ixs (Lexeme 'Replacement
l:[Lexeme 'Replacement]
ls) (MultiZipper t Grapheme
mz, Maybe Grapheme
prev) = do
        (ReplacementIndices
ixs', (MultiZipper t Grapheme
mz', Maybe Grapheme
prev')) <- forall t.
ReplacementIndices
-> Lexeme 'Replacement
-> MultiZipper t Grapheme
-> Maybe Grapheme
-> [(ReplacementIndices, (MultiZipper t Grapheme, Maybe Grapheme))]
replaceLex ReplacementIndices
ixs Lexeme 'Replacement
l MultiZipper t Grapheme
mz Maybe Grapheme
prev
        forall t.
ReplacementIndices
-> [Lexeme 'Replacement]
-> (MultiZipper t Grapheme, Maybe Grapheme)
-> [(ReplacementIndices, (MultiZipper t Grapheme, Maybe Grapheme))]
go ReplacementIndices
ixs' [Lexeme 'Replacement]
ls (MultiZipper t Grapheme
mz', Maybe Grapheme
prev')

    numCatsMatched :: Int
numCatsMatched = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ MatchOutput -> [Int]
matchedCatIxs MatchOutput
out

    replaceLex
        :: ReplacementIndices
        -> Lexeme 'Replacement
        -> MultiZipper t Grapheme
        -> Maybe Grapheme
        -> [(ReplacementIndices, (MultiZipper t Grapheme, Maybe Grapheme))]
    replaceLex :: forall t.
ReplacementIndices
-> Lexeme 'Replacement
-> MultiZipper t Grapheme
-> Maybe Grapheme
-> [(ReplacementIndices, (MultiZipper t Grapheme, Maybe Grapheme))]
replaceLex ReplacementIndices
ixs (Grapheme Grapheme
g) MultiZipper t Grapheme
mz Maybe Grapheme
_prev = [(ReplacementIndices
ixs, (forall a t. a -> MultiZipper t a -> MultiZipper t a
insert Grapheme
g MultiZipper t Grapheme
mz, forall a. a -> Maybe a
Just Grapheme
g))]
    replaceLex ReplacementIndices
ixs (Category PWord
gs) MultiZipper t Grapheme
mz Maybe Grapheme
_prev =
        case ReplacementIndices -> Int -> (CategoryNumber, ReplacementIndices)
advanceCategory ReplacementIndices
ixs Int
numCatsMatched of
            (CategoryNumber Int
ci, ReplacementIndices
ixs') ->
                let i :: Int
i = MatchOutput -> [Int]
matchedCatIxs MatchOutput
out forall a. [a] -> Int -> a
!! Int
ci in
                    case PWord
gs forall a. [a] -> Int -> Maybe a
!? Int
i of
                        Just Grapheme
g   -> [(ReplacementIndices
ixs', (forall a t. a -> MultiZipper t a -> MultiZipper t a
insert Grapheme
g MultiZipper t Grapheme
mz, forall a. a -> Maybe a
Just Grapheme
g))]
                        Maybe Grapheme
Nothing  -> [(ReplacementIndices
ixs', (forall a t. a -> MultiZipper t a -> MultiZipper t a
insert (String -> Grapheme
GMulti String
"\xfffd") MultiZipper t Grapheme
mz, forall a. Maybe a
Nothing))]  -- Unicode replacement character

            (CategoryNumber
Nondeterministic, ReplacementIndices
ixs') -> PWord
gs forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Grapheme
g -> (ReplacementIndices
ixs', (forall a t. a -> MultiZipper t a -> MultiZipper t a
insert Grapheme
g MultiZipper t Grapheme
mz, forall a. a -> Maybe a
Just Grapheme
g))
    replaceLex ReplacementIndices
ixs (Optional [Lexeme 'Replacement]
ls) MultiZipper t Grapheme
mz Maybe Grapheme
prev =
        let (Int
co, ReplacementIndices
ixs') = ReplacementIndices -> (Int, ReplacementIndices)
advanceOptional ReplacementIndices
ixs in
            case MatchOutput -> [Bool]
matchedOptionals MatchOutput
out forall a. [a] -> Int -> Maybe a
!? Int
co of
                Just Bool
True -> forall t.
ReplacementIndices
-> [Lexeme 'Replacement]
-> (MultiZipper t Grapheme, Maybe Grapheme)
-> [(ReplacementIndices, (MultiZipper t Grapheme, Maybe Grapheme))]
go ReplacementIndices
ixs' [Lexeme 'Replacement]
ls (MultiZipper t Grapheme
mz, Maybe Grapheme
prev)
                Just Bool
False -> [(ReplacementIndices
ixs', (MultiZipper t Grapheme
mz, forall a. Maybe a
Nothing))]
                Maybe Bool
Nothing    ->  (ReplacementIndices
ixs', (MultiZipper t Grapheme
mz, forall a. Maybe a
Nothing)) forall a. a -> [a] -> [a]
: forall t.
ReplacementIndices
-> [Lexeme 'Replacement]
-> (MultiZipper t Grapheme, Maybe Grapheme)
-> [(ReplacementIndices, (MultiZipper t Grapheme, Maybe Grapheme))]
go ReplacementIndices
ixs [Lexeme 'Replacement]
ls (MultiZipper t Grapheme
mz, Maybe Grapheme
prev)
    replaceLex ReplacementIndices
ixs Lexeme 'Replacement
Metathesis MultiZipper t Grapheme
mz Maybe Grapheme
_prev =
        [( ReplacementIndices
ixs
         , ( forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a t. [a] -> MultiZipper t a -> MultiZipper t a
insertMany MultiZipper t Grapheme
mz forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ MatchOutput -> PWord
matchedGraphemes MatchOutput
out
           , forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ MatchOutput -> PWord
matchedGraphemes MatchOutput
out)
         )]
    replaceLex ReplacementIndices
ixs Lexeme 'Replacement
Geminate MultiZipper t Grapheme
mz Maybe Grapheme
prev =
        [(ReplacementIndices
ixs, (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a t. [a] -> MultiZipper t a -> MultiZipper t a
insertMany MultiZipper t Grapheme
mz forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> [a]
maybeToList Maybe Grapheme
prev, Maybe Grapheme
prev))]
    replaceLex ReplacementIndices
ixs Lexeme 'Replacement
Discard MultiZipper t Grapheme
mz Maybe Grapheme
prev =
        let (CategoryNumber
_, ReplacementIndices
ixs') = ReplacementIndices -> Int -> (CategoryNumber, ReplacementIndices)
advanceCategory ReplacementIndices
ixs Int
numCatsMatched
        in [(ReplacementIndices
ixs', (MultiZipper t Grapheme
mz, Maybe Grapheme
prev))]
    replaceLex ReplacementIndices
ixs (Backreference Int
i PWord
c) MultiZipper t Grapheme
mz Maybe Grapheme
prev =
        let ixs' :: ReplacementIndices
ixs' = CategoryNumber -> ReplacementIndices -> ReplacementIndices
forceCategory (Int -> CategoryNumber
CategoryNumber forall a b. (a -> b) -> a -> b
$ Int
iforall a. Num a => a -> a -> a
-Int
1) ReplacementIndices
ixs -- 1-based indexing!

        in forall t.
ReplacementIndices
-> Lexeme 'Replacement
-> MultiZipper t Grapheme
-> Maybe Grapheme
-> [(ReplacementIndices, (MultiZipper t Grapheme, Maybe Grapheme))]
replaceLex ReplacementIndices
ixs' (forall (a :: LexemeType). PWord -> Lexeme a
Category PWord
c) MultiZipper t Grapheme
mz Maybe Grapheme
prev
    replaceLex ReplacementIndices
ixs (Multiple PWord
c) MultiZipper t Grapheme
mz Maybe Grapheme
prev =
        let ixs' :: ReplacementIndices
ixs' = CategoryNumber -> ReplacementIndices -> ReplacementIndices
forceCategory CategoryNumber
Nondeterministic ReplacementIndices
ixs
        in forall t.
ReplacementIndices
-> Lexeme 'Replacement
-> MultiZipper t Grapheme
-> Maybe Grapheme
-> [(ReplacementIndices, (MultiZipper t Grapheme, Maybe Grapheme))]
replaceLex ReplacementIndices
ixs' (forall (a :: LexemeType). PWord -> Lexeme a
Category PWord
c) MultiZipper t Grapheme
mz Maybe Grapheme
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 Grapheme -> [Int]
exceptionAppliesAtPoint [Lexeme 'Target]
target ([Lexeme 'Env]
ex1, [Lexeme 'Env]
ex2) MultiZipper RuleTag Grapheme
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 Grapheme
-> [(a, MultiZipper RuleTag Grapheme)]
runRuleAp MultiZipper RuleTag Grapheme
mz forall a b. (a -> b) -> a -> b
$ do
    MatchOutput
_ <- forall a.
(MultiZipper RuleTag Grapheme
 -> [(a, MultiZipper RuleTag Grapheme)])
-> RuleAp a
RuleAp forall a b. (a -> b) -> a -> b
$ forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
Maybe Grapheme
-> [Lexeme a]
-> MultiZipper t Grapheme
-> [(MatchOutput, MultiZipper t Grapheme)]
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 Grapheme
 -> [(a, MultiZipper RuleTag Grapheme)])
-> RuleAp a
RuleAp forall a b. (a -> b) -> a -> b
$ forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
Maybe Grapheme
-> [Lexeme a]
-> MultiZipper t Grapheme
-> [(MatchOutput, MultiZipper t Grapheme)]
matchMany' forall a. Maybe a
Nothing [Lexeme 'Target]
target
    MatchOutput
_ <- forall a.
(MultiZipper RuleTag Grapheme
 -> [(a, MultiZipper RuleTag Grapheme)])
-> RuleAp a
RuleAp forall a b. (a -> b) -> a -> b
$ forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
Maybe Grapheme
-> [Lexeme a]
-> MultiZipper t Grapheme
-> [(MatchOutput, MultiZipper t Grapheme)]
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 target and environment, determine if they 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
    :: [Lexeme 'Target]
    -> Environment
    -> MultiZipper RuleTag Grapheme
    -> [(MatchOutput, MultiZipper RuleTag Grapheme)]
matchRuleAtPoint :: [Lexeme 'Target]
-> Environment
-> MultiZipper RuleTag Grapheme
-> [(MatchOutput, MultiZipper RuleTag Grapheme)]
matchRuleAtPoint [Lexeme 'Target]
target ([Lexeme 'Env]
env1,[Lexeme 'Env]
env2) MultiZipper RuleTag Grapheme
mz = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a.
RuleAp a
-> MultiZipper RuleTag Grapheme
-> [(a, MultiZipper RuleTag Grapheme)]
runRuleAp MultiZipper RuleTag Grapheme
mz forall a b. (a -> b) -> a -> b
$ do
    MatchOutput
_ <- forall a.
(MultiZipper RuleTag Grapheme
 -> [(a, MultiZipper RuleTag Grapheme)])
-> RuleAp a
RuleAp forall a b. (a -> b) -> a -> b
$ forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
Maybe Grapheme
-> [Lexeme a]
-> MultiZipper t Grapheme
-> [(MatchOutput, MultiZipper t Grapheme)]
matchMany' forall a. Maybe a
Nothing [Lexeme 'Env]
env1
    -- start of target needs to be INSIDE 'MultiZipper'!

    -- otherwise get weird things like /x/#_ resulting in

    -- #abc#→#xabd#x when it should be #abc#→#xabc#

    forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall t a. MultiZipper t a -> Bool
atBoundary forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> forall a.
(MultiZipper RuleTag Grapheme
 -> [(a, MultiZipper RuleTag Grapheme)])
-> RuleAp a
RuleAp forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const []
        Bool
False -> 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
TargetStart
            MatchOutput
matchResult <- forall a.
(MultiZipper RuleTag Grapheme
 -> [(a, MultiZipper RuleTag Grapheme)])
-> RuleAp a
RuleAp forall a b. (a -> b) -> a -> b
$ forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
Maybe Grapheme
-> [Lexeme a]
-> MultiZipper t Grapheme
-> [(MatchOutput, MultiZipper t Grapheme)]
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 Grapheme
 -> [(a, MultiZipper RuleTag Grapheme)])
-> RuleAp a
RuleAp forall a b. (a -> b) -> a -> b
$ forall (a :: LexemeType) t.
OneOf a 'Target 'Env =>
Maybe Grapheme
-> [Lexeme a]
-> MultiZipper t Grapheme
-> [(MatchOutput, MultiZipper t Grapheme)]
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 Grapheme) [] Bool
applyOnce r :: Rule
r@Rule{[Lexeme 'Target]
target :: Rule -> [Lexeme 'Target]
target :: [Lexeme 'Target]
target, [Lexeme 'Replacement]
replacement :: Rule -> [Lexeme 'Replacement]
replacement :: [Lexeme 'Replacement]
replacement, Maybe Environment
exception :: Rule -> Maybe Environment
exception :: Maybe Environment
exception} =
    forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (forall t a. Ord t => t -> MultiZipper t a -> MultiZipper t a
tag RuleTag
AppStart) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Environment] -> StateT (MultiZipper RuleTag Grapheme) [] Bool
go (Rule -> [Environment]
environment Rule
r)
  where
    go :: [Environment] -> StateT (MultiZipper RuleTag Grapheme) [] Bool
go [] = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    go (Environment
env:[Environment]
envs) = do
        Maybe MatchOutput
result <- forall s a. (s -> [(a, s)]) -> StateT s [] (Maybe a)
try ([Lexeme 'Target]
-> Environment
-> MultiZipper RuleTag Grapheme
-> [(MatchOutput, MultiZipper RuleTag Grapheme)]
matchRuleAtPoint [Lexeme 'Target]
target Environment
env)
        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 Grapheme -> [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 Grapheme
-> [MultiZipper t Grapheme]
mkReplacement MatchOutput
out [Lexeme 'Replacement]
replacement
                        forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            Maybe MatchOutput
Nothing -> forall (m :: * -> *) s. Monad m => (s -> Maybe s) -> StateT s m ()
modifyMay (forall t a.
Ord t =>
t -> MultiZipper t a -> Maybe (MultiZipper t a)
seek RuleTag
AppStart) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Environment] -> StateT (MultiZipper RuleTag Grapheme) [] Bool
go [Environment]
envs

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

    let startingPos :: MultiZipper RuleTag Grapheme
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 Grapheme
mz
            Direction
RTL -> forall t a. MultiZipper t a -> MultiZipper t a
toEnd MultiZipper RuleTag Grapheme
mz
        result :: [MultiZipper RuleTag Grapheme]
result = StateT (MultiZipper RuleTag Grapheme) [] Bool
-> MultiZipper RuleTag Grapheme -> [MultiZipper RuleTag Grapheme]
repeatRule (Rule -> StateT (MultiZipper RuleTag Grapheme) [] Bool
applyOnce Rule
r) MultiZipper RuleTag Grapheme
startingPos
    in if Flags -> Bool
sporadic forall a b. (a -> b) -> a -> b
$ Rule -> Flags
flags Rule
r
          then MultiZipper RuleTag Grapheme
mz forall a. a -> [a] -> [a]
: [MultiZipper RuleTag Grapheme]
result
          else [MultiZipper RuleTag Grapheme]
result
  where
    repeatRule
        :: StateT (MultiZipper RuleTag Grapheme) [] Bool
        -> MultiZipper RuleTag Grapheme
        -> [MultiZipper RuleTag Grapheme]
    repeatRule :: StateT (MultiZipper RuleTag Grapheme) [] Bool
-> MultiZipper RuleTag Grapheme -> [MultiZipper RuleTag Grapheme]
repeatRule StateT (MultiZipper RuleTag Grapheme) [] Bool
m MultiZipper RuleTag Grapheme
mz = forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT (MultiZipper RuleTag Grapheme) [] Bool
m MultiZipper RuleTag Grapheme
mz forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \(Bool
success, MultiZipper RuleTag Grapheme
mz') ->
        if Bool
success Bool -> Bool -> Bool
&& Flags -> Bool
applyOnceOnly (Rule -> Flags
flags Rule
r)
        then [MultiZipper RuleTag Grapheme
mz']
        else case Bool
-> Rule
-> MultiZipper RuleTag Grapheme
-> Maybe (MultiZipper RuleTag Grapheme)
setupForNextApplication Bool
success Rule
r MultiZipper RuleTag Grapheme
mz' of
            Just MultiZipper RuleTag Grapheme
mz'' -> StateT (MultiZipper RuleTag Grapheme) [] Bool
-> MultiZipper RuleTag Grapheme -> [MultiZipper RuleTag Grapheme]
repeatRule StateT (MultiZipper RuleTag Grapheme) [] Bool
m MultiZipper RuleTag Grapheme
mz''
            Maybe (MultiZipper RuleTag Grapheme)
Nothing -> [MultiZipper RuleTag Grapheme
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 Grapheme -> MultiZipper RuleTag Grapheme
checkGraphemes (CategoriesDecl PWord
gs) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ \case
    Grapheme
GBoundary -> Grapheme
GBoundary
    Grapheme
g -> if Grapheme
g forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` PWord
gs then Grapheme
g else String -> Grapheme
GMulti String
"\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 Grapheme -> [MultiZipper RuleTag Grapheme]
applyStatement (RuleS Rule
r) MultiZipper RuleTag Grapheme
mz = Rule
-> MultiZipper RuleTag Grapheme -> [MultiZipper RuleTag Grapheme]
applyRule Rule
r MultiZipper RuleTag Grapheme
mz
applyStatement (CategoriesDeclS CategoriesDecl
gs) MultiZipper RuleTag Grapheme
mz = [CategoriesDecl
-> MultiZipper RuleTag Grapheme -> MultiZipper RuleTag Grapheme
checkGraphemes CategoriesDecl
gs MultiZipper RuleTag Grapheme
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 Grapheme -> [MultiZipper RuleTag Grapheme]
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 -> PWord
addBoundaries
    forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a t. [a] -> MultiZipper t a
fromListStart
    forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Statement
-> MultiZipper RuleTag Grapheme -> [MultiZipper RuleTag Grapheme]
applyStatement Statement
st
    forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall t a. MultiZipper t a -> [a]
toList forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> PWord -> PWord
removeBoundaries)
    forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall a. Ord a => [a] -> [a]
nubOrd

-- | 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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogItem r] -> ShowS
$cshowList :: forall r. Show r => [LogItem r] -> ShowS
show :: LogItem r -> String
$cshow :: forall r. Show r => LogItem r -> String
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 -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PWordLog r] -> ShowS
$cshowList :: forall r. Show r => [PWordLog r] -> ShowS
show :: PWordLog r -> String
$cshow :: forall r. Show r => PWordLog r -> String
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 -> String) -> PWordLog r -> String
reportAsHtmlRows r -> String
render PWordLog r
item = String -> [(PWord, r)] -> String
go (PWord -> String
concatWithBoundary 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 :: String -> [(PWord, r)] -> String
go String
_ [] = String
""
    go String
cell1 ((PWord
output, r
action) : [(PWord, r)]
ds) =
        (String
"<tr><td>" forall a. [a] -> [a] -> [a]
++ String
cell1 forall a. [a] -> [a] -> [a]
++ String
"</td><td>&rarr;</td><td>"
         forall a. [a] -> [a] -> [a]
++ PWord -> String
concatWithBoundary PWord
output
         forall a. [a] -> [a] -> [a]
++ String
"</td><td>(" forall a. [a] -> [a] -> [a]
++ r -> String
render r
action forall a. [a] -> [a] -> [a]
++ String
")</td></tr>")
        forall a. [a] -> [a] -> [a]
++ String -> [(PWord, r)] -> String
go String
"" [(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 -> String) -> PWordLog r -> String
reportAsText r -> String
render PWordLog r
item = [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
    PWord -> String
concatWithBoundary (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 (String, r) -> String
toLine (forall {b}. [(PWord, b)] -> [(String, b)]
alignWithPadding forall a b. (a -> b) -> a -> b
$ forall r. PWordLog r -> [(PWord, r)]
derivations PWordLog r
item)
  where
    alignWithPadding :: [(PWord, b)] -> [(String, b)]
alignWithPadding [(PWord, b)]
ds =
        let (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PWord -> String
concatWithBoundary -> [String]
outputs, [b]
actions) = forall a b. [(a, b)] -> ([a], [b])
unzip [(PWord, 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
<$> [String]
outputs
            padded :: [String]
padded = [String]
outputs forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \String
o -> String
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 String
o) Char
' '
        in forall a b. [a] -> [b] -> [(a, b)]
zip [String]
padded [b]
actions

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

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