module Text.Replace
  (
    -- * Performing replacement
    replaceWithList, replaceWithMap, replaceWithTrie,

    -- * Specifying replacements
    Replace (..), ReplaceMap, listToMap, mapToAscList,

    -- * Replacements in trie structure
    Trie, Trie' (..), listToTrie, ascListToTrie, mapToTrie, drawTrie,

    -- * Non-empty text
    Text' (..), text'fromString, text'fromText,
  )
  where

-- base
import qualified Data.Foldable      as Foldable
import           Data.Function      (on)
import qualified Data.List.NonEmpty as NonEmpty
import           Data.String        (IsString (..))

-- containers
import           Data.Map        (Map)
import qualified Data.Map.Strict as Map
import           Data.Tree       (Tree)
import qualified Data.Tree       as Tree

-- text
import qualified Data.Text      as T
import qualified Data.Text.Lazy as LT

{- | Apply a list of replacement rules to a string

The search for strings to replace is performed left-to-right, preferring longer
matches to shorter ones.

Internally, the list will be converted to a 'ReplaceMap' using 'listToMap'. If
the list contains more than one replacement for the same search string, the last
mapping is used, and earlier mappings are ignored.

If you are going to be applying the same list of rules to multiple input
strings, you should first convert the list to a 'Trie' using 'listToTrie' and
then use 'replaceWithTrie' instead. -}
replaceWithList :: Foldable f =>
  f Replace    -- ^ List of replacement rules
  -> LT.Text   -- ^ Input string
  -> LT.Text   -- ^ Result after performing replacements on the input string
replaceWithList :: f Replace -> Text -> Text
replaceWithList = Trie -> Text -> Text
replaceWithTrie (Trie -> Text -> Text)
-> (f Replace -> Trie) -> f Replace -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f Replace -> Trie
forall (f :: * -> *). Foldable f => f Replace -> Trie
listToTrie

{- | Apply a map of replacement rules to a string

The search for strings to replace is performed left-to-right, preferring longer
matches to shorter ones.

If you are going to be applying the same list of rules to multiple input
strings, you should first convert the 'Map' to a 'Trie' using 'mapToTrie' and
then use 'replaceWithTrie' instead. -}
replaceWithMap ::
  ReplaceMap    -- ^ Map of replacement rules
  -> LT.Text    -- ^ Input string
  -> LT.Text    -- ^ Result after performing replacements on the input string
replaceWithMap :: ReplaceMap -> Text -> Text
replaceWithMap = Trie -> Text -> Text
replaceWithTrie (Trie -> Text -> Text)
-> (ReplaceMap -> Trie) -> ReplaceMap -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReplaceMap -> Trie
mapToTrie

{- | Apply a trie of replacement rules to a string

The search for strings to replace is performed left-to-right, preferring longer
matches to shorter ones.

To construct a 'Trie', you may use 'listToTrie' or 'mapToTrie'. -}
replaceWithTrie ::
  Trie       -- ^ Map of replacement rules, represented as a trie
  -> LT.Text -- ^ Input string
  -> LT.Text -- ^ Result after performing replacements on the input string
replaceWithTrie :: Trie -> Text -> Text
replaceWithTrie Trie
trie = Text -> Text
go
  where
    go :: Text -> Text
go Text
xs = case Text -> Maybe (Char, Text)
LT.uncons Text
xs of
        Maybe (Char, Text)
Nothing -> Text
LT.empty
        Just (Char
x, Text
xs') -> case Trie -> Text -> Maybe (Text, Text)
replaceWithTrie1 Trie
trie Text
xs of
            Maybe (Text, Text)
Nothing -> Char -> Text -> Text
LT.cons Char
x (Text -> Text
go Text
xs')
            Just (Text
r, Text
xs'') -> Text -> Text -> Text
LT.append (Text -> Text
LT.fromStrict Text
r) (Text -> Text
go Text
xs'')

replaceWithTrie1 :: Trie -> LT.Text -> Maybe (T.Text, LT.Text)
replaceWithTrie1 :: Trie -> Text -> Maybe (Text, Text)
replaceWithTrie1 Trie
trie Text
xs = case Text -> Maybe (Char, Text)
LT.uncons Text
xs of
    Maybe (Char, Text)
Nothing -> Maybe (Text, Text)
forall a. Maybe a
Nothing
    Just (Char
x, Text
xs') -> case Char -> Trie -> Maybe Trie'
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
x Trie
trie of
        Maybe Trie'
Nothing                  -> Maybe (Text, Text)
forall a. Maybe a
Nothing
        Just (Trie' Maybe Text
Nothing Trie
bs)  -> Trie -> Text -> Maybe (Text, Text)
replaceWithTrie1 Trie
bs Text
xs'
        Just (Trie' (Just Text
r) Trie
bs) -> case Trie -> Text -> Maybe (Text, Text)
replaceWithTrie1 Trie
bs Text
xs' of
                                      Maybe (Text, Text)
Nothing -> (Text, Text) -> Maybe (Text, Text)
forall a. a -> Maybe a
Just (Text
r, Text
xs')
                                      Maybe (Text, Text)
longerMatch -> Maybe (Text, Text)
longerMatch

-- | Non-empty text
data Text' = Text'
    { Text' -> Char
text'head :: Char -- ^ The first character of a non-empty string
    , Text' -> Text
text'tail :: T.Text -- ^ All characters of a non-empty string except the first
    }
  deriving (Text' -> Text' -> Bool
(Text' -> Text' -> Bool) -> (Text' -> Text' -> Bool) -> Eq Text'
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Text' -> Text' -> Bool
$c/= :: Text' -> Text' -> Bool
== :: Text' -> Text' -> Bool
$c== :: Text' -> Text' -> Bool
Eq, Eq Text'
Eq Text'
-> (Text' -> Text' -> Ordering)
-> (Text' -> Text' -> Bool)
-> (Text' -> Text' -> Bool)
-> (Text' -> Text' -> Bool)
-> (Text' -> Text' -> Bool)
-> (Text' -> Text' -> Text')
-> (Text' -> Text' -> Text')
-> Ord Text'
Text' -> Text' -> Bool
Text' -> Text' -> Ordering
Text' -> Text' -> Text'
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 :: Text' -> Text' -> Text'
$cmin :: Text' -> Text' -> Text'
max :: Text' -> Text' -> Text'
$cmax :: Text' -> Text' -> Text'
>= :: Text' -> Text' -> Bool
$c>= :: Text' -> Text' -> Bool
> :: Text' -> Text' -> Bool
$c> :: Text' -> Text' -> Bool
<= :: Text' -> Text' -> Bool
$c<= :: Text' -> Text' -> Bool
< :: Text' -> Text' -> Bool
$c< :: Text' -> Text' -> Bool
compare :: Text' -> Text' -> Ordering
$ccompare :: Text' -> Text' -> Ordering
$cp1Ord :: Eq Text'
Ord)

instance Show Text' where
    showsPrec :: Int -> Text' -> ShowS
showsPrec Int
i (Text' Char
x Text
xs) = Int -> Text -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
i (Char -> Text -> Text
LT.cons Char
x (Text -> Text
LT.fromStrict Text
xs))

{- | @'fromString' = 'text'fromString'@

🌶️ Warning: @('fromString' "" :: 'Text'') = ⊥@ -}
instance IsString Text' where
    fromString :: String -> Text'
fromString = String -> Text'
text'fromString

{- | Convert an ordinary 'String' to a non-empty 'Text''

🌶️ Warning: @text'fromString "" = ⊥@ -}
text'fromString :: String -> Text'
text'fromString :: String -> Text'
text'fromString [] = String -> Text'
forall a. HasCallStack => String -> a
error String
"Text' cannot be empty"
text'fromString (Char
x : String
xs) = Char -> Text -> Text'
Text' Char
x (String -> Text
T.pack String
xs)

{- | Convert an ordinary 'T.Text' to a non-empty 'Text''

🌶️ Warning: @text'fromText "" = ⊥@ -}
text'fromText :: T.Text -> Text'
text'fromText :: Text -> Text'
text'fromText Text
t = case Text -> Maybe (Char, Text)
T.uncons Text
t of
    Maybe (Char, Text)
Nothing -> String -> Text'
forall a. HasCallStack => String -> a
error String
"Text' cannot be empty"
    Just (Char
x, Text
xs) -> Char -> Text -> Text'
Text' Char
x Text
xs

{- | A replacement rule

@Replace "abc" "xyz"@ means "When you encounter the string __@abc@__ in the
input text, replace it with __@xyz@__."

The first argument must be a non-empty string, because there is no sensible way
to interpret "replace all occurrences of the empty string." -}
data Replace = Replace
    { Replace -> Text'
replaceFrom :: Text' -- ^ A string we're looking for
    , Replace -> Text
replaceTo   :: T.Text  -- ^ A string we're replacing it with
    }
    deriving (Replace -> Replace -> Bool
(Replace -> Replace -> Bool)
-> (Replace -> Replace -> Bool) -> Eq Replace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Replace -> Replace -> Bool
$c/= :: Replace -> Replace -> Bool
== :: Replace -> Replace -> Bool
$c== :: Replace -> Replace -> Bool
Eq, Int -> Replace -> ShowS
[Replace] -> ShowS
Replace -> String
(Int -> Replace -> ShowS)
-> (Replace -> String) -> ([Replace] -> ShowS) -> Show Replace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Replace] -> ShowS
$cshowList :: [Replace] -> ShowS
show :: Replace -> String
$cshow :: Replace -> String
showsPrec :: Int -> Replace -> ShowS
$cshowsPrec :: Int -> Replace -> ShowS
Show)

{- | A map where the keys are strings we're looking for and the values are
strings with which we're replacing a key that we find

You may use 'listToMap' to construct a 'ReplaceMap' from a list of replacement
rules, and you may use 'mapToAscList' to convert back to a list. -}
type ReplaceMap = Map Text' T.Text

{- | Construct a replacement map from a list of replacement rules

If the list contains more than one replacement for the same search string, the
last mapping is used, and earlier mappings are ignored. -}
listToMap :: Foldable f => f Replace -> ReplaceMap
listToMap :: f Replace -> ReplaceMap
listToMap = [(Text', Text)] -> ReplaceMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text', Text)] -> ReplaceMap)
-> (f Replace -> [(Text', Text)]) -> f Replace -> ReplaceMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Replace -> (Text', Text)) -> [Replace] -> [(Text', Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Replace -> (Text', Text)
toTuple ([Replace] -> [(Text', Text)])
-> (f Replace -> [Replace]) -> f Replace -> [(Text', Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f Replace -> [Replace]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList
  where
    toTuple :: Replace -> (Text', Text)
toTuple Replace
x = (Replace -> Text'
replaceFrom Replace
x, Replace -> Text
replaceTo Replace
x)

{- | Convert a replacement map to a list of replacement rules

The rules in the list will be sorted according to their 'replaceFrom' field in
ascending order. -}
mapToAscList :: ReplaceMap -> [Replace]
mapToAscList :: ReplaceMap -> [Replace]
mapToAscList = ((Text', Text) -> Replace) -> [(Text', Text)] -> [Replace]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Text'
x, Text
y) -> Text' -> Text -> Replace
Replace Text'
x Text
y) ([(Text', Text)] -> [Replace])
-> (ReplaceMap -> [(Text', Text)]) -> ReplaceMap -> [Replace]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReplaceMap -> [(Text', Text)]
forall k a. Map k a -> [(k, a)]
Map.toAscList

{- | A representation of a 'ReplaceMap' designed for efficient lookups when we
perform the replacements in 'replaceWithTrie'

You may construct a 'Trie' using 'listToTrie' or 'mapToTrie'. -}
type Trie = Map Char Trie'

{- | A variant of 'Trie' which may contain a value at the root of the tree -}
data Trie' = Trie'
    { Trie' -> Maybe Text
trieRoot     :: Maybe T.Text
    , Trie' -> Trie
trieBranches :: Trie
    }
  deriving (Trie' -> Trie' -> Bool
(Trie' -> Trie' -> Bool) -> (Trie' -> Trie' -> Bool) -> Eq Trie'
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Trie' -> Trie' -> Bool
$c/= :: Trie' -> Trie' -> Bool
== :: Trie' -> Trie' -> Bool
$c== :: Trie' -> Trie' -> Bool
Eq, Int -> Trie' -> ShowS
[Trie'] -> ShowS
Trie' -> String
(Int -> Trie' -> ShowS)
-> (Trie' -> String) -> ([Trie'] -> ShowS) -> Show Trie'
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Trie'] -> ShowS
$cshowList :: [Trie'] -> ShowS
show :: Trie' -> String
$cshow :: Trie' -> String
showsPrec :: Int -> Trie' -> ShowS
$cshowsPrec :: Int -> Trie' -> ShowS
Show)

{- | Draws a text diagram of a trie; useful for debugging -}
drawTrie :: Trie -> LT.Text
drawTrie :: Trie -> Text
drawTrie = String -> Text
LT.pack (String -> Text) -> (Trie -> String) -> Trie -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tree String] -> String
Tree.drawForest ([Tree String] -> String)
-> (Trie -> [Tree String]) -> Trie -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree Text -> Tree String) -> [Tree Text] -> [Tree String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> String) -> Tree Text -> Tree String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
T.unpack) ([Tree Text] -> [Tree String])
-> (Trie -> [Tree Text]) -> Trie -> [Tree String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trie -> [Tree Text]
trieForest

trieForest :: Trie -> Tree.Forest T.Text
trieForest :: Trie -> [Tree Text]
trieForest = ((Char, Trie') -> Tree Text) -> [(Char, Trie')] -> [Tree Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Char
c, Trie'
t) -> Text -> Trie' -> Tree Text
trieTree (Char -> Text
T.singleton Char
c) Trie'
t) ([(Char, Trie')] -> [Tree Text])
-> (Trie -> [(Char, Trie')]) -> Trie -> [Tree Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trie -> [(Char, Trie')]
forall k a. Map k a -> [(k, a)]
Map.toAscList

trieTree :: T.Text -> Trie' -> Tree T.Text
trieTree :: Text -> Trie' -> Tree Text
trieTree Text
c (Trie' Maybe Text
r Trie
bs) = case (Maybe Text
r, Trie -> [(Char, Trie')]
forall k a. Map k a -> [(k, a)]
Map.toAscList Trie
bs) of
    (Maybe Text
Nothing, [(Char
c', Trie'
t)]) -> Text -> Trie' -> Tree Text
trieTree (Text -> Char -> Text
T.snoc Text
c Char
c') Trie'
t
    (Maybe Text, [(Char, Trie')])
_ -> Text -> [Tree Text] -> Tree Text
forall a. a -> [Tree a] -> Tree a
Tree.Node (Text -> Text -> Text
T.append Text
c (Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
T.empty (\Text
rr -> String -> Text
T.pack (String
" - " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
rr)) Maybe Text
r))
                   (Trie -> [Tree Text]
trieForest Trie
bs)

{- | Convert a replacement map to a trie, which is used to efficiently implement
'replaceWithTrie' -}
mapToTrie :: ReplaceMap -> Trie
mapToTrie :: ReplaceMap -> Trie
mapToTrie = [Replace] -> Trie
forall (f :: * -> *). Foldable f => f Replace -> Trie
ascListToTrie ([Replace] -> Trie)
-> (ReplaceMap -> [Replace]) -> ReplaceMap -> Trie
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReplaceMap -> [Replace]
mapToAscList

{- | Convert a list of replacement rules to a trie, which is used to efficiently
implement 'replaceWithTrie'

If the list contains more than one replacement for the same search string, the
last mapping is used, and earlier mappings are ignored. -}
listToTrie :: Foldable f => f Replace -> Trie
listToTrie :: f Replace -> Trie
listToTrie = ReplaceMap -> Trie
mapToTrie (ReplaceMap -> Trie)
-> (f Replace -> ReplaceMap) -> f Replace -> Trie
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f Replace -> ReplaceMap
forall (f :: * -> *). Foldable f => f Replace -> ReplaceMap
listToMap

{- | Convert a list of replacement rules to a 'Trie', where the rules must be
sorted in ascending order by the 'replaceFrom' field

🌶️ Warning: this precondition is not checked. If you are not sure, it is safer
to use 'listToTrie' instead. -}
ascListToTrie :: Foldable f =>
  f Replace  -- ^ This list must be sorted according to the 'replaceFrom'
             --   field in ascending order
             --
             -- 🌶️ Warning: this precondition is not checked
  -> Trie
ascListToTrie :: f Replace -> Trie
ascListToTrie =
    [(Char, Trie')] -> Trie
forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList
    ([(Char, Trie')] -> Trie)
-> (f Replace -> [(Char, Trie')]) -> f Replace -> Trie
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty Replace -> (Char, Trie'))
-> [NonEmpty Replace] -> [(Char, Trie')]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\NonEmpty Replace
xs -> (NonEmpty Replace -> Char
firstChar NonEmpty Replace
xs, NonEmpty Replace -> Trie'
subtrie NonEmpty Replace
xs))
    ([NonEmpty Replace] -> [(Char, Trie')])
-> (f Replace -> [NonEmpty Replace])
-> f Replace
-> [(Char, Trie')]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Replace -> Replace -> Bool) -> f Replace -> [NonEmpty Replace]
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty a]
NonEmpty.groupBy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Char -> Char -> Bool)
-> (Replace -> Char) -> Replace -> Replace -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Text' -> Char
text'head (Text' -> Char) -> (Replace -> Text') -> Replace -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Replace -> Text'
replaceFrom))
  where
    firstChar :: NonEmpty Replace -> Char
firstChar = Text' -> Char
text'head (Text' -> Char)
-> (NonEmpty Replace -> Text') -> NonEmpty Replace -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Replace -> Text'
replaceFrom (Replace -> Text')
-> (NonEmpty Replace -> Replace) -> NonEmpty Replace -> Text'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Replace -> Replace
forall a. NonEmpty a -> a
NonEmpty.head
    subtrie :: NonEmpty Replace -> Trie'
subtrie = NonEmpty (Text, Text) -> Trie'
forall (f :: * -> *). Foldable f => f (Text, Text) -> Trie'
ascListToTrie' (NonEmpty (Text, Text) -> Trie')
-> (NonEmpty Replace -> NonEmpty (Text, Text))
-> NonEmpty Replace
-> Trie'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Replace -> (Text, Text))
-> NonEmpty Replace -> NonEmpty (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Replace Text'
x Text
y) -> (Text' -> Text
text'tail Text'
x, Text
y))

ascListToTrie' :: Foldable f =>
  f (T.Text, T.Text)  -- ^ This list must be sorted according to the left
                      --   field of the tuple in ascending order
                      --
                      -- 🌶️ Warning: this precondition is not checked
  -> Trie'
ascListToTrie' :: f (Text, Text) -> Trie'
ascListToTrie' = [(Text, Text)] -> Trie'
f ([(Text, Text)] -> Trie')
-> (f (Text, Text) -> [(Text, Text)]) -> f (Text, Text) -> Trie'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f (Text, Text) -> [(Text, Text)]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Foldable.toList
  where
    f :: [(T.Text, T.Text)] -> Trie'
    f :: [(Text, Text)] -> Trie'
f ((Text
a, Text
x) : [(Text, Text)]
xs') | Text -> Bool
T.null Text
a = Maybe Text -> Trie -> Trie'
Trie' (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x) ([(Text, Text)] -> Trie
forall (f :: * -> *).
(Foldable f, Functor f) =>
f (Text, Text) -> Trie
g [(Text, Text)]
xs')
    f [(Text, Text)]
xs                        = Maybe Text -> Trie -> Trie'
Trie' Maybe Text
forall a. Maybe a
Nothing ([(Text, Text)] -> Trie
forall (f :: * -> *).
(Foldable f, Functor f) =>
f (Text, Text) -> Trie
g [(Text, Text)]
xs)

    g :: (Foldable f, Functor f) => f (T.Text, T.Text) -> Trie
    g :: f (Text, Text) -> Trie
g = f Replace -> Trie
forall (f :: * -> *). Foldable f => f Replace -> Trie
ascListToTrie (f Replace -> Trie)
-> (f (Text, Text) -> f Replace) -> f (Text, Text) -> Trie
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Text) -> Replace) -> f (Text, Text) -> f Replace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Text
x, Text
y) -> Text' -> Text -> Replace
Replace (Text -> Text'
text'fromText Text
x) Text
y)