Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

seperate bytestring and text interface.

  • Loading branch information...
commit 366e4b121b4b2877acc90b9c81ec198a4d58d8cb 1 parent 6e0edfd
@yihuang authored
View
6 Highlight.hs
@@ -11,6 +11,12 @@ import qualified Data.Conduit.List as CL
import Blaze.ByteString.Builder (Builder)
import Data.Conduit.Blaze (builderToByteString)
+encodeHL :: (ByteString -> ByteString) -> [Token] -> ByteString
+encodeHL hl = B.toByteString . mconcat . map (showToken hl)
+
+encode :: [Token] -> ByteString
+encode = encodeHL id
+
color :: Color -> ByteString -> ByteString
color c s = S.concat [ S.pack $ setSGRCode [SetColor Foreground Dull c]
, s
View
12 Text/HTML/TagStream.hs
@@ -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
View
75 Text/HTML/TagStream/Parser.hs → Text/HTML/TagStream/ByteString.hs
@@ -1,18 +1,27 @@
-{-# LANGUAGE OverloadedStrings, TupleSections #-}
-module Text.HTML.TagStream.Parser where
+{-# 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 Blaze.ByteString.Builder (toByteString)
+import Data.Conduit (GInfConduit, awaitE, yield)
+
+import qualified Blaze.ByteString.Builder as B
import Text.HTML.TagStream.Types
-import Text.HTML.TagStream.Utils (cons, append)
+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 = append <$> takeTill (in2 ('\\',q))
+quoted q = S.append <$> takeTill (in2 ('\\',q))
<*> ( char q *> pure ""
<|> char '\\' *> atLeast 1 (quoted q) )
@@ -32,8 +41,8 @@ attrValue = quotedOr $ takeTill ((=='>') ||. isSpace)
-}
attrName :: Parser ByteString
attrName = quotedOr $
- cons <$> satisfy (/='>')
- <*> takeTill (in3 ('/','>','=') ||. isSpace)
+ S.cons <$> satisfy (/='>')
+ <*> takeTill (in3 ('/','>','=') ||. isSpace)
{--
- tag end, return self-close or not, can fail.
@@ -68,7 +77,7 @@ attrs = loop []
-}
comment :: Parser Token
comment = Comment <$> comment'
- where comment' = append <$> takeTill (=='-')
+ where comment' = S.append <$> takeTill (=='-')
<*> ( string "-->" *> return ""
<|> atLeast 1 comment' )
@@ -77,7 +86,7 @@ comment = Comment <$> comment'
-}
special :: Parser Token
special = Special
- <$> ( cons <$> satisfy (not . ((=='-') ||. isSpace))
+ <$> ( S.cons <$> satisfy (not . ((=='-') ||. isSpace))
<*> takeTill ((=='>') ||. isSpace)
<* skipSpace )
<*> takeTill (=='>') <* char '>'
@@ -106,7 +115,7 @@ tag = do
- record incomplete tag for streamline processing.
-}
incomplete :: Parser Token
-incomplete = Incomplete . cons '<' <$> takeByteString
+incomplete = Incomplete . S.cons '<' <$> takeByteString
{--
- parse text node. consume at least one char, to make sure progress.
@@ -123,9 +132,9 @@ token = char '<' *> (tag <|> incomplete)
-}
tillScriptEnd :: Token -> Parser [Token]
tillScriptEnd t = reverse <$> loop [t]
- <|> (:[]) . Incomplete . append script <$> takeByteString
+ <|> (:[]) . Incomplete . S.append script <$> takeByteString
where
- script = toByteString $ showToken id t
+ script = B.toByteString $ showToken id t
loop acc = (:acc) <$> scriptEnd
<|> (text >>= loop . (:acc))
scriptEnd = string "</script>" *> return (TagClose "script")
@@ -151,7 +160,7 @@ decode = parseOnly html
atLeast :: Int -> Parser ByteString -> Parser ByteString
atLeast 0 p = p
-atLeast n p = cons <$> anyChar <*> atLeast (n-1) 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
@@ -171,3 +180,43 @@ 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
+
+-- }}}
View
31 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)
View
223 Text/HTML/TagStream/Text.hs
@@ -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
+-- }}}
View
35 Text/HTML/TagStream/Types.hs
@@ -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
@@ -21,34 +16,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
fmap f (TagClose x) = TagClose (f x)
View
26 Text/HTML/TagStream/Utils.hs
@@ -1,22 +1,10 @@
+{-# LANGUAGE ViewPatterns #-}
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
+import Data.Monoid (Monoid(..))
+import Text.HTML.TagStream.Types
-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
+splitAccum :: Monoid s => [Token' s] -> (s, [Token' s])
+splitAccum [] = (mempty, [])
+splitAccum (reverse -> (Incomplete s : xs)) = (s, reverse xs)
+splitAccum tokens = (mempty, tokens)
View
7 tagstream-conduit.cabal
@@ -26,12 +26,12 @@ source-repository head
Library
GHC-Options: -Wall
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 @@ test-suite test
type: exitcode-stdio-1.0
build-depends: base >= 4 && < 5
, bytestring
+ , text
, conduit >= 0.0.2
, QuickCheck
, HUnit
View
97 tests/Tests.hs
@@ -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 @@ streamlineTests = mapM_ one testcases
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 :: Gen String
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
+
+assertDecodeText :: Text -> IO [T.Token]
+assertDecodeText s = do
+ let result = T.decode s
assertEither result
let (Right tokens) = result
return tokens
-combineText :: [Token] -> [Token]
+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
Please sign in to comment.
Something went wrong with that request. Please try again.