packages feed

tag-stream 0.1.0 → 0.2.0

raw patch · 8 files changed

+372/−182 lines, 8 filesdep +blaze-builderdep ~enumeratorPVP ok

version bump matches the API change (PVP)

Dependencies added: blaze-builder

Dependency ranges changed: enumerator

API changes (from Hackage documentation)

- Text.HTML.TagStream.Parser: value :: Parser ByteString
+ Text.HTML.TagStream: Incomplete :: s -> Token' s
+ Text.HTML.TagStream.Parser: atLeast :: Int -> Parser ByteString -> Parser ByteString
+ Text.HTML.TagStream.Parser: attrName :: Parser ByteString
+ Text.HTML.TagStream.Parser: attrValue :: Parser ByteString
+ Text.HTML.TagStream.Parser: boolP :: Parser a -> Parser Bool
+ Text.HTML.TagStream.Parser: cond :: a -> a -> Bool -> a
+ Text.HTML.TagStream.Parser: in2 :: Eq a => (a, a) -> a -> Bool
+ Text.HTML.TagStream.Parser: in3 :: Eq a => (a, a, a) -> a -> Bool
+ Text.HTML.TagStream.Parser: incomplete :: Parser Token
+ Text.HTML.TagStream.Parser: maybeP :: Parser a -> Parser (Maybe a)
+ Text.HTML.TagStream.Parser: quoted :: Char -> Parser ByteString
+ Text.HTML.TagStream.Parser: quotedOr :: Parser ByteString -> Parser ByteString
+ Text.HTML.TagStream.Parser: tagEnd :: Parser Bool
+ Text.HTML.TagStream.Parser: tillScriptEnd :: Token -> Parser [Token]
+ Text.HTML.TagStream.Types: Incomplete :: s -> Token' s
+ Text.HTML.TagStream.Types: TagTypeClose :: TagType
+ Text.HTML.TagStream.Types: TagTypeNormal :: TagType
+ Text.HTML.TagStream.Types: TagTypeSpecial :: TagType
+ Text.HTML.TagStream.Types: cc :: [ByteString] -> Builder
+ Text.HTML.TagStream.Types: data TagType
+ Text.HTML.TagStream.Utils: append :: ByteString -> ByteString -> ByteString
+ Text.HTML.TagStream.Utils: cons :: Char -> ByteString -> ByteString
+ Text.HTML.TagStream.Utils: cons' :: Word8 -> ByteString -> ByteString
+ Text.HTML.TagStream.Utils: peekByteOff' :: Storable a => ForeignPtr b -> Int -> a
- Text.HTML.TagStream: showToken :: (ByteString -> ByteString) -> Token -> ByteString
+ Text.HTML.TagStream: showToken :: (ByteString -> ByteString) -> Token -> Builder
- Text.HTML.TagStream.Parser: attrs :: Parser [Attr]
+ Text.HTML.TagStream.Parser: attrs :: Parser ([Attr], Bool)
- Text.HTML.TagStream.Parser: comment :: Parser ByteString
+ Text.HTML.TagStream.Parser: comment :: Parser Token
- Text.HTML.TagStream.Types: showToken :: (ByteString -> ByteString) -> Token -> ByteString
+ Text.HTML.TagStream.Types: showToken :: (ByteString -> ByteString) -> Token -> Builder

Files

FilterUrl.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} import Control.Applicative import System.Environment (getArgs)-import System.IO (openBinaryFile, IOMode(..))+import System.IO (stdout) import qualified Data.Enumerator.Binary as E import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S@@ -9,6 +9,7 @@ import qualified Data.Enumerator.List as EL import Data.Attoparsec.Char8 import Text.HTML.TagStream+import Blaze.ByteString.Builder.Enumerator (builderToByteString)  type Protocol = ByteString type Domain = ByteString@@ -41,8 +42,9 @@ main :: IO () main = do     [filename] <- getArgs-    h <- openBinaryFile filename ReadMode-    let bufSize = 2-        enum = E.enumHandle bufSize h-    tokens <- E.run_ $ ((enum E.$= tokenStream) E.$= withUrl changeUrl) E.$$ EL.consume-    S.putStrLn $ S.concat $ map (showToken id) tokens+    E.run_ $ E.enumFile filename+             E.$= tokenStream+             E.$= withUrl changeUrl+             E.$= EL.map (showToken id)+             E.$= builderToByteString+             E.$$ E.iterHandle stdout
Highlight.hs view
@@ -8,6 +8,8 @@ import qualified Data.Enumerator as E import qualified Data.Enumerator.Binary as E import qualified Data.Enumerator.List as EL+import Blaze.ByteString.Builder (Builder)+import Blaze.ByteString.Builder.Enumerator (unsafeBuilderToByteString, allocBuffer)  color :: Color -> ByteString -> ByteString color c s = S.concat [ S.pack $ setSGRCode [SetColor Foreground Dull c]@@ -15,12 +17,16 @@                      , S.pack $ setSGRCode [SetColor Foreground Dull White]                      ] -hightlightStream :: Monad m => E.Enumeratee Token ByteString m b+hightlightStream :: Monad m => E.Enumeratee Token Builder m b hightlightStream = EL.map (showToken (color Red))  main :: IO () main = do     args <- getArgs     filename <- maybe (fail "pass file path") return (listToMaybe args)-    let enum = (E.enumFile filename E.$= tokenStream) E.$= hightlightStream-    E.run_ $ enum E.$$ E.iterHandle stdout+    let iter = E.enumFile filename+               E.$= tokenStream+               E.$= hightlightStream+               E.$= unsafeBuilderToByteString (allocBuffer 4096)+               E.$$ E.iterHandle stdout+    E.run_ iter
Text/HTML/TagStream/Parser.hs view
@@ -1,82 +1,182 @@ {-# LANGUAGE OverloadedStrings, TupleSections #-} module Text.HTML.TagStream.Parser where -import Prelude hiding (takeWhile)-import Control.Applicative hiding (many)-import Data.Attoparsec.Char8+import Control.Applicative import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S+import Data.Attoparsec.Char8+import Blaze.ByteString.Builder (toByteString) import Text.HTML.TagStream.Types+import Text.HTML.TagStream.Utils (cons, append) -(||.) :: Applicative f => f Bool -> f Bool -> f Bool-(||.) = liftA2 (||)--- (&&.) = liftA2 (&&)+{--+ - match quoted string, can fail.+ -}+quoted :: Char -> Parser ByteString+quoted q = append <$> takeTill (in2 ('\\',q))+                  <*> ( char q *> pure ""+                        <|> char '\\' *> atLeast 1 (quoted q) ) -value :: Parser ByteString-value = char '"' *> str-    <|> takeTill (inClass ">=" ||. isSpace)-  where-    str = S.append <$> takeTill (inClass "\\\"") -                   <*> (end <|> unescape)-    end = char '"' *> return ""-    unescape = char '\\' *> -               (S.cons <$> anyChar <*> str)+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 = do-    skipSpace-    c <- satisfy (notInClass "/>")-    name' <- takeTill (inClass ">=" ||. isSpace)-    let name = S.cons c name'-    skipSpace-    option (name, S.empty) $ do-        _ <- char '='-        skipSpace-        (name,) <$> value+attr = (,) <$> attrName <* skipSpace+           <*> ( boolP (char '=') >>=+                 cond (skipSpace *> attrValue)+                      (pure "")+               ) -attrs :: Parser [Attr]-attrs = many attr+{--+ - 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 :: Parser ByteString-comment = S.append <$>-            takeTill (=='-') <*>-            ( string "-->" *> return "" <|>-              S.cons <$> anyChar <*> comment )+{--+ - 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 = Comment <$> ( string "--" *> comment )-      <|> Special-          <$> ( S.cons-                <$> satisfy (not . ((=='-') ||. isSpace))-                <*> takeTill ((=='>') ||. isSpace)-                <* skipSpace )-          <*> takeTill (=='>')-          <*  char '>'+special = Special+          <$> ( cons <$> satisfy (not . ((=='-') ||. isSpace))+                     <*> takeTill ((=='>') ||. isSpace)+                     <* skipSpace )+          <*> takeTill (=='>') <* char '>' +{--+ - parse a tag, can fail.+ -} tag :: Parser Token-tag = string "<!" *> special-  <|> string "</"-      *> (TagClose <$> takeTill (=='>'))-      <* char '>'-  <|> char '<'-      *> ( TagOpen-           <$> ( S.cons-                 <$> satisfy (not . (isSpace ||. (inClass "!>")))-                 <*> takeTill (inClass "/>" ||. isSpace) )-           <*> attrs <* skipSpace-           <*> ( char '>' *> return False-             <|> string "/>" *> return True ) )+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 <$> (-         S.cons <$> anyChar <*> takeTill (=='<')-       )+text = Text <$> atLeast 1 (takeTill (=='<'))  token :: Parser Token-token = tag <|> text+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+    surround q s = S.concat [S.singleton q, s, S.singleton q]+    loop acc = do+        s <- takeTill (in3 ('<','\'','"'))+        let acc' = if S.null s then acc else Text s:acc+        mq <- maybeP (satisfy (in2 ('"','\'')))+        case mq of+            Just q -> Text . surround q <$> quoted q >>=+                      loop . (:acc')+            Nothing -> (:acc') <$> scriptEnd++    scriptEnd = string "</script>" *> return (TagClose "script")+ html :: Parser [Token]-html = many 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 view
@@ -17,7 +17,7 @@   where     splitAccum :: [Token] -> (ByteString, [Token])     splitAccum [] = (S.empty, [])-    splitAccum (reverse -> (Text s : xs)) = (s, reverse xs)+    splitAccum (reverse -> (Incomplete s : xs)) = (s, reverse xs)     splitAccum tokens = (S.empty, tokens)  tokenStream :: Monad m => E.Enumeratee ByteString Token m b
Text/HTML/TagStream/Types.hs view
@@ -1,8 +1,10 @@ {-# 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)  type Attr' s = (s, s) type Attr = Attr' ByteString@@ -11,28 +13,37 @@               | Text s               | Comment s               | Special s s+              | Incomplete s     deriving (Eq, Show) +data TagType = TagTypeClose+             | TagTypeSpecial+             | TagTypeNormal+ type Token = Token' ByteString -showToken :: (ByteString -> ByteString) -> Token -> ByteString+cc :: [ByteString] -> Builder+cc = mconcat . map fromByteString++showToken :: (ByteString -> ByteString) -> Token -> Builder showToken hl (TagOpen name as close) =-    S.concat $ [hl "<", name]-            ++ map showAttr as-            ++ [hl (if close then "/>" else ">")]+    cc $ [hl "<", name]+      ++ map showAttr as+      ++ [hl (if close then "/>" else ">")]   where     showAttr :: Attr -> ByteString-    showAttr (key, value) = S.concat [" ", key, hl "=\"", S.pack . concatMap escape . S.unpack $ value, hl "\""]+    showAttr (key, value) = S.concat $ [" ", key, hl "=\""] ++ map escape (S.unpack value) ++ [hl "\""]     escape '"' = "\\\""     escape '\\' = "\\\\"-    escape c = [c]-showToken hl (TagClose name) = S.concat [hl "</", name, hl ">"]-showToken _ (Text s) = s-showToken hl (Comment s) = S.concat [hl "<!--", s, hl "-->"]-showToken hl (Special name s) = S.concat [hl "<!", name, " ", s, hl ">"]+    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 = S.concat . map (showToken hl)+encodeHL :: (ByteString -> ByteString) -> [Token] -> ByteString+encodeHL hl = toByteString . mconcat . map (showToken hl)
+ Text/HTML/TagStream/Utils.hs view
@@ -0,0 +1,22 @@+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
tag-stream.cabal view
@@ -1,7 +1,12 @@ Name:                tag-stream-Version:             0.1.0+Version:             0.2.0 Synopsis:            streamlined html tag parser-Description:         Tag-stream is a library for parsing HTML/XML to a token stream. It can parse unstructured and malformed HTML from the web. It also provides an Enumeratee which can parse streamline html, which means it consumes constant memory. You can start from `tests/Tests.hs` to see what it can do.+Description:+    Tag-stream is a library for parsing HTML//XML to a token stream.+    It can parse unstructured and malformed HTML from the web.+    It also provides an Enumeratee which can parse streamline html, which means it consumes constant memory.++    Users can start from the `tests/Tests.hs` module to see what it can do. Homepage:            http://github.com/yihuang/tag-stream License:             BSD3 License-file:        LICENSE@@ -19,12 +24,14 @@   location: git://github.com/yihuang/tag-stream.git  Library-  GHC-Options:       -Wall+  GHC-Options:       -Wall -O2   Exposed-modules:     Text.HTML.TagStream                      , Text.HTML.TagStream.Parser                      , Text.HTML.TagStream.Types                      , Text.HTML.TagStream.Stream+                     , Text.HTML.TagStream.Utils   Build-depends:       base >= 4 && < 5                      , bytestring+                     , enumerator >= 0.4.15                      , attoparsec-                     , enumerator+                     , blaze-builder
tests/Tests.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleInstances, OverloadedStrings #-} module Main where -import Debug.Trace import Control.Applicative import Test.Framework (defaultMain, testGroup, Test) import Test.Framework.Providers.HUnit@@ -10,17 +9,149 @@ import Test.QuickCheck import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S+import qualified Data.Enumerator as E+import qualified Data.Enumerator.List as EL import Text.HTML.TagStream  main :: IO ()-main = defaultMain tests+main = defaultMain+         [ testGroup "Property"+             [ testProperty "Text nodes can't be empty" propTextNotEmpty+             , testProperty "Parse results can't empty" propResultNotEmpty+             ]+         , testGroup "One pass parse" onePassTests+         , testGroup "Streamline parse" streamlineTests+         ] -atLeast :: Arbitrary a => Int -> Gen [a]-atLeast 0 = arbitrary-atLeast n = (:) <$> arbitrary <*> atLeast (n-1)+propTextNotEmpty :: ByteString -> Bool+propTextNotEmpty = either (const False) text_not_empty . 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+  where not_empty tokens = (S.null s && null tokens)+                        || (not (S.null s) && not (null tokens))++onePassTests :: [Test]+onePassTests = map one testcases+  where+    one (str, tokens) = testCase (S.unpack str) $ do+        result <- combineText <$> assertDecode str+        assertEqual "one-pass parse result incorrect" tokens result++streamlineTests :: [Test]+streamlineTests = map one testcases+  where+    isIncomplete (Incomplete _) = True+    isIncomplete _ = False+    one (str, tokens) = testCase (S.unpack str) $ do+        -- streamline parse result don't contain the trailing Incomplete token.+        let tokens' = reverse . dropWhile isIncomplete  . reverse $ tokens+        result <- combineText <$> E.run_ (+                      E.enumList 1 (map S.singleton (S.unpack str))+                      E.$= tokenStream+                      E.$$ EL.consume )+        assertEqual "streamline parse result incorrect" tokens' result++testcases :: [(ByteString, [Token])]+testcases =+  -- attributes {{{+  [ ( "<span readonly title=foo class=\"foo bar\" style='display:none;'>"+    , [TagOpen "span" [("readonly", ""), ("title", "foo"), ("class", "foo bar"), ("style", "display:none;")] False]+    )+  , ( "<span a = b = c = d>"+    , [TagOpen "span" [("a", "b"), ("=", ""), ("c", "d")] False]+    )+  , ( "<span a = b = c>"+    , [TagOpen "span" [("a", "b"), ("=", ""), ("c", "")] False]+    )+  , ( "<span /foo=bar>"+    , [TagOpen "span" [("/foo", "bar")] False]+    )+  -- }}}+  -- quoted string and escaping {{{+  , ( "<span \"<p>xx \\\"'\\\\</p>\"=\"<p>xx \\\"'\\\\</p>\">"+    , [TagOpen "span" [("<p>xx \"'\\</p>", "<p>xx \"'\\</p>")] False]+    )+  , ( "<span '<p>xx \\\"\\'\\\\</p>'='<p>xx \\\"\\'\\\\</p>'>"+    , [TagOpen "span" [("<p>xx \"'\\</p>", "<p>xx \"'\\</p>")] False]+    )+  -- }}}+  -- attribute and tag end {{{+  , ( "<br/>"+    , [TagOpen "br" [] True]+    )+  , ( "<img src=http://foo.bar.com/foo.jpg />"+    , [TagOpen "img" [("src", "http://foo.bar.com/foo.jpg")] True]+    )+  , ( "<span foo>"+    , [TagOpen "span" [("foo", "")] False]+    )+  , ( "<span foo/>"+    , [TagOpen "span" [("foo", "")] True]+    )+  , ( "<span foo=/>"+    , [TagOpen "span" [("foo", "/")] False]+    )+  -- }}}+  -- normal tag {{{+  , ( "<p>text</p>"+    , [TagOpen "p" [] False, Text "text", TagClose "p"]+    )+  , ( "<>"+    , [TagOpen "" [] False]+    )+  , ( "<a\ttitle\n=\r\"foo\nbar\" alt=\n/\r\t>"+    , [TagOpen "a" [("title", "foo\nbar"), ("alt", "/")] False]+    )+  -- }}}+  -- comment tag {{{+  , ( "<!--foo-->"+    , [Comment "foo"] )+  , ( "<!--f--oo->-->"+    , [Comment "f--oo->"] )+  , ( "<!--foo-->bar-->"+    , [Comment "foo", Text "bar-->"]+    )+  -- }}}+  -- special tag {{{+  , ( "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\">"+    , [Special "DOCTYPE" "html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\""]+    )+  , ( "<!DOCTYPE html>"+    , [Special "DOCTYPE" "html"]+    )+  -- }}}+  -- close tag {{{+  , ( "</\r\t\nbr>"+    , [TagClose "\r\t\nbr"]+    )+  , ( "</br/>"+    , [TagClose "br/"]+    )+  , ( "</>"+    , [TagClose ""]+    )+  -- }}}+  -- incomplete test {{{+  -- }}}+  -- script tag TODO{{{+  , ( "<script></script>"+    , [TagOpen "script" [] False, TagClose "script"]+    )+  , ( "<script>var x=\"</script>\";"+    , [Incomplete "<script>var x=\"</script>\";"]+    )+  , ( "<script>var x=\"</script>\";</script>"+    , [TagOpen "script" [] False, Text "var x=\"</script>\";", TagClose "script"]+    )+  -- }}}+  ]+ testChar :: Gen Char-testChar = growingElements "<>=\"' \tabcde\\"+testChar = growingElements "<>/=\"' \t\r\nabcde\\" testString :: Gen String testString = listOf testChar testBS :: Gen ByteString@@ -29,28 +160,6 @@ instance Arbitrary ByteString where     arbitrary = testBS -instance Arbitrary (Token' ByteString) where-    arbitrary = oneof [ TagOpen <$> arbitrary <*> arbitrary <*> arbitrary-                      , TagClose <$> arbitrary-                      , Text <$> S.pack <$> atLeast 1-                      ]--tests :: [Test]-tests = [ testGroup "Property"-            [-- testProperty "revertiable" prop_revertiable1-            ]-        , testGroup "Special cases"-            [ testCase "special cases" testSpecialCases-            --, testCase "parse real world file" testRealworldFiles-            ]-        ]--prop_revertiable1 :: ByteString -> Bool-prop_revertiable1 = either (const False) prop_revertiable . decode--prop_revertiable :: [Token] -> Bool-prop_revertiable tokens = either (const False) (==tokens) . decode . encode $ tokens- assertEither :: Either String a -> Assertion assertEither = either (assertFailure . ("Left:"++)) (const $ return ()) @@ -61,74 +170,7 @@     let (Right tokens) = result     return tokens -testSpecialCases :: Assertion-testSpecialCases = mapM_ testOne testcases-  where-    testOne (str, tokens) =-      trace (show' str tokens) $-        assertDecode str >>= assertEqual "parse result incorrect" tokens-    show' str tokens = S.unpack $ S.concat [str, "\n", S.pack (show tokens)]-    testcases =-      [( "<a readonly title=xxx href=\"f<o/>o\" class=\"foo bar\">bar</a>",-         [TagOpen "a" [("readonly", ""), ("title", "xxx"), ("href", "f<o/>o"), ("class", "foo bar")] False,-          Text "bar",-          TagClose "a"] )-      ,( "<a href=fo\"o >",-         [TagOpen "a" [("href", "fo\"o")] False] )-      ,( "<a href=\"f\\\"oo\" >",-         [TagOpen "a" [("href", "f\"oo")] False] )-      ,( "<a href=\"f\\\\\\\"oo\" >",-         [TagOpen "a" [("href", "f\\\"oo")] False] )-      ,( "<a href=\"f\noo\" >",-         [TagOpen "a" [("href", "f\noo")] False] )-      ,( "<a href=>",-         [TagOpen "a" [("href", "")] False] )-      ,( "<a href=http://www.douban.com/>",-         [TagOpen "a" [("href", "http://www.douban.com/")] False] )-      ,( "<a alt=foo />",-         [TagOpen "a" [("alt", "foo")] True] )-      ,( "<a href>",-         [TagOpen "a" [("href", "")] False] )-      ,( "<a href src=/>",-         [TagOpen "a" [("href", ""), ("src", "/")] False] )-      ,( "<a\tsrc\t\r\nhref\n=\n\"\nfo\t\no\n\" title\r\n\t=>",-         [TagOpen "a" [("src", ""), ("href", "\nfo\t\no\n"), ("title", "")] False] )-      ,( "<br />",-         [TagOpen "br" [] True] )-      ,( "</br/>",-         [TagClose "br/"] )-      ,( "<\n/br/>",-         [Text "<\n/br/>"] )-      ,( "< asafasd>",-         [Text "< asafasd>"] )-      ,( "<a href=\"http://",-         [Text "<a href=\"http://"] )-      ,( "<>",-         [Text "<>"] )-      ,( "</>",-         [TagClose ""] )-      ,( "</\ndiv>",-         [TagClose "\ndiv"] )-      ,( "<!--foo-->",-         [Comment "foo"] )-      ,( "<!--f--oo->-->",-         [Comment "f--oo->"] )-      ,( "<!--fo--o->",-         [Text "<!--fo--o->"] )-      ,( "<!--fo--o->",-         [Text "<!--fo--o->"] )-      ,( "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\">",-         [Special "DOCTYPE" "html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\""] )-      ,( "<!DOCTYPE/>",-         [Special "DOCTYPE/" ""] )-      ]--testRealworldFiles :: Assertion-testRealworldFiles = mapM_ testFile files-  where-    testFile file = do-        result <- decode <$> S.readFile file-        assertEither result-        assertEqual "not equal" result $ encode <$> result >>= decode-    files = [ "qq.html"-            ]+combineText :: [Token] -> [Token]+combineText [] = []+combineText (Text t1 : Text t2 : xs) = combineText $ Text (S.append t1 t2) : xs+combineText (x:xs) = x : combineText xs