yesod-test: use html-conduit
This commit is contained in:
parent
d0a7447f56
commit
f8c731534c
@ -6,60 +6,9 @@ module Yesod.Test.HtmlParse
|
|||||||
( parseHtml
|
( parseHtml
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Text.HTML.TagStream
|
|
||||||
import qualified Data.ByteString as S
|
|
||||||
import qualified Data.ByteString.Lazy as L
|
import qualified Data.ByteString.Lazy as L
|
||||||
import Text.XML
|
import Text.XML (Document)
|
||||||
import Data.Conduit
|
import qualified Text.HTML.DOM as HD
|
||||||
import qualified Data.Conduit.List as CL
|
|
||||||
import Data.Functor.Identity (runIdentity)
|
|
||||||
import Control.Monad.Trans.Resource (runExceptionT)
|
|
||||||
import Data.XML.Types (Event (..), Content (ContentText))
|
|
||||||
import Control.Arrow ((***))
|
|
||||||
import Data.Text.Encoding (decodeUtf8With)
|
|
||||||
import Data.Text.Encoding.Error (lenientDecode)
|
|
||||||
import qualified Data.Set as Set
|
|
||||||
|
|
||||||
parseHtml :: L.ByteString -> Either String Document
|
parseHtml :: L.ByteString -> Either String Document
|
||||||
parseHtml lbs =
|
parseHtml = Right . HD.parseLBS
|
||||||
either (Left . show) Right
|
|
||||||
$ runIdentity
|
|
||||||
$ runExceptionT
|
|
||||||
$ CL.sourceList (L.toChunks lbs)
|
|
||||||
$$ tokenStream =$ (CL.concatMap toEvent =$ fromEvents)
|
|
||||||
|
|
||||||
toEvent :: Token -> [Event]
|
|
||||||
toEvent (TagOpen bsname bsattrs isClose') =
|
|
||||||
EventBeginElement name attrs : if isClose then [EventEndElement name] else []
|
|
||||||
where
|
|
||||||
name = toName bsname
|
|
||||||
attrs = map (toName *** (return . ContentText . decodeUtf8With lenientDecode)) bsattrs
|
|
||||||
isClose = isClose' || isVoid bsname
|
|
||||||
toEvent (TagClose bsname) = [EventEndElement $ toName bsname]
|
|
||||||
toEvent (Text bs) = [EventContent $ ContentText $ decodeUtf8With lenientDecode bs]
|
|
||||||
toEvent (Comment bs) = [EventComment $ decodeUtf8With lenientDecode bs]
|
|
||||||
toEvent Special{} = []
|
|
||||||
toEvent Incomplete{} = []
|
|
||||||
|
|
||||||
toName :: S.ByteString -> Name
|
|
||||||
toName bs = Name (decodeUtf8With lenientDecode bs) Nothing Nothing
|
|
||||||
|
|
||||||
isVoid :: S.ByteString -> Bool
|
|
||||||
isVoid = flip Set.member $ Set.fromList
|
|
||||||
[ "area"
|
|
||||||
, "base"
|
|
||||||
, "br"
|
|
||||||
, "col"
|
|
||||||
, "command"
|
|
||||||
, "embed"
|
|
||||||
, "hr"
|
|
||||||
, "img"
|
|
||||||
, "input"
|
|
||||||
, "keygen"
|
|
||||||
, "link"
|
|
||||||
, "meta"
|
|
||||||
, "param"
|
|
||||||
, "source"
|
|
||||||
, "track"
|
|
||||||
, "wbr"
|
|
||||||
]
|
|
||||||
|
|||||||
@ -33,13 +33,11 @@ library
|
|||||||
, bytestring >= 0.9
|
, bytestring >= 0.9
|
||||||
, case-insensitive >= 0.2
|
, case-insensitive >= 0.2
|
||||||
, text
|
, text
|
||||||
, tagstream-conduit >= 0.3 && < 0.4
|
|
||||||
, conduit >= 0.4 && < 0.5
|
|
||||||
, resourcet >= 0.3 && < 0.4
|
|
||||||
, xml-conduit >= 0.7 && < 0.8
|
, xml-conduit >= 0.7 && < 0.8
|
||||||
, xml-types >= 0.3 && < 0.4
|
, xml-types >= 0.3 && < 0.4
|
||||||
, containers
|
, containers
|
||||||
, xml2html >= 0.1.2 && < 0.2
|
, xml2html >= 0.1.2.3 && < 0.2
|
||||||
|
, html-conduit >= 0.0.1 && < 0.1
|
||||||
|
|
||||||
if flag(blaze_html_0_5)
|
if flag(blaze_html_0_5)
|
||||||
build-depends:
|
build-depends:
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user