module Text.HTML.Truncate(truncateHtml,truncateHtml',truncateStringLike) where
import qualified Text.HTML.TagSoup as TS
import qualified Text.StringLike as SL
import Data.Char(isSpace)
import Data.List(dropWhileEnd)
truncateHtml :: SL.StringLike str => Int -> str -> str
truncateHtml n txt = snd $ truncateHtml' n txt
truncateHtml' :: SL.StringLike str => Int -> str -> (Int,str)
truncateHtml' n txt = fmap (TS.renderTags . removeTrailingEmptyTags) $ go n 0 (TS.parseTags txt)
where
removeTrailingEmptyTags = removeTrailingEmptyTags' [] . reverse
removeTrailingEmptyTags' accm (t@(TS.TagClose _) : ts) = removeTrailingEmptyTags' (t : accm) ts
removeTrailingEmptyTags' accm (t@(TS.TagOpen _ _) : ts) = removeTrailingEmptyTags' (delCloseTag accm) ts
removeTrailingEmptyTags' accm (t@(TS.TagText _) : ts) = reverse (t : ts) ++ accm
removeTrailingEmptyTags' accm (t : ts) = removeTrailingEmptyTags' (t : accm) ts
removeTrailingEmptyTags' accm [] = accm
delCloseTag (t@(TS.TagClose _) : ts) = ts
delCloseTag (t : ts) = t : delCloseTag ts
delCloseTag [] = []
go :: (SL.StringLike str)
=> Int
-> Int
-> [TS.Tag str]
-> (Int,[TS.Tag str])
go c openTags _ | c <= 0 && openTags <= 0 = (0,[])
go i _ [] = (i,[])
go 0 openTags (t@(TS.TagOpen _ _) : ts) = go 0 (openTags + 1) ts
go c openTags (t@(TS.TagOpen _ _) : ts) = fmap (t :) (go c (openTags + 1) ts)
go 0 openTags (t@(TS.TagClose _) : ts) = go 0 (openTags 1) ts
go c openTags (t@(TS.TagClose _) : ts) = fmap (t :) (go c (openTags 1) ts)
go 0 openTags ((TS.TagText str) : ts) = go 0 openTags ts
go c openTags (t@(TS.TagText str) : ts) = case truncateStringLike c str of
(c', str') -> fmap ((TS.TagText str') :) (go (max 0 c') openTags ts)
go c openTags (t : ts) = fmap (t :) (go c openTags ts)
truncateStringLike :: SL.StringLike str => Int -> str -> (Int, str)
truncateStringLike c t = case truncateStringLike' c t of
(0, t') -> (0, dropWhileEndSL isSpace $ dropWhileEndSL (not . isSpace) $ t')
other -> other
truncateStringLike' :: SL.StringLike str => Int -> str -> (Int, str)
truncateStringLike' 0 t = (0, SL.empty)
truncateStringLike' c t = case SL.uncons t of
Nothing -> (c, t)
Just (char, rest) -> fmap (SL.cons char) (truncateStringLike (c 1) rest)
dropWhileEndSL :: SL.StringLike a => (Char -> Bool) -> a -> a
dropWhileEndSL p = SL.fromString . (dropWhileEnd p) . SL.toString