module Text.Replace
(
replaceWithList, replaceWithMap, replaceWithTrie
, Replace (..), ReplaceMap, listToMap, mapToAscList
, Trie, Trie' (..), listToTrie, ascListToTrie, mapToTrie, drawTrie
, Text' (..), text'fromString, text'fromText
) where
import qualified Data.Foldable as Foldable
import Data.Function (on)
import qualified Data.List.NonEmpty as NonEmpty
import Data.String (IsString (..))
import Data.Map (Map)
import qualified Data.Map.Strict as Map
import Data.Tree (Tree)
import qualified Data.Tree as Tree
import qualified Data.Text as T
import qualified Data.Text.Lazy as LT
replaceWithList
:: Foldable f
=> f Replace
-> LT.Text
-> LT.Text
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
replaceWithMap
:: ReplaceMap
-> LT.Text
-> LT.Text
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
replaceWithTrie
:: Trie
-> LT.Text
-> LT.Text
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
data Text' =
Text'
{ Text' -> Char
text'head :: Char
, Text' -> Text
text'tail :: T.Text
}
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))
instance IsString Text'
where
fromString :: String -> Text'
fromString = String -> Text'
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)
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
data Replace =
Replace
{ Replace -> Text'
replaceFrom :: Text'
, Replace -> Text
replaceTo :: T.Text
}
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)
type ReplaceMap = Map Text' T.Text
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)
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
type Trie = Map Char Trie'
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)
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
. Forest String -> String
Tree.drawForest (Forest String -> String)
-> (Trie -> Forest String) -> Trie -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tree Text -> Tree String) -> [Tree Text] -> Forest 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] -> Forest String)
-> (Trie -> [Tree Text]) -> Trie -> Forest 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 -> Forest 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)
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
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
ascListToTrie
:: Foldable f
=> f Replace
-> 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)
-> 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)