{-# LANGUAGE ScopedTypeVariables #-}
module Text.Seonbi.PairedTransformer
    ( PairedTransformer (..)
    , transformPairs
    ) where

import Data.Text hiding (break, reverse)

import Text.Seonbi.Html

-- | Settings for 'transformPairs'.
data PairedTransformer match = PairedTransformer
    { forall match. PairedTransformer match -> HtmlTagStack -> Bool
ignoresTagStack :: HtmlTagStack -> Bool
    , forall match.
PairedTransformer match
-> [match] -> Text -> Maybe (match, Text, Text, Text)
matchStart :: [match] -> Text -> Maybe (match, Text, Text, Text)
    , forall match.
PairedTransformer match -> Text -> Maybe (match, Text, Text, Text)
matchEnd :: Text -> Maybe (match, Text, Text, Text)
    , forall match. PairedTransformer match -> match -> match -> Bool
areMatchesPaired :: match -> match -> Bool
    , forall match.
PairedTransformer match
-> match -> match -> [HtmlEntity] -> [HtmlEntity]
transformPair :: match -> match -> [HtmlEntity] -> [HtmlEntity]
    }

-- | Some transformations should be done only if a start and an end are paired
-- like parentheses.  These even usually can be nested.  Even if there is
-- a start and an end they should not be paired unless they are sibling in
-- an HTML tree.
--
-- These kinds of scanning are easily turned highly stateful and imperative,
-- hence hard to debug.  This base class provides the common logic between
-- these kinds of paired transformations so that an implementation class fill
-- several abstract methods triggered by the state machine.
transformPairs :: forall m . PairedTransformer m -> [HtmlEntity] -> [HtmlEntity]
transformPairs :: forall m. PairedTransformer m -> [HtmlEntity] -> [HtmlEntity]
transformPairs (PairedTransformer HtmlTagStack -> Bool
ignores [m] -> Text -> Maybe (m, Text, Text, Text)
start Text -> Maybe (m, Text, Text, Text)
end m -> m -> Bool
arePaired m -> m -> [HtmlEntity] -> [HtmlEntity]
transform) =
    [Unclosed m] -> [HtmlEntity] -> [HtmlEntity]
iter [] forall b c a. (b -> c) -> (a -> b) -> a -> c
. [HtmlEntity] -> [HtmlEntity]
normalizeText
  where
    iter :: [Unclosed m] -> [HtmlEntity] -> [HtmlEntity]
    iter :: [Unclosed m] -> [HtmlEntity] -> [HtmlEntity]
iter [] [] = []
    iter [Unclosed m]
stack [] = [Unclosed m] -> [HtmlEntity]
unstack [Unclosed m]
stack
    iter [Unclosed m]
stack (x :: HtmlEntity
x@HtmlText { tagStack :: HtmlEntity -> HtmlTagStack
tagStack = HtmlTagStack
ts, rawText :: HtmlEntity -> Text
rawText = Text
txt } : [HtmlEntity]
xs) =
        case (Maybe (m, Text, Text, Text)
startMatch, Maybe (m, Text, Text, Text)
endMatch) of
            (Just (m, Text, Text, Text)
captured, Maybe (m, Text, Text, Text)
Nothing) ->
                [Unclosed m]
-> (m, Text, Text, Text)
-> HtmlTagStack
-> [HtmlEntity]
-> [HtmlEntity]
roll [Unclosed m]
stack (m, Text, Text, Text)
captured HtmlTagStack
ts [HtmlEntity]
xs
            (Maybe (m, Text, Text, Text)
Nothing, Just captured :: (m, Text, Text, Text)
captured@(m
m, Text
_, Text
_, Text
_))
              | forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
Prelude.any ((m -> m -> Bool
`arePaired` m
m) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall match. Unclosed match -> match
match) [Unclosed m]
stack ->
                    [Unclosed m]
-> (m, Text, Text, Text)
-> HtmlTagStack
-> [HtmlEntity]
-> [HtmlEntity]
unroll [Unclosed m]
stack (m, Text, Text, Text)
captured HtmlTagStack
ts [HtmlEntity]
xs
            (Just captured :: (m, Text, Text, Text)
captured@(m
_, Text
pre, Text
_, Text
_), Just captured' :: (m, Text, Text, Text)
captured'@(m
m', Text
pre', Text
_, Text
_)) ->
                if Text -> Int
Data.Text.length Text
pre forall a. Ord a => a -> a -> Bool
>= Text -> Int
Data.Text.length Text
pre' Bool -> Bool -> Bool
&&
                    forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
Prelude.any ((m -> m -> Bool
`arePaired` m
m') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall match. Unclosed match -> match
match) [Unclosed m]
stack
                then [Unclosed m]
-> (m, Text, Text, Text)
-> HtmlTagStack
-> [HtmlEntity]
-> [HtmlEntity]
unroll [Unclosed m]
stack (m, Text, Text, Text)
captured' HtmlTagStack
ts [HtmlEntity]
xs
                else [Unclosed m]
-> (m, Text, Text, Text)
-> HtmlTagStack
-> [HtmlEntity]
-> [HtmlEntity]
roll [Unclosed m]
stack (m, Text, Text, Text)
captured HtmlTagStack
ts [HtmlEntity]
xs
            (Maybe (m, Text, Text, Text)
Nothing, Maybe (m, Text, Text, Text)
_) ->
                case [Unclosed m]
stack of
                    [] -> HtmlEntity
x forall a. a -> [a] -> [a]
: [Unclosed m] -> [HtmlEntity] -> [HtmlEntity]
iter [Unclosed m]
stack [HtmlEntity]
xs
                    Unclosed m
s : [Unclosed m]
ss -> [Unclosed m] -> [HtmlEntity] -> [HtmlEntity]
iter (Unclosed m
s { buffer :: [HtmlEntity]
buffer = HtmlEntity
x forall a. a -> [a] -> [a]
: forall match. Unclosed match -> [HtmlEntity]
buffer Unclosed m
s } forall a. a -> [a] -> [a]
: [Unclosed m]
ss) [HtmlEntity]
xs
      where
        startMatch :: Maybe (m, Text, Text, Text)
        startMatch :: Maybe (m, Text, Text, Text)
startMatch = [m] -> Text -> Maybe (m, Text, Text, Text)
start (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall match. Unclosed match -> match
match [Unclosed m]
stack) Text
txt
        endMatch :: Maybe (m, Text, Text, Text)
        endMatch :: Maybe (m, Text, Text, Text)
endMatch = Text -> Maybe (m, Text, Text, Text)
end Text
txt
    iter (s :: Unclosed m
s@Unclosed {} : [Unclosed m]
ss) (HtmlEntity
x : [HtmlEntity]
xs) =
        [Unclosed m] -> [HtmlEntity] -> [HtmlEntity]
iter (Unclosed m
s { buffer :: [HtmlEntity]
buffer = HtmlEntity
x forall a. a -> [a] -> [a]
: forall match. Unclosed match -> [HtmlEntity]
buffer Unclosed m
s } forall a. a -> [a] -> [a]
: [Unclosed m]
ss) [HtmlEntity]
xs
    iter [] (HtmlEntity
x : [HtmlEntity]
xs) = HtmlEntity
x forall a. a -> [a] -> [a]
: [Unclosed m] -> [HtmlEntity] -> [HtmlEntity]
iter [] [HtmlEntity]
xs
    roll :: [Unclosed m]
         -> (m, Text, Text, Text)
         -> HtmlTagStack
         -> [HtmlEntity]
         -> [HtmlEntity]
    roll :: [Unclosed m]
-> (m, Text, Text, Text)
-> HtmlTagStack
-> [HtmlEntity]
-> [HtmlEntity]
roll [] (m
startMatch, Text
pre, Text
t, Text
post) HtmlTagStack
tagStack_ [HtmlEntity]
entities =
        HtmlTagStack -> Text -> [HtmlEntity] -> [HtmlEntity]
prependText HtmlTagStack
tagStack_ Text
pre forall a b. (a -> b) -> a -> b
$ [Unclosed m] -> [HtmlEntity] -> [HtmlEntity]
iter
            [forall match. match -> [HtmlEntity] -> Unclosed match
Unclosed m
startMatch [HtmlTagStack -> Text -> HtmlEntity
HtmlText HtmlTagStack
tagStack_ Text
t]]
            ([HtmlEntity] -> [HtmlEntity]
normalizeText (HtmlTagStack -> Text -> [HtmlEntity] -> [HtmlEntity]
prependText HtmlTagStack
tagStack_ Text
post [HtmlEntity]
entities))
    roll (Unclosed m
s : [Unclosed m]
ss) (m
startMatch, Text
pre, Text
t, Text
post) HtmlTagStack
tagStack_ [HtmlEntity]
entities = [Unclosed m] -> [HtmlEntity] -> [HtmlEntity]
iter
        ( forall match. match -> [HtmlEntity] -> Unclosed match
Unclosed m
startMatch [HtmlTagStack -> Text -> HtmlEntity
HtmlText HtmlTagStack
tagStack_ Text
t]
        forall a. a -> [a] -> [a]
: Unclosed m
s { buffer :: [HtmlEntity]
buffer = HtmlTagStack -> Text -> [HtmlEntity] -> [HtmlEntity]
prependText HtmlTagStack
tagStack_ Text
pre forall a b. (a -> b) -> a -> b
$ forall match. Unclosed match -> [HtmlEntity]
buffer Unclosed m
s }
        forall a. a -> [a] -> [a]
: [Unclosed m]
ss
        )
        ([HtmlEntity] -> [HtmlEntity]
normalizeText (HtmlTagStack -> Text -> [HtmlEntity] -> [HtmlEntity]
prependText HtmlTagStack
tagStack_ Text
post [HtmlEntity]
entities))
    unroll :: [Unclosed m]
           -> (m, Text, Text, Text)
           -> HtmlTagStack
           -> [HtmlEntity]
           -> [HtmlEntity]
    unroll :: [Unclosed m]
-> (m, Text, Text, Text)
-> HtmlTagStack
-> [HtmlEntity]
-> [HtmlEntity]
unroll [Unclosed m]
stack (m
endMatch, Text
pre, Text
t, Text
post) HtmlTagStack
tagStack_ [HtmlEntity]
es =
        case [Unclosed m]
remainStack of
            [] -> [HtmlEntity]
unrolled forall a. [a] -> [a] -> [a]
++ [Unclosed m] -> [HtmlEntity] -> [HtmlEntity]
iter [] [HtmlEntity]
remainEntities
            Unclosed m
s : [Unclosed m]
ss -> [Unclosed m] -> [HtmlEntity] -> [HtmlEntity]
iter
                (Unclosed m
s { buffer :: [HtmlEntity]
buffer = forall a. [a] -> [a]
reverse [HtmlEntity]
unrolled forall a. [a] -> [a] -> [a]
++ forall match. Unclosed match -> [HtmlEntity]
buffer Unclosed m
s } forall a. a -> [a] -> [a]
: [Unclosed m]
ss)
                [HtmlEntity]
remainEntities
      where
        prependText' :: Text -> [HtmlEntity] -> [HtmlEntity]
        prependText' :: Text -> [HtmlEntity] -> [HtmlEntity]
prependText' = HtmlTagStack -> Text -> [HtmlEntity] -> [HtmlEntity]
prependText HtmlTagStack
tagStack_
        unrolled :: [HtmlEntity]
        remainStack :: [Unclosed m]
        ([HtmlEntity]
unrolled, [Unclosed m]
remainStack) = case m -> [Unclosed m] -> ([Unclosed m], [Unclosed m])
findPair m
endMatch [Unclosed m]
stack of
            ([Unclosed m]
_, []) ->
                ([HtmlTagStack -> Text -> HtmlEntity
HtmlText HtmlTagStack
tagStack_ (Text
pre Text -> Text -> Text
`append` Text
t)], [])
            ([Unclosed m]
stack', s :: Unclosed m
s@Unclosed { match :: forall match. Unclosed match -> match
match = m
startMatch } : [Unclosed m]
ss) ->
                let
                    buf :: [HtmlEntity]
buf = Text -> [HtmlEntity] -> [HtmlEntity]
prependText' Text
pre ([Unclosed m] -> [HtmlEntity]
unstack' [Unclosed m]
stack' forall a. [a] -> [a] -> [a]
++ forall match. Unclosed match -> [HtmlEntity]
buffer Unclosed m
s)
                    buf' :: [HtmlEntity]
buf' = Text -> [HtmlEntity] -> [HtmlEntity]
prependText' Text
t [HtmlEntity]
buf
                    buf'' :: [HtmlEntity]
buf'' = forall a. [a] -> [a]
reverse [HtmlEntity]
buf'
                    transformed :: [HtmlEntity]
transformed = if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
Prelude.any (HtmlTagStack -> Bool
ignores forall b c a. (b -> c) -> (a -> b) -> a -> c
. HtmlEntity -> HtmlTagStack
tagStack) [HtmlEntity]
buf''
                       then [HtmlEntity]
buf''
                       else m -> m -> [HtmlEntity] -> [HtmlEntity]
transform m
startMatch m
endMatch [HtmlEntity]
buf''
                in
                    ([HtmlEntity]
transformed, [Unclosed m]
ss)
        remainEntities :: [HtmlEntity]
        remainEntities :: [HtmlEntity]
remainEntities = Text -> [HtmlEntity] -> [HtmlEntity]
prependText' Text
post [HtmlEntity]
es
    findPair :: m -> [Unclosed m] -> ([Unclosed m], [Unclosed m])
    findPair :: m -> [Unclosed m] -> ([Unclosed m], [Unclosed m])
findPair m
m = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (m -> m -> Bool
arePaired m
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall match. Unclosed match -> match
match)
    unstack :: [Unclosed m] -> [HtmlEntity]
    unstack :: [Unclosed m] -> [HtmlEntity]
unstack = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Unclosed m] -> [HtmlEntity]
unstack'
    unstack' :: [Unclosed m] -> [HtmlEntity]
    unstack' :: [Unclosed m] -> [HtmlEntity]
unstack' [] = []
    unstack' (Unclosed { buffer :: forall match. Unclosed match -> [HtmlEntity]
buffer = [HtmlEntity]
b } : [Unclosed m]
ss) = [HtmlEntity]
b forall a. [a] -> [a] -> [a]
++ [Unclosed m] -> [HtmlEntity]
unstack' [Unclosed m]
ss
    prependText :: HtmlTagStack -> Text -> [HtmlEntity] -> [HtmlEntity]
    prependText :: HtmlTagStack -> Text -> [HtmlEntity] -> [HtmlEntity]
prependText HtmlTagStack
tagStack_ Text
txt
      | Text -> Bool
Data.Text.null Text
txt = forall a. a -> a
id
      | Bool
otherwise = (HtmlTagStack -> Text -> HtmlEntity
HtmlText HtmlTagStack
tagStack_ Text
txt forall a. a -> [a] -> [a]
:)

data Unclosed match = Unclosed
    { forall match. Unclosed match -> match
match :: match
    , forall match. Unclosed match -> [HtmlEntity]
buffer :: [HtmlEntity] -- in reverse order
    }