module Text.HTML.TagSoup.Parsec
( module Text.HTML.TagSoup
, TagParser
, TagParserSt
, WholeTag
, tParse
, tStParse
, openTag
, maybeOpenTag
, eitherOpenTag
, notOpenTag
, allOpenTags
, wholeTag
, maybeWholeTag
, eitherWholeTag
, allWholeTags
, closeTag
, maybeCloseTag
, eitherCloseTag
, notCloseTag
, allCloseTags
, maybeP
, allP
, eitherP
)
where
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Pos
import Text.HTML.TagSoup
import Text.StringLike
import Data.Maybe
import Data.Char
type WholeTag str =
( Tag str, [ Tag str] , Tag str)
type TagParser str =
GenParser (Tag str) ( )
type TagParserSt str =
GenParser (Tag str)
tParse :: (StringLike str, Show str) => TagParser str a -> [ Tag str ] -> a
tParse p ts =
either ( error . show ) id $ parse p "tagsoup" ts
tStParse :: (StringLike str, Show str) => TagParserSt str st a -> st -> [ Tag str ] -> a
tStParse p state tos =
either ( error . show ) id $ runParser p state "tagsoup" tos
tagEater matcher =
tokenPrim show
( \ oldSp _ _ -> do
setSourceLine oldSp ( 1 + sourceLine oldSp )
)
matcher
lowercase :: StringLike s => s -> s
lowercase =
fromString . map toLower . toString
openTag :: (StringLike str, Show str) => str -> TagParserSt str st (Tag str)
openTag soughtName =
openTagMatch soughtName ( Just ) $ \ _ -> Nothing
notOpenTag :: (StringLike str, Show str) => str -> TagParserSt str st (Tag str)
notOpenTag avoidName =
openTagMatch avoidName ( \ _ -> Nothing ) Just
openTagMatch soughtName match noMatch =
tagEater $ \ tag ->
case tag of
t@( TagOpen tname atrs ) ->
if lowercase tname == lowercase soughtName
then
match t
else
noMatch t
t ->
noMatch t
closeTagMatch soughtName match noMatch =
tagEater $ \ tag ->
case tag of
t@( TagClose tname ) ->
if lowercase tname == lowercase soughtName
then
match t
else
noMatch t
t ->
noMatch t
wholeTag :: (StringLike str, Show str) => str -> TagParserSt str st (WholeTag str)
wholeTag soughtName = do
open <- openTag soughtName
ts <- many $ notCloseTag soughtName
close <- closeTag soughtName
return ( open , ts , close )
closeTag :: (StringLike str, Show str) => str -> TagParserSt str st (Tag str)
closeTag soughtName =
closeTagMatch soughtName ( Just ) $ \ _ -> Nothing
notCloseTag :: (StringLike str, Show str) => str -> TagParserSt str st (Tag str)
notCloseTag avoidName =
closeTagMatch avoidName ( \ _ -> Nothing ) Just
maybeOpenTag :: (StringLike str, Show str) => str -> TagParserSt str st ( Maybe (Tag str) )
maybeOpenTag =
maybeP . openTag
maybeCloseTag :: (StringLike str, Show str) => str -> TagParserSt str st ( Maybe (Tag str) )
maybeCloseTag =
maybeP . closeTag
maybeWholeTag :: (StringLike str, Show str) => str -> TagParserSt str st ( Maybe (WholeTag str) )
maybeWholeTag =
maybeP . wholeTag
allOpenTags :: (StringLike str, Show str) => str -> TagParserSt str st [ Tag str ]
allOpenTags =
allP . maybeOpenTag
allCloseTags :: (StringLike str, Show str) => str -> TagParserSt str st [ Tag str ]
allCloseTags =
allP . maybeCloseTag
allWholeTags :: (StringLike str, Show str) => str -> TagParserSt str st [ WholeTag str ]
allWholeTags =
allP . maybeWholeTag
eitherP :: Show tok => GenParser tok st a -> GenParser tok st ( Either tok a )
eitherP p = do
try ( do t <- p
return $ Right t
) <|> ( do t <- anyToken
return $ Left t
)
eitherOpenTag :: (StringLike str, Show str) => str -> TagParserSt str st ( Either (Tag str) (Tag str) )
eitherOpenTag =
eitherP . openTag
eitherCloseTag :: (StringLike str, Show str) => str -> TagParserSt str st ( Either (Tag str) (Tag str) )
eitherCloseTag =
eitherP . closeTag
eitherWholeTag :: (StringLike str, Show str) => str -> TagParserSt str st ( Either (Tag str) (WholeTag str) )
eitherWholeTag =
eitherP . wholeTag
allP :: GenParser tok st ( Maybe a ) -> GenParser tok st [ a ]
allP p = do
ts <- many p
let ls =
catMaybes ts
return ls
maybeP :: Show tok => GenParser tok st a -> GenParser tok st ( Maybe a )
maybeP p =
try ( do t <- p
return $ Just t
) <|> ( do anyToken
return Nothing
)