packages feed

tagstream-conduit 0.4.0 → 0.5.0

raw patch · 11 files changed

+541/−305 lines, 11 filesdep +textdep ~base

Dependencies added: text

Dependency ranges changed: base

Files

Highlight.hs view
@@ -1,16 +1,18 @@-import Data.Maybe import System.IO import System.Environment-import Text.HTML.TagStream+import System.Console.ANSI++import Data.Maybe import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S-import System.Console.ANSI++import Data.Conduit.Blaze (builderToByteString) import qualified Data.Conduit as C import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL-import Blaze.ByteString.Builder (Builder)-import Data.Conduit.Blaze (builderToByteString) +import qualified Text.HTML.TagStream.ByteString as S+ color :: Color -> ByteString -> ByteString color c s = S.concat [ S.pack $ setSGRCode [SetColor Foreground Dull c]                      , s@@ -23,7 +25,7 @@     filename <- maybe (fail "Highlight file") return (listToMaybe args)     C.runResourceT $         CB.sourceFile filename-        C.$= tokenStream-        C.$= CL.map (showToken (color Red))+        C.$= S.tokenStream+        C.$= CL.map (S.showToken (color Red))         C.$= builderToByteString         C.$$ CB.sinkHandle stdout
Parse.hs view
@@ -1,6 +1,6 @@ import Data.Maybe import System.Environment-import Text.HTML.TagStream+import qualified Text.HTML.TagStream.ByteString as S import qualified Data.Conduit as C import qualified Data.Conduit.Binary as C import qualified Data.Conduit.List as CL@@ -11,6 +11,6 @@     filename <- maybe (fail "pass file path") return (listToMaybe args)     _ <- C.runResourceT $            C.sourceFile filename-           C.$= tokenStream+           C.$= S.tokenStream            C.$$ CL.consume     return ()
Text/HTML/TagStream.hs view
@@ -1,15 +1,5 @@ module Text.HTML.TagStream-  ( tokenStream-  , Token-  , Token'(..)-  , Attr-  , Attr'-  , showToken-  , encode-  , encodeHL-  , decode+  ( module Text.HTML.TagStream.Types   ) where  import Text.HTML.TagStream.Types-import Text.HTML.TagStream.Stream-import Text.HTML.TagStream.Parser
+ Text/HTML/TagStream/ByteString.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE OverloadedStrings, TupleSections, ViewPatterns #-}+module Text.HTML.TagStream.ByteString where++import Control.Applicative+import Control.Monad (unless)++import Data.Monoid (mconcat)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S+import Data.Attoparsec.Char8+import Data.Conduit (GInfConduit, awaitE, yield)++import qualified Blaze.ByteString.Builder as B+import Text.HTML.TagStream.Types+import Text.HTML.TagStream.Utils (splitAccum)++type Token = Token' ByteString+type Attr = Attr' ByteString++{--+ - match quoted string, can fail.+ -}+quoted :: Char -> Parser ByteString+quoted q = S.append <$> takeTill (in2 ('\\',q))+                    <*> ( char q *> pure ""+                      <|> char '\\' *> atLeast 1 (quoted q) )++quotedOr :: Parser ByteString -> Parser ByteString+quotedOr p = maybeP (satisfy (in2 ('"','\''))) >>=+             maybe p quoted++{--+ - attribute value, can't fail.+ -}+attrValue :: Parser ByteString+attrValue = quotedOr $ takeTill ((=='>') ||. isSpace)++{--+ - attribute name, at least one char, can fail when meet tag end.+ - might match self-close tag end "/>" , make sure match `tagEnd' first.+ -}+attrName :: Parser ByteString+attrName = quotedOr $+             S.cons <$> satisfy (/='>')+                    <*> takeTill (in3 ('/','>','=') ||. isSpace)++{--+ - tag end, return self-close or not, can fail.+ -}+tagEnd :: Parser Bool+tagEnd = char '>' *> pure False+     <|> string "/>" *> pure True++{--+ - attribute pair or tag end, can fail if tag end met.+ -}+attr :: Parser Attr+attr = (,) <$> attrName <* skipSpace+           <*> ( boolP (char '=') >>=+                 cond (skipSpace *> attrValue)+                      (pure "")+               )++{--+ - all attributes before tag end. can't fail.+ -}+attrs :: Parser ([Attr], Bool)+attrs = loop []+  where+    loop acc = skipSpace *> (Left <$> tagEnd <|> Right <$> attr) >>=+               either+                 (return . (reverse acc,))+                 (loop . (:acc))++{--+ - comment tag without prefix.+ -}+comment :: Parser Token+comment = Comment <$> comment'+  where comment' = S.append <$> takeTill (=='-')+                            <*> ( string "-->" *> return ""+                              <|> atLeast 1 comment' )++{--+ - tags begine with <! , e.g. <!DOCTYPE ...>+ -}+special :: Parser Token+special = Special+          <$> ( S.cons <$> satisfy (not . ((=='-') ||. isSpace))+                       <*> takeTill ((=='>') ||. isSpace)+                       <* skipSpace )+          <*> takeTill (=='>') <* char '>'++{--+ - parse a tag, can fail.+ -}+tag :: Parser Token+tag = do+    t <-    string "/"     *> return TagTypeClose+        <|> string "!" *> return TagTypeSpecial+        <|> return TagTypeNormal+    case t of+        TagTypeClose ->+            TagClose <$> takeTill (=='>')+            <* char '>'+        TagTypeSpecial -> boolP (string "--") >>=+                          cond comment special+        TagTypeNormal -> do+            name <- takeTill (in3 ('<','>','/') ||. isSpace)+            (as, close) <- attrs+            skipSpace+            return $ TagOpen name as close++{--+ - record incomplete tag for streamline processing.+ -}+incomplete :: Parser Token+incomplete = Incomplete . S.cons '<' <$> takeByteString++{--+ - parse text node. consume at least one char, to make sure progress.+ -}+text :: Parser Token+text = Text <$> atLeast 1 (takeTill (=='<'))++token :: Parser Token+token = char '<' *> (tag <|> incomplete)+    <|> text++{--+ - treat script tag specially, can't fail.+ -}+tillScriptEnd :: Token -> Parser [Token]+tillScriptEnd t = reverse <$> loop [t]+              <|> (:[]) . Incomplete . S.append script <$> takeByteString+  where+    script = B.toByteString $ showToken id t+    loop acc = (:acc) <$> scriptEnd+           <|> (text >>= loop . (:acc))+    scriptEnd = string "</script>" *> return (TagClose "script")++html :: Parser [Token]+html = tokens <|> pure []+  where+    tokens :: Parser [Token]+    tokens = do+        t <- token+        case t of+            (TagOpen name _ close)+              | not close && name=="script"+                -> (++) <$> tillScriptEnd t <*> html+            _ -> (t:) <$> html++decode :: ByteString -> Either String [Token]+decode = parseOnly html++{--+ - Utils {{{+ -}++atLeast :: Int -> Parser ByteString -> Parser ByteString+atLeast 0 p = p+atLeast n p = S.cons <$> anyChar <*> atLeast (n-1) p++cond :: a -> a -> Bool -> a+cond a1 a2 b = if b then a1 else a2++(||.) :: Applicative f => f Bool -> f Bool -> f Bool+(||.) = liftA2 (||)++in2 :: Eq a => (a,a) -> a -> Bool+in2 (a1,a2) a = a==a1 || a==a2++in3 :: Eq a => (a,a,a) -> a -> Bool+in3 (a1,a2,a3) a = a==a1 || a==a2 || a==a3++boolP :: Parser a -> Parser Bool+boolP p = p *> pure True <|> pure False++maybeP :: Parser a -> Parser (Maybe a)+maybeP p = Just <$> p <|> return Nothing+-- }}}++-- {{{ encode tokens+cc :: [ByteString] -> B.Builder+cc = mconcat . map B.fromByteString++showToken :: (ByteString -> ByteString) -> Token -> B.Builder+showToken hl (TagOpen name as close) =+    cc $ [hl "<", name]+      ++ map showAttr as+      ++ [hl (if close then "/>" else ">")]+  where+    showAttr :: Attr -> ByteString+    showAttr (key, value) = S.concat $ [" ", key, hl "=\""] ++ map escape (S.unpack value) ++ [hl "\""]+    escape '"' = "\\\""+    escape '\\' = "\\\\"+    escape c = S.singleton c+showToken hl (TagClose name) = cc [hl "</", name, hl ">"]+showToken _ (Text s) = B.fromByteString s+showToken hl (Comment s) = cc [hl "<!--", s, hl "-->"]+showToken hl (Special name s) = cc [hl "<!", name, " ", s, hl ">"]+showToken _ (Incomplete s) = B.fromByteString s+-- }}}++-- {{{ Stream+tokenStream :: Monad m => GInfConduit ByteString m Token+tokenStream =+    loop S.empty+  where+    loop accum = awaitE >>= either (close accum) (push accum)++    push accum input =+        case parseOnly html (accum `S.append` input) of+            Right (splitAccum -> (accum', tokens)) -> mapM_ yield tokens >> loop accum'+            Left err -> fail err++    close s r = do+        unless (S.null s) $ yield $ Text s+        return r++-- }}}
− Text/HTML/TagStream/Parser.hs 
@@ -1,173 +0,0 @@-{-# LANGUAGE OverloadedStrings, TupleSections #-}-module Text.HTML.TagStream.Parser where--import Control.Applicative-import Data.ByteString (ByteString)-import Data.Attoparsec.Char8-import Blaze.ByteString.Builder (toByteString)-import Text.HTML.TagStream.Types-import Text.HTML.TagStream.Utils (cons, append)--{--- - match quoted string, can fail.- -}-quoted :: Char -> Parser ByteString-quoted q = append <$> takeTill (in2 ('\\',q))-                  <*> ( char q *> pure ""-                        <|> char '\\' *> atLeast 1 (quoted q) )--quotedOr :: Parser ByteString -> Parser ByteString-quotedOr p = maybeP (satisfy (in2 ('"','\''))) >>=-             maybe p quoted--{--- - attribute value, can't fail.- -}-attrValue :: Parser ByteString-attrValue = quotedOr $ takeTill ((=='>') ||. isSpace)--{--- - attribute name, at least one char, can fail when meet tag end.- - might match self-close tag end "/>" , make sure match `tagEnd' first.- -}-attrName :: Parser ByteString-attrName = quotedOr $-             cons <$> satisfy (/='>')-                  <*> takeTill (in3 ('/','>','=') ||. isSpace)--{--- - tag end, return self-close or not, can fail.- -}-tagEnd :: Parser Bool-tagEnd = char '>' *> pure False-     <|> string "/>" *> pure True--{--- - attribute pair or tag end, can fail if tag end met.- -}-attr :: Parser Attr-attr = (,) <$> attrName <* skipSpace-           <*> ( boolP (char '=') >>=-                 cond (skipSpace *> attrValue)-                      (pure "")-               )--{--- - all attributes before tag end. can't fail.- -}-attrs :: Parser ([Attr], Bool)-attrs = loop []-  where-    loop acc = skipSpace *> (Left <$> tagEnd <|> Right <$> attr) >>=-               either-                 (return . (reverse acc,))-                 (loop . (:acc))--{--- - comment tag without prefix.- -}-comment :: Parser Token-comment = Comment <$> comment'-  where comment' = append <$> takeTill (=='-')-                          <*> ( string "-->" *> return ""-                                <|> atLeast 1 comment' )--{--- - tags begine with <! , e.g. <!DOCTYPE ...>- -}-special :: Parser Token-special = Special-          <$> ( cons <$> satisfy (not . ((=='-') ||. isSpace))-                     <*> takeTill ((=='>') ||. isSpace)-                     <* skipSpace )-          <*> takeTill (=='>') <* char '>'--{--- - parse a tag, can fail.- -}-tag :: Parser Token-tag = do-    t <- string "/"     *> return TagTypeClose-         <|> string "!" *> return TagTypeSpecial-         <|> return TagTypeNormal-    case t of-        TagTypeClose ->-            TagClose <$> takeTill (=='>')-            <* char '>'-        TagTypeSpecial -> boolP (string "--") >>=-                          cond comment special-        TagTypeNormal -> do-            name <- takeTill (in3 ('<','>','/') ||. isSpace)-            (as, close) <- attrs-            skipSpace-            return $ TagOpen name as close--{--- - record incomplete tag for streamline processing.- -}-incomplete :: Parser Token-incomplete = Incomplete . cons '<' <$> takeByteString--{--- - parse text node. consume at least one char, to make sure progress.- -}-text :: Parser Token-text = Text <$> atLeast 1 (takeTill (=='<'))--token :: Parser Token-token = char '<' *> (tag <|> incomplete)-        <|> text--{--- - treat script tag specially, can't fail.- -}-tillScriptEnd :: Token -> Parser [Token]-tillScriptEnd t = reverse <$> loop [t]-              <|> (:[]) . Incomplete . append script <$> takeByteString-  where-    script = toByteString $ showToken id t-    loop acc = (:acc) <$> scriptEnd-           <|> (text >>= loop . (:acc))-    scriptEnd = string "</script>" *> return (TagClose "script")--html :: Parser [Token]-html = tokens <|> pure []-  where-    tokens :: Parser [Token]-    tokens = do-        t <- token-        case t of-            (TagOpen name _ close)-              | not close && name=="script"-                -> (++) <$> tillScriptEnd t <*> html-            _ -> (t:) <$> html--decode :: ByteString -> Either String [Token]-decode = parseOnly html--{--- - Utils {{{- -}--atLeast :: Int -> Parser ByteString -> Parser ByteString-atLeast 0 p = p-atLeast n p = cons <$> anyChar <*> atLeast (n-1) p--cond :: a -> a -> Bool -> a-cond a1 a2 b = if b then a1 else a2--(||.) :: Applicative f => f Bool -> f Bool -> f Bool-(||.) = liftA2 (||)--in2 :: Eq a => (a,a) -> a -> Bool-in2 (a1,a2) a = a==a1 || a==a2--in3 :: Eq a => (a,a,a) -> a -> Bool-in3 (a1,a2,a3) a = a==a1 || a==a2 || a==a3--boolP :: Parser a -> Parser Bool-boolP p = p *> pure True <|> pure False--maybeP :: Parser a -> Parser (Maybe a)-maybeP p = Just <$> p <|> return Nothing--- }}}
− Text/HTML/TagStream/Stream.hs 
@@ -1,31 +0,0 @@-{-# LANGUAGE OverloadedStrings, ViewPatterns #-}-module Text.HTML.TagStream.Stream where--import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S-import Data.Attoparsec.ByteString (parseOnly)-import Data.Conduit-import Text.HTML.TagStream.Parser-import Text.HTML.TagStream.Types-import Control.Monad (unless)---- | html parser conduit.-tokenStream :: Monad m => GInfConduit ByteString m Token-tokenStream =-    loop S.empty-  where-    loop accum = awaitE >>= either (close accum) (push accum)--    push accum input =-        case parseOnly html (accum `S.append` input) of-            Right (splitAccum -> (accum', tokens)) -> mapM_ yield tokens >> loop accum'-            Left err -> fail err--    close s r = do-        unless (S.null s) $ yield $ Text s-        return r--    splitAccum :: [Token] -> (ByteString, [Token])-    splitAccum [] = (S.empty, [])-    splitAccum (reverse -> (Incomplete s : xs)) = (s, reverse xs)-    splitAccum tokens = (S.empty, tokens)
+ Text/HTML/TagStream/Text.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE OverloadedStrings, TupleSections, ViewPatterns #-}+module Text.HTML.TagStream.Text where++import Control.Applicative+import Control.Monad (unless)++import Data.Monoid (mconcat)+import Data.Char (isSpace)+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 Data.Attoparsec.Text+import Data.Conduit (GInfConduit, awaitE, yield)++import Text.HTML.TagStream.Types+import Text.HTML.TagStream.Utils (splitAccum)++type Token = Token' Text+type Attr = Attr' Text++{--+ - match quoted string, can fail.+ -}+quoted :: Char -> Parser Text+quoted q = T.append <$> takeTill (in2 ('\\',q))+                    <*> ( char q *> pure ""+                      <|> char '\\' *> atLeast 1 (quoted q) )++quotedOr :: Parser Text -> Parser Text+quotedOr p = maybeP (satisfy (in2 ('"','\''))) >>=+             maybe p quoted++{--+ - attribute value, can't fail.+ -}+attrValue :: Parser Text+attrValue = quotedOr $ takeTill ((=='>') ||. isSpace)++{--+ - attribute name, at least one char, can fail when meet tag end.+ - might match self-close tag end "/>" , make sure match `tagEnd' first.+ -}+attrName :: Parser Text+attrName = quotedOr $+             T.cons <$> satisfy (/='>')+                    <*> takeTill (in3 ('/','>','=') ||. isSpace)++{--+ - tag end, return self-close or not, can fail.+ -}+tagEnd :: Parser Bool+tagEnd = char '>' *> pure False+     <|> string "/>" *> pure True++{--+ - attribute pair or tag end, can fail if tag end met.+ -}+attr :: Parser Attr+attr = (,) <$> attrName <* skipSpace+           <*> ( boolP (char '=') >>=+                 cond (skipSpace *> attrValue)+                      (pure "")+               )++{--+ - all attributes before tag end. can't fail.+ -}+attrs :: Parser ([Attr], Bool)+attrs = loop []+  where+    loop acc = skipSpace *> (Left <$> tagEnd <|> Right <$> attr) >>=+               either+                 (return . (reverse acc,))+                 (loop . (:acc))++{--+ - comment tag without prefix.+ -}+comment :: Parser Token+comment = Comment <$> comment'+  where comment' = T.append <$> takeTill (=='-')+                            <*> ( string "-->" *> return ""+                              <|> atLeast 1 comment' )++{--+ - tags begine with <! , e.g. <!DOCTYPE ...>+ -}+special :: Parser Token+special = Special+          <$> ( T.cons <$> satisfy (not . ((=='-') ||. isSpace))+                       <*> takeTill ((=='>') ||. isSpace)+                       <* skipSpace )+          <*> takeTill (=='>') <* char '>'++{--+ - parse a tag, can fail.+ -}+tag :: Parser Token+tag = do+    t <-     string "/" *> return TagTypeClose+         <|> string "!" *> return TagTypeSpecial+         <|> return TagTypeNormal+    case t of+        TagTypeClose ->+            TagClose <$> takeTill (=='>')+            <* char '>'+        TagTypeSpecial -> boolP (string "--") >>=+                          cond comment special+        TagTypeNormal -> do+            name <- takeTill (in3 ('<','>','/') ||. isSpace)+            (as, close) <- attrs+            skipSpace+            return $ TagOpen name as close++{--+ - record incomplete tag for streamline processing.+ -}+incomplete :: Parser Token+incomplete = Incomplete . T.cons '<' <$> takeText++{--+ - parse text node. consume at least one char, to make sure progress.+ -}+text :: Parser Token+text = Text <$> atLeast 1 (takeTill (=='<'))++token :: Parser Token+token = char '<' *> (tag <|> incomplete)+    <|> text++{--+ - treat script tag specially, can't fail.+ -}+tillScriptEnd :: Token -> Parser [Token]+tillScriptEnd t = reverse <$> loop [t]+              <|> (:[]) . Incomplete . T.append script <$> takeText+  where+    script = L.toStrict . B.toLazyText $ showToken id t+    loop acc = (:acc) <$> scriptEnd+           <|> (text >>= loop . (:acc))+    scriptEnd = string "</script>" *> return (TagClose "script")++html :: Parser [Token]+html = tokens <|> pure []+  where+    tokens :: Parser [Token]+    tokens = do+        t <- token+        case t of+            (TagOpen name _ close)+              | not close && name=="script"+                -> (++) <$> tillScriptEnd t <*> html+            _ -> (t:) <$> html++decode :: Text -> Either String [Token]+decode = parseOnly html++{--+ - Utils {{{+ -}++atLeast :: Int -> Parser Text -> Parser Text+atLeast 0 p = p+atLeast n p = T.cons <$> anyChar <*> atLeast (n-1) p++cond :: a -> a -> Bool -> a+cond a1 a2 b = if b then a1 else a2++(||.) :: Applicative f => f Bool -> f Bool -> f Bool+(||.) = liftA2 (||)++in2 :: Eq a => (a,a) -> a -> Bool+in2 (a1,a2) a = a==a1 || a==a2++in3 :: Eq a => (a,a,a) -> a -> Bool+in3 (a1,a2,a3) a = a==a1 || a==a2 || a==a3++boolP :: Parser a -> Parser Bool+boolP p = p *> pure True <|> pure False++maybeP :: Parser a -> Parser (Maybe a)+maybeP p = Just <$> p <|> return Nothing+-- }}}++-- {{{ encode tokens+cc :: [Text] -> B.Builder+cc = mconcat . map B.fromText++showToken :: (Text -> Text) -> Token -> B.Builder+showToken hl (TagOpen name as close) =+    cc $ [hl "<", name]+      ++ map showAttr as+      ++ [hl (if close then "/>" else ">")]+  where+    showAttr :: Attr -> Text+    showAttr (key, value) = T.concat $ [" ", key, hl "=\""] ++ map escape (T.unpack value) ++ [hl "\""]+    escape '"' = "\\\""+    escape '\\' = "\\\\"+    escape c = T.singleton c+showToken hl (TagClose name) = cc [hl "</", name, hl ">"]+showToken _ (Text s) = B.fromText s+showToken hl (Comment s) = cc [hl "<!--", s, hl "-->"]+showToken hl (Special name s) = cc [hl "<!", name, " ", s, hl ">"]+showToken _ (Incomplete s) = B.fromText s+-- }}}++-- {{{ Stream+tokenStream :: Monad m => GInfConduit Text m Token+tokenStream =+    loop T.empty+  where+    loop accum = awaitE >>= either (close accum) (push accum)++    push accum input =+        case parseOnly html (accum `T.append` input) of+            Right (splitAccum -> (accum', tokens)) -> mapM_ yield tokens >> loop accum'+            Left err -> fail err++    close s r = do+        unless (T.null s) $ yield $ Text s+        return r+-- }}}
Text/HTML/TagStream/Types.hs view
@@ -1,14 +1,9 @@-{-# LANGUAGE OverloadedStrings, FlexibleInstances #-} module Text.HTML.TagStream.Types where -import Data.Monoid-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S-import Blaze.ByteString.Builder (Builder, fromByteString, toByteString) import Control.Arrow ((***))  type Attr' s = (s, s)-type Attr = Attr' ByteString+ data Token' s = TagOpen s [Attr' s] Bool               | TagClose s               | Text s@@ -20,34 +15,6 @@ data TagType = TagTypeClose              | TagTypeSpecial              | TagTypeNormal--type Token = Token' ByteString--cc :: [ByteString] -> Builder-cc = mconcat . map fromByteString--showToken :: (ByteString -> ByteString) -> Token -> Builder-showToken hl (TagOpen name as close) =-    cc $ [hl "<", name]-      ++ map showAttr as-      ++ [hl (if close then "/>" else ">")]-  where-    showAttr :: Attr -> ByteString-    showAttr (key, value) = S.concat $ [" ", key, hl "=\""] ++ map escape (S.unpack value) ++ [hl "\""]-    escape '"' = "\\\""-    escape '\\' = "\\\\"-    escape c = S.singleton c-showToken hl (TagClose name) = cc [hl "</", name, hl ">"]-showToken _ (Text s) = fromByteString s-showToken hl (Comment s) = cc [hl "<!--", s, hl "-->"]-showToken hl (Special name s) = cc [hl "<!", name, " ", s, hl ">"]-showToken _ (Incomplete s) = fromByteString s--encode :: [Token] -> ByteString-encode = encodeHL id--encodeHL :: (ByteString -> ByteString) -> [Token] -> ByteString-encodeHL hl = toByteString . mconcat . map (showToken hl)  instance Functor Token' where     fmap f (TagOpen x pairs b) = TagOpen (f x) (map (f *** f) pairs) b
− Text/HTML/TagStream/Utils.hs 
@@ -1,22 +0,0 @@-module Text.HTML.TagStream.Utils where-import Data.Word-import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)-import Foreign.Storable (Storable(peekByteOff))-import qualified Data.ByteString as S-import qualified Data.ByteString.Internal as S--peekByteOff' :: Storable a => ForeignPtr b -> Int -> a-peekByteOff' p i = S.inlinePerformIO $ withForeignPtr p $ \p' -> peekByteOff p' i--cons' :: Word8 -> S.ByteString -> S.ByteString-cons' c bs@(S.PS p s l)-  | s>0 && peekByteOff' p (s-1)==c = S.PS p (s-1) (l+1)-  | otherwise = S.cons c bs--cons :: Char -> S.ByteString -> S.ByteString-cons = cons' . S.c2w--append :: S.ByteString -> S.ByteString -> S.ByteString-append (S.PS p1 s1 l1) (S.PS p2 s2 l2)-  | p1==p2 && (s1+l1)==s2 = S.PS p1 s1 (l1+l2)-append xs ys = S.append xs ys
tagstream-conduit.cabal view
@@ -1,5 +1,5 @@ Name:                tagstream-conduit-Version:             0.4.0+Version:             0.5.0 Synopsis:            streamlined html tag parser Description:     Tag-stream is a library for parsing HTML//XML to a token stream.@@ -24,14 +24,14 @@   location: git://github.com/yihuang/tagstream-conduit  Library-  GHC-Options:       -Wall+  GHC-Options:       -Wall -O2   Exposed-modules:     Text.HTML.TagStream-                     , Text.HTML.TagStream.Parser+                     , Text.HTML.TagStream.ByteString+                     , Text.HTML.TagStream.Text                      , Text.HTML.TagStream.Types-                     , Text.HTML.TagStream.Stream-                     , Text.HTML.TagStream.Utils   Build-depends:       base >= 4 && < 5                      , bytestring+                     , text                      , conduit >= 0.5 && < 0.6                      , attoparsec                      , blaze-builder@@ -43,6 +43,7 @@     type: exitcode-stdio-1.0     build-depends:     base >= 4 && < 5                      , bytestring+                     , text                      , conduit >= 0.0.2                      , QuickCheck                      , HUnit
tests/Tests.hs view
@@ -3,44 +3,76 @@ 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.Conduit as C+import qualified Data.Conduit.List as CL+ import Test.Hspec.Monadic import Test.Hspec.HUnit () import Test.Hspec.QuickCheck (prop) import Test.HUnit hiding (Test) import Test.QuickCheck-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S-import qualified Data.Conduit as C-import qualified Data.Conduit.List as CL+ import Text.HTML.TagStream+import qualified Text.HTML.TagStream.ByteString as S+import qualified Text.HTML.TagStream.Text as T  main :: IO ()-main = hspecX $ do-    describe "Property" $ do+main = hspec $ do+    describe "[ByteString] Property" $ do          prop "Text nodes can't be empty" propTextNotEmpty          prop "Parse results can't empty" propResultNotEmpty-    describe "One pass parse" onePassTests-    describe "Streamline parse" streamlineTests+    describe "[Text] Property" $ do+         prop "Text nodes can't be empty" propTextNotEmptyText+         prop "Parse results can't empty" propResultNotEmptyText+    describe "[ByteString]One pass parse" onePassTests+    describe "[ByteString]Streamline parse" streamlineTests+    describe "[Text]One pass parse" onePassTestsText+    describe "[Text]Streamline parse" streamlineTestsText  propTextNotEmpty :: ByteString -> Bool-propTextNotEmpty = either (const False) text_not_empty . decode+propTextNotEmpty = either (const False) text_not_empty . S.decode   where text_not_empty = all not_empty         not_empty (Text s) = S.length s > 0         not_empty _ = True  propResultNotEmpty :: ByteString -> Bool-propResultNotEmpty s = either (const False) not_empty . decode $ s+propResultNotEmpty s = either (const False) not_empty . S.decode $ s   where not_empty tokens = (S.null s && null tokens)                         || (not (S.null s) && not (null tokens)) -onePassTests :: Specs+propTextNotEmptyText :: Text -> Bool+propTextNotEmptyText = either (const False) text_not_empty . T.decode+  where text_not_empty = all not_empty+        not_empty (Text s) = not (T.null s)+        not_empty _ = True++propResultNotEmptyText :: Text -> Bool+propResultNotEmptyText s = either (const False) not_empty . T.decode $ s+  where not_empty tokens = (T.null s && null tokens)+                        || (not (T.null s) && not (null tokens))++onePassTests :: Spec onePassTests = mapM_ one testcases   where     one (str, tokens) = it (S.unpack str) $ do-        result <- combineText <$> assertDecode str+        result <- combineText <$> assertDecodeBS str         assertEqual "one-pass parse result incorrect" tokens result -streamlineTests :: Specs+onePassTestsText :: Spec+onePassTestsText = mapM_ one testcases+  where+    one (str, tokens) = it (T.unpack str) $ do+        result <- combineText <$> assertDecodeText str+        assertEqual "one-pass parse result incorrect" tokens result++streamlineTests :: Spec streamlineTests = mapM_ one testcases   where     isIncomplete (Incomplete _) = True@@ -50,11 +82,25 @@         let tokens' = reverse . dropWhile isIncomplete  . reverse $ tokens         result <- combineText <$> C.runResourceT (                       CL.sourceList (map S.singleton (S.unpack str))-                      C.$= tokenStream+                      C.$= S.tokenStream                       C.$$ CL.consume )         assertEqual "streamline parse result incorrect" tokens' result -testcases :: [(ByteString, [Token])]+streamlineTestsText :: Spec+streamlineTestsText = mapM_ one testcases+  where+    isIncomplete (Incomplete _) = True+    isIncomplete _ = False+    one (str, tokens) = it (T.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+                      C.$$ CL.consume )+        assertEqual "streamline parse result incorrect" tokens' result++testcases :: IsString s => [(s, [Token' s])] testcases =   -- attributes {{{   [ ( "<span readonly title=foo class=\"foo bar\" style='display:none;'>"@@ -158,21 +204,32 @@ testString = listOf testChar testBS :: Gen ByteString testBS = S.pack <$> testString+testText :: Gen Text+testText = T.pack <$> testString  instance Arbitrary ByteString where     arbitrary = testBS+instance Arbitrary Text where+    arbitrary = testText  assertEither :: Either String a -> Assertion assertEither = either (assertFailure . ("Left:"++)) (const $ return ()) -assertDecode :: ByteString -> IO [Token]-assertDecode s = do-    let result = decode s+assertDecodeBS :: ByteString -> IO [S.Token]+assertDecodeBS s = do+    let result = S.decode s     assertEither result     let (Right tokens) = result     return tokens -combineText :: [Token] -> [Token]+assertDecodeText :: Text -> IO [T.Token]+assertDecodeText s = do+    let result = T.decode s+    assertEither result+    let (Right tokens) = result+    return tokens++combineText :: Monoid s => [Token' s] -> [Token' s] combineText [] = []-combineText (Text t1 : Text t2 : xs) = combineText $ Text (S.append t1 t2) : xs+combineText (Text t1 : Text t2 : xs) = combineText $ Text (mappend t1 t2) : xs combineText (x:xs) = x : combineText xs