tagstream-conduit 0.5.3 → 0.5.4

raw patch · 5 files changed

+142/−22 lines, 5 filesdep +attoparsec-conduitdep +case-insensitivedep +transformersdep ~blaze-builder-conduitdep ~conduitPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: attoparsec-conduit, case-insensitive, transformers

Dependency ranges changed: blaze-builder-conduit, conduit

API changes (from Hackage documentation)

Files

• Text/HTML/TagStream/ByteString.hs +13/−2
• Text/HTML/TagStream/Text.hs +77/−3
• Text/HTML/TagStream/Types.hs +32/−6
• tagstream-conduit.cabal +6/−3
• tests/Tests.hs +14/−8

@@ -1,4 +1,6 @@ {-# LANGUAGE OverloadedStrings, TupleSections, ViewPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-} module Text.HTML.TagStream.ByteString where  import Control.Applicative@@ -8,7 +10,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S import Data.Attoparsec.Char8-import Data.Conduit (GInfConduit, awaitE, yield)+import Data.Conduit  import qualified Blaze.ByteString.Builder as B import Text.HTML.TagStream.Types@@ -204,11 +206,20 @@ -- }}}  -- {{{ Stream-tokenStream :: Monad m => GInfConduit ByteString m Token+tokenStream :: Monad m+#if MIN_VERSION_conduit(1, 0, 0)+            => Conduit ByteString m Token+#else+            => GInfConduit ByteString m Token+#endif tokenStream =     loop S.empty   where+#if MIN_VERSION_conduit(1, 0, 0)+    loop accum = await >>= maybe (close accum ()) (push accum)+#else     loop accum = awaitE >>= either (close accum) (push accum)+#endif      push accum input =         case parseOnly html (accum `S.append` input) of

@@ -1,18 +1,36 @@ {-# LANGUAGE OverloadedStrings, TupleSections, ViewPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-} module Text.HTML.TagStream.Text where +import Prelude hiding (mapM) import Control.Applicative-import Control.Monad (unless)+import Control.Monad (unless, when, liftM)+import Control.Monad.Trans.Class (lift) +import Data.Traversable (mapM)+import Data.Maybe (fromMaybe) import Data.Monoid (mconcat) import Data.Char (isSpace)+import Data.ByteString (ByteString) import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Builder as B+import qualified Data.CaseInsensitive as CI+import qualified Data.Attoparsec.ByteString.Char8 as S import Data.Attoparsec.Text-import Data.Conduit (GInfConduit, awaitE, yield)+import Data.Conduit+#if MIN_VERSION_conduit(1, 0, 0)+import Data.Conduit.Internal (unConduitM)+#else+import Data.Conduit.Internal (pipeL)+#endif+import qualified Data.Conduit.List as C+import qualified Data.Conduit.Attoparsec as C+import qualified Data.Conduit.Text as C +import qualified Text.HTML.TagStream.ByteString as S import Text.HTML.TagStream.Types import Text.HTML.TagStream.Utils (splitAccum) @@ -206,11 +224,20 @@ -- }}}  -- {{{ Stream-tokenStream :: Monad m => GInfConduit Text m Token+tokenStream :: Monad m+#if MIN_VERSION_conduit(1, 0, 0)+            => Conduit Text m Token+#else+            => GInfConduit Text m Token+#endif tokenStream =     loop T.empty   where+#if MIN_VERSION_conduit(1, 0, 0)+    loop accum = await >>= maybe (close accum ()) (push accum)+#else     loop accum = awaitE >>= either (close accum) (push accum)+#endif      push accum input =         case parseOnly html (accum `T.append` input) of@@ -220,4 +247,51 @@     close s r = do         unless (T.null s) $ yield $ Text s         return r++-- | like `tokenStream', but it process `ByteString' input, decode it according to xml version tag.+--+-- Only support utf-8 and iso8859 for now.+tokenStreamBS :: MonadThrow m+#if MIN_VERSION_conduit(1, 0, 0)+              => Conduit ByteString m Token+#else+              => GLInfConduit ByteString m Token+#endif+tokenStreamBS = do+    -- try to peek the first tag to find the xml encoding.+    tk <- C.sinkParser (skipBOM *> S.skipSpace *> S.char '<' *> S.tag)++    let (mencoding, yieldToken) =+          case tk of+            (TagOpen "?xml" as _) ->+                (lookup "encoding" as, False)+            _ -> (Nothing, True)++    let codec = fromMaybe C.utf8 (mencoding >>= getCodec . CI.mk)++    when yieldToken $ lift (mapM (decodeBS codec) tk) >>= yield++#if MIN_VERSION_conduit(1, 0, 0)+    C.decode codec =$= tokenStream+#else+    C.decode codec `pipeL` tokenStream+#endif+  where+    skipBOM :: S.Parser ()+    skipBOM =+        ( S.string "\xff\xfe"+          <|> S.string "\xef\xbb\xbf"+        ) *> return ()+        <|> return ()++    getCodec :: CI.CI ByteString -> Maybe C.Codec+    getCodec c =+        case c of+            "utf-8"   -> Just C.utf8+            "utf8"    -> Just C.utf8+            "iso8859" -> Just C.iso8859_1+            _         -> Nothing++    --decodeBS :: C.Codec -> ByteString -> m Text+    decodeBS codec bs = liftM T.concat $ yield bs $= C.decode codec $$ C.consume -- }}}

@@ -1,6 +1,10 @@ module Text.HTML.TagStream.Types where +import Control.Applicative (pure, (<$>), (<*>)) import Control.Arrow ((***))+import Data.Monoid (mappend, mconcat)+import Data.Foldable (Foldable(foldMap))+import Data.Traversable (Traversable(traverse), sequenceA)  type Attr' s = (s, s) @@ -17,9 +21,31 @@              | TagTypeNormal  instance Functor Token' where-    fmap f (TagOpen x pairs b) = TagOpen (f x) (map (f *** f) pairs) b-    fmap f (TagClose x) = TagClose (f x)-    fmap f (Text x) = Text (f x)-    fmap f (Comment x) = Comment (f x)-    fmap f (Special x y) = Special (f x) (f y)-    fmap f (Incomplete x) = Incomplete (f x)+    fmap f t = case t of+        (TagOpen x pairs b) -> TagOpen (f x) (map (f *** f) pairs) b+        (TagClose x)        -> TagClose (f x)+        (Text x)            -> Text (f x)+        (Comment x)         -> Comment (f x)+        (Special x y)       -> Special (f x) (f y)+        (Incomplete x)      -> Incomplete (f x)++instance Foldable Token' where+    foldMap f t = case t of+        (TagOpen x pairs _) -> f x `mappend` mconcat (map (\(a1, a2) -> f a1 `mappend` f a2) pairs)+        (TagClose x)        -> f x+        (Text x)            -> f x+        (Comment x)         -> f x+        (Special x y)       -> f x `mappend` f y+        (Incomplete x)      -> f x++instance Traversable Token' where+    traverse f t = case t of+        (TagOpen x pairs b) -> TagOpen <$> f x+                                       <*> sequenceA (map (\(a1, a2) -> (,) <$> f a1 <*> f a2) pairs)+                                       <*> pure b+        (TagClose x)        -> TagClose <$> f x+        (Text x)            -> Text <$> f x+        (Comment x)         -> Comment <$> f x+        (Special x y)       -> Special <$> f x <*> f y+        (Incomplete x)      -> Incomplete <$> f x+

@@ -1,5 +1,5 @@ Name:                tagstream-conduit-Version:             0.5.3+Version:             0.5.4 Synopsis:            streamlined html tag parser Description:     Tag-stream is a library for parsing HTML//XML to a token stream.@@ -35,10 +35,13 @@   Build-depends:       base >= 4 && < 5                      , bytestring                      , text-                     , conduit >= 0.5 && < 0.6+                     , case-insensitive+                     , transformers >= 0.3+                     , conduit >= 0.5 && < 1.1                      , attoparsec                      , blaze-builder-                     , blaze-builder-conduit >= 0.5 && < 0.6+                     , blaze-builder-conduit >= 0.5 && < 1.1+                     , attoparsec-conduit >= 0.5  test-suite test     hs-source-dirs: tests

@@ -1,15 +1,15 @@-{-# LANGUAGE FlexibleInstances, OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances, OverloadedStrings, ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Main where  import Control.Applicative -import Data.String (IsString) import Data.Monoid (Monoid(..)) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S import Data.Text (Text) import qualified Data.Text as T+import qualified Data.Text.Encoding as T import qualified Data.Conduit as C import qualified Data.Conduit.List as CL @@ -57,10 +57,14 @@   where not_empty tokens = (T.null s && null tokens)                         || (not (T.null s) && not (null tokens)) +encodeTokenUtf8 :: Token' Text -> Token' ByteString+encodeTokenUtf8 = fmap T.encodeUtf8+ onePassTests :: Spec onePassTests = mapM_ one testcases   where-    one (str, tokens) = it (S.unpack str) $ do+    one (T.encodeUtf8 -> str, map encodeTokenUtf8 -> tokens) =+      it (S.unpack str) $ do         result <- combineText <$> assertDecodeBS str         assertEqual "one-pass parse result incorrect" tokens result @@ -76,7 +80,8 @@   where     isIncomplete (Incomplete _) = True     isIncomplete _ = False-    one (str, tokens) = it (S.unpack str) $ do+    one (T.encodeUtf8 -> str, map encodeTokenUtf8 -> tokens) =+      it (S.unpack str) $ do         -- streamline parse result don't contain the trailing Incomplete token.         let tokens' = reverse . dropWhile isIncomplete  . reverse $ tokens         result <- combineText <$> C.runResourceT (@@ -90,16 +95,17 @@   where     isIncomplete (Incomplete _) = True     isIncomplete _ = False-    one (str, tokens) = it (T.unpack str) $ do+    one (T.encodeUtf8 -> str, tokens) =+      it (S.unpack str) $ do         -- streamline parse result don't contain the trailing Incomplete token.         let tokens' = reverse . dropWhile isIncomplete  . reverse $ tokens         result <- combineText <$> C.runResourceT (-                      CL.sourceList (map T.singleton (T.unpack str))-                      C.$= T.tokenStream+                      CL.sourceList (map S.singleton (S.unpack str))+                      C.$= T.tokenStreamBS                       C.$$ CL.consume )         assertEqual "streamline parse result incorrect" tokens' result -testcases :: IsString s => [(s, [Token' s])]+testcases :: [(Text, [Token' Text])] testcases =   -- attributes {{{   [ ( "<span readonly title=foo class=\"foo bar\" style='display:none;'>"