PairedTransformer.hs

{-# 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
    { ignoresTagStack :: HtmlTagStack -> Bool
    , matchStart :: [match] -> Text -> Maybe (match, Text, Text, Text)
    , matchEnd :: Text -> Maybe (match, Text, Text, Text)
    , areMatchesPaired :: match -> match -> Bool
    , 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 (PairedTransformer ignores start end arePaired transform) =
    iter [] . normalizeText
  where
    iter :: [Unclosed m] -> [HtmlEntity] -> [HtmlEntity]
    iter [] [] = []
    iter stack [] = unstack stack
    iter stack (x@HtmlText { tagStack = ts, rawText = txt } : xs) =
        case (startMatch, endMatch) of
            (Just captured, Nothing) ->
                roll stack captured ts xs
            (Nothing, Just captured@(m, _, _, _))
              | Prelude.any ((`arePaired` m) . match) stack ->
                    unroll stack captured ts xs
            (Just captured@(_, pre, _, _), Just captured'@(m', pre', _, _)) ->
                if Data.Text.length pre >= Data.Text.length pre' &&
                    Prelude.any ((`arePaired` m') . match) stack
                then unroll stack captured' ts xs
                else roll stack captured ts xs
            (Nothing, _) ->
                case stack of
                    [] -> x : iter stack xs
                    s : ss -> iter (s { buffer = x : buffer s } : ss) xs
      where
        startMatch :: Maybe (m, Text, Text, Text)
        startMatch = start (reverse $ fmap match stack) txt
        endMatch :: Maybe (m, Text, Text, Text)
        endMatch = end txt
    iter (s@Unclosed {} : ss) (x : xs) =
        iter (s { buffer = x : buffer s } : ss) xs
    iter [] (x : xs) = x : iter [] xs
    roll :: [Unclosed m]
         -> (m, Text, Text, Text)
         -> HtmlTagStack
         -> [HtmlEntity]
         -> [HtmlEntity]
    roll [] (startMatch, pre, t, post) tagStack_ entities =
        prependText tagStack_ pre $ iter
            [Unclosed startMatch [HtmlText tagStack_ t]]
            (normalizeText (prependText tagStack_ post entities))
    roll (s : ss) (startMatch, pre, t, post) tagStack_ entities = iter
        ( Unclosed startMatch [HtmlText tagStack_ t]
        : s { buffer = prependText tagStack_ pre $ buffer s }
        : ss
        )
        (normalizeText (prependText tagStack_ post entities))
    unroll :: [Unclosed m]
           -> (m, Text, Text, Text)
           -> HtmlTagStack
           -> [HtmlEntity]
           -> [HtmlEntity]
    unroll stack (endMatch, pre, t, post) tagStack_ es =
        case remainStack of
            [] -> unrolled ++ iter [] remainEntities
            s : ss -> iter
                (s { buffer = reverse unrolled ++ buffer s } : ss)
                remainEntities
      where
        prependText' :: Text -> [HtmlEntity] -> [HtmlEntity]
        prependText' = prependText tagStack_
        unrolled :: [HtmlEntity]
        remainStack :: [Unclosed m]
        (unrolled, remainStack) = case findPair endMatch stack of
            (_, []) ->
                ([HtmlText tagStack_ (pre `append` t)], [])
            (stack', s@Unclosed { match = startMatch } : ss) ->
                let
                    buf = prependText' pre (unstack' stack' ++ buffer s)
                    buf' = prependText' t buf
                    buf'' = reverse buf'
                    transformed = if Prelude.any (ignores . tagStack) buf''
                       then buf''
                       else transform startMatch endMatch buf''
                in
                    (transformed, ss)
        remainEntities :: [HtmlEntity]
        remainEntities = prependText' post es
    findPair :: m -> [Unclosed m] -> ([Unclosed m], [Unclosed m])
    findPair m = break (arePaired m . match)
    unstack :: [Unclosed m] -> [HtmlEntity]
    unstack = reverse . unstack'
    unstack' :: [Unclosed m] -> [HtmlEntity]
    unstack' [] = []
    unstack' (Unclosed { buffer = b } : ss) = b ++ unstack' ss
    prependText :: HtmlTagStack -> Text -> [HtmlEntity] -> [HtmlEntity]
    prependText tagStack_ txt
      | Data.Text.null txt = id
      | otherwise = (HtmlText tagStack_ txt :)

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