diff --git a/Text/HTML/DOM.hs b/Text/HTML/DOM.hs
--- a/Text/HTML/DOM.hs
+++ b/Text/HTML/DOM.hs
@@ -4,23 +4,23 @@
, sinkDoc
, readFile
, parseLBS
+ , parseBSChunks
) where
import Control.Monad.Trans.Resource
import Prelude hiding (readFile)
import qualified Data.ByteString as S
#if MIN_VERSION_tagstream_conduit(0,5,0)
-import qualified Text.HTML.TagStream.ByteString as TS
+import qualified Text.HTML.TagStream.Text as TS
#endif
import qualified Text.HTML.TagStream as TS
import qualified Data.XML.Types as XT
import Data.Conduit
+import Data.Conduit.Text (decodeUtf8Lenient)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Conduit.List as CL
import Control.Arrow ((***), second)
-import Data.Text.Encoding (decodeUtf8With)
-import Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Set as Set
import qualified Text.XML as X
import Text.XML.Stream.Parse (decodeHtmlEntities)
@@ -37,11 +37,11 @@
-- that case.
eventConduit :: Monad m => Conduit S.ByteString m XT.Event
eventConduit =
- TS.tokenStream =$= go []
+ decodeUtf8Lenient =$= TS.tokenStream =$= go []
where
go stack = do
mx <- await
- case fmap (entities . fmap' (decodeUtf8With lenientDecode)) mx of
+ case fmap entities mx of
Nothing -> closeStack stack
-- Ignore processing instructions (or pseudo-instructions)
@@ -75,14 +75,6 @@
toName l = XT.Name l Nothing Nothing
closeStack = mapM_ (yield . XT.EventEndElement)
- fmap' :: (a -> b) -> TS.Token' a -> TS.Token' b
- fmap' f (TS.TagOpen x pairs b) = TS.TagOpen (f x) (map (f *** f) pairs) b
- fmap' f (TS.TagClose x) = TS.TagClose (f x)
- fmap' f (TS.Text x) = TS.Text (f x)
- fmap' f (TS.Comment x) = TS.Comment (f x)
- fmap' f (TS.Special x y) = TS.Special (f x) (f y)
- fmap' f (TS.Incomplete x) = TS.Incomplete (f x)
-
entities :: TS.Token' Text -> TS.Token' Text
entities (TS.TagOpen x pairs b) = TS.TagOpen x (map (second entities') pairs) b
entities (TS.Text x) = TS.Text $ entities' x
@@ -141,4 +133,8 @@
readFile fp = runResourceT $ sourceFile (F.encodeString fp) $$ sinkDoc
parseLBS :: L.ByteString -> X.Document
-parseLBS lbs = runIdentity $ runExceptionT_ $ CL.sourceList (L.toChunks lbs) $$ sinkDoc
+parseLBS = parseBSChunks . L.toChunks
+
+parseBSChunks :: [S.ByteString] -> X.Document
+parseBSChunks bss = runIdentity $ runExceptionT_ $ CL.sourceList bss $$ sinkDoc
+
diff --git a/html-conduit.cabal b/html-conduit.cabal
--- a/html-conduit.cabal
+++ b/html-conduit.cabal
@@ -1,5 +1,5 @@
Name: html-conduit
-Version: 1.1.0.6
+Version: 1.1.1
Synopsis: Parse HTML documents using xml-conduit datatypes.
Description: This package uses tagstream-conduit for its parser. It automatically balances mismatched tags, so that there shouldn't be any parse failures. It does not handle a full HTML document rendering, such as adding missing html and head tags.
Homepage: https://github.com/snoyberg/xml
diff --git a/test/main.hs b/test/main.hs
--- a/test/main.hs
+++ b/test/main.hs
@@ -39,6 +39,9 @@
it "doesn't strip whitespace" $
X.parseLBS_ X.def " hello" @=?
H.parseLBS " hello"
+ it "split code-points" $
+ X.parseLBS_ X.def " " @=?
+ H.parseBSChunks ["\xc2", "\xa0"]
describe "HTML parsing" $ do
it "XHTML" $
let html = "fooHello World
"