module Text.ParserCombinators.Parsec.Tag
( TagParser
, satisfy, lexeme
, space, whitespace
, anyTag, anyTagOpen, anyTagClose
, tag, tagOpen, tagClose
, tagP, anyTagP
, tagText
, oneOf, noneOf
) where
import Control.Applicative
import Control.Monad
import Data.Char
import Data.Maybe
import Text.HTML.TagSoup
import Text.StringLike
import Text.ParserCombinators.Parsec.Prim hiding ((<|>), many)
import Text.ParserCombinators.Parsec.Combinator (many1)
import Text.ParserCombinators.Parsec.Pos
type TagParser str st = GenParser (Tag str) st
tagToken :: (Show str, StringLike str) => (Tag str -> Maybe a) -> TagParser str st a
tagToken = tokenPrim show updatePosTag
where updatePosTag s _ _ = setSourceLine s ( 1 + sourceLine s )
satisfy :: (StringLike str, Show str) => (Tag str -> Bool) -> TagParser str st (Tag str)
satisfy f = lexeme $ tagToken (\t -> if (f t) then Just t else Nothing)
tagOpen, tagClose :: (Show str, StringLike str) => str -> TagParser str st (Tag str)
tagOpen x = satisfy (isTagOpenName x) <?> show (TagOpen x [])
tagClose x = satisfy (isTagCloseName x) <?> show (TagClose x)
anyTagOpen, anyTagClose :: (Show str, StringLike str) => TagParser str st (Tag str)
anyTagOpen = satisfy isTagOpen <?> "<TAG>"
anyTagClose = satisfy isTagClose <?> "</TAG>"
tagText :: (Show str, StringLike str) => TagParser str st str
tagText = (lexeme $
tagToken (\tag -> case tag of
TagText x -> Just x
_ -> Nothing))
<?> "TEXT"
space :: (Show str, StringLike str) => TagParser str st (Tag str)
space = satisfy (\tag -> case tag of
TagText x | all isSpace (toString x) -> True
_ -> False )
whitespace :: (Show str, StringLike str) => TagParser str st ()
whitespace = skipMany space
lexeme :: (Show str, StringLike str) => TagParser str st a -> TagParser str st a
lexeme p = p <* whitespace
tag :: forall st str rep . (StringLike str, Show str, TagRep rep) => rep -> TagParser str st (Tag str)
tag t = satisfy (~== t) <?> show(toTagRep t :: Tag str)
tag' :: (StringLike str, Show str, TagRep str) => (Tag str -> Bool) -> TagParser str st (Tag str)
tag' t = satisfy t <?> "TAG"
tagP :: forall rep str st a. (StringLike str, Show str, TagRep rep) => rep -> (Tag str -> TagParser str st a) -> TagParser str st a
tagP t p = lexeme (do
x@(TagOpen name _) <- tag t
result <- p x
skipMany (satisfy (/= TagClose name))
tagClose name
return result
) <?> show (toTagRep t :: Tag str)
anyTag :: (Show str, StringLike str) => TagParser str st (Tag str)
anyTag = lexeme $ tagToken Just
anyTagP :: (Show str, StringLike str) => (Tag str -> TagParser str st a) -> TagParser str st a
anyTagP p = lexeme $ do
x@(TagOpen name _) <- anyTagOpen
result <- p x
skipMany (satisfy (/= TagClose name))
tagClose name
return result
elemTag :: StringLike str => Tag str -> [Tag str] -> Bool
elemTag tag = any (tag ~==)
oneOf, noneOf :: (Show str, StringLike str) => [Tag str] -> TagParser str st (Tag str)
oneOf ts = satisfy (`elemTag` ts)
noneOf ts = satisfy (not . (`elemTag` ts))
someTagP :: (Show str, StringLike str, TagRep str) => str -> (Tag str -> TagParser str st a) -> TagParser str st a
someTagP t k = skipMany (satisfy (~/= t)) >> tagP t k
childrenP :: (Show str, StringLike str) => TagParser str st [Tag str]
childrenP = do
open@(TagOpen name _) <- anyTagOpen
content <- many (many1 (TagText <$> tagText) <|> childrenP)
close <- tagClose name
return (open : concat content ++ [close])