diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright John Ky (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +# hw-conduit +[![Circle CI](https://circleci.com/gh/haskell-works/hw-conduit.svg?style=svg)](https://circleci.com/gh/haskell-works/hw-conduit) + +Extra facilities for conduits. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "Hello world" diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Monad.Trans.Resource (MonadThrow) +import Criterion.Main +import qualified Data.ByteString as BS +import qualified Data.ByteString.Internal as BSI +import Data.Conduit (Conduit, (=$=)) +import qualified Data.Vector.Storable as DVS +import Data.Word +import Foreign +import HaskellWorks.Data.Conduit.ByteString +import HaskellWorks.Data.Conduit.Json +import HaskellWorks.Data.Conduit.Json.Blank +import HaskellWorks.Data.Conduit.List +import System.IO.MMap + +setupEnvBs :: Int -> IO BS.ByteString +setupEnvBs n = return $ BS.pack (take n (cycle [maxBound, 0])) + +setupEnvBss :: Int -> Int -> IO [BS.ByteString] +setupEnvBss n k = setupEnvBs n >>= \v -> return (replicate k v) + +setupEnvVector :: Int -> IO (DVS.Vector Word64) +setupEnvVector n = return $ DVS.fromList (take n (cycle [maxBound, 0])) + +setupEnvVectors :: Int -> Int -> IO [DVS.Vector Word64] +setupEnvVectors n k = setupEnvVector n >>= \v -> return (replicate k v) + +setupEnvJson :: FilePath -> IO BS.ByteString +setupEnvJson filepath = do + (fptr :: ForeignPtr Word8, offset, size) <- mmapFileForeignPtr filepath ReadOnly Nothing + let !bs = BSI.fromForeignPtr (castForeignPtr fptr) offset size + return bs + +runCon :: Conduit i [] BS.ByteString -> i -> BS.ByteString +runCon con bs = BS.concat $ runListConduit con [bs] + +runCon2 :: Conduit i [] o -> [i] -> [o] +runCon2 con is = let os = runListConduit con is in seq (length os) os + +runCon3 :: Conduit i [] BS.ByteString -> [i] -> [BS.ByteString] +runCon3 con is = let os = runListConduit con is in seq (BS.length (last os)) os + +jsonToInterestBits3 :: MonadThrow m => Conduit BS.ByteString m BS.ByteString +jsonToInterestBits3 = blankJson =$= blankedJsonToInterestBits + +benchRankJson40Conduits :: [Benchmark] +benchRankJson40Conduits = + [ env (setupEnvJson "/Users/jky/Downloads/part40.json") $ \bs -> bgroup "Json40" + [ bench "Run blankJson " (whnf (runCon blankJson ) bs) + , bench "Run jsonToInterestBits3 " (whnf (runCon jsonToInterestBits3 ) bs) + ] + ] + +benchRankJson80Conduits :: [Benchmark] +benchRankJson80Conduits = + [ env (setupEnvJson "/Users/jky/Downloads/part80.json") $ \bs -> bgroup "Json40" + [ bench "Run blankJson " (whnf (runCon blankJson ) bs) + , bench "Run jsonToInterestBits3 " (whnf (runCon jsonToInterestBits3 ) bs) + ] + ] + +benchRankJsonBigConduits :: [Benchmark] +benchRankJsonBigConduits = + [ env (setupEnvJson "/Users/jky/Downloads/78mb.json") $ \bs -> bgroup "JsonBig" + [ bench "Run blankJson " (whnf (runCon blankJson ) bs) + , bench "Run jsonToInterestBits3 " (whnf (runCon jsonToInterestBits3 ) bs) + ] + ] + +benchBlankedJsonToBalancedParens :: [Benchmark] +benchBlankedJsonToBalancedParens = + [ env (setupEnvJson "/Users/jky/Downloads/part40.json") $ \bs -> bgroup "JsonBig" + [ bench "blankedJsonToBalancedParens2" (whnf (runCon2 blankedJsonToBalancedParens) [bs]) + , bench "blankedJsonToBalancedParens2" (whnf (runCon3 blankedJsonToBalancedParens2) [bs]) + , bench "blankedJsonToBalancedParens2" (whnf (runCon3 (blankedJsonToBalancedParens2 =$= rechunk 4060)) [bs]) + ] + ] + +benchRechunk :: [Benchmark] +benchRechunk = + [ env (setupEnvBss 4060 19968) $ \bss -> bgroup "Rank" + [ bench "Rechunk" (whnf (runListConduit (rechunk 1000)) bss) + ] + ] + +main :: IO () +main = defaultMain benchRankJson40Conduits diff --git a/hw-conduit.cabal b/hw-conduit.cabal new file mode 100644 --- /dev/null +++ b/hw-conduit.cabal @@ -0,0 +1,106 @@ +name: hw-conduit +version: 0.0.0.6 +synopsis: Conduits for tokenizing streams. +description: Please see README.md +homepage: http://github.com/haskell-works/hw-conduit#readme +license: BSD3 +license-file: LICENSE +author: John Ky +maintainer: newhoggy@gmail.com +copyright: 2016 John Ky +category: Data, Conduit +build-type: Simple +extra-source-files: README.md +cabal-version: >= 1.10 +data-files: test/data/sample.json + +executable hw-conduit-example + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 -Wall -msse4.2 + build-depends: base >= 4 + , bytestring + , conduit + , criterion + , hw-bits + , hw-prim + , hw-conduit + , mmap + , resourcet + , vector + default-language: Haskell2010 + +library + hs-source-dirs: src + exposed-modules: HaskellWorks.Data.Conduit.ByteString + , HaskellWorks.Data.Conduit.Json + , HaskellWorks.Data.Conduit.Json.Blank + , HaskellWorks.Data.Conduit.Json.Words + , HaskellWorks.Data.Conduit.List + build-depends: base >= 4.7 && < 5 + , array + , attoparsec >= 0.10 + , bytestring + , conduit >= 1.1 && < 1.3 + , deepseq < 1.5 + , ghc-prim + , hw-bits + , hw-prim + , lens + , mmap + , mono-traversable + , parsec + , QuickCheck + , random + , resourcet >= 1.1 + , safe + , text + , vector + , word8 + + default-language: Haskell2010 + ghc-options: -rtsopts -with-rtsopts=-N -Wall -O2 -Wall -msse4.2 + +test-suite hw-conduit-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + other-modules: HaskellWorks.Data.Conduit.ByteStringSpec + , HaskellWorks.Data.Conduit.Json.BlankSpec + build-depends: base + , attoparsec >= 0.10 + , bytestring + , conduit >= 1.1 && < 1.3 + , hspec >= 1.3 + , hw-bits + , hw-prim + , hw-conduit + , mmap + , parsec + , QuickCheck + , resourcet >= 1.1 + , transformers + , vector + ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/haskell-works/hw-conduit + +benchmark bench + Type: exitcode-stdio-1.0 + HS-Source-Dirs: bench + Main-Is: Main.hs + GHC-Options: -O2 -Wall -msse4.2 + Default-Language: Haskell2010 + Build-Depends: base >= 4 && < 5 + , bytestring + , conduit + , criterion + , hw-bits + , hw-prim + , hw-conduit + , mmap + , resourcet + , vector diff --git a/src/HaskellWorks/Data/Conduit/ByteString.hs b/src/HaskellWorks/Data/Conduit/ByteString.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Conduit/ByteString.hs @@ -0,0 +1,32 @@ +module HaskellWorks.Data.Conduit.ByteString + ( rechunk + ) where + +import Control.Monad +import qualified Data.ByteString as BS +import Data.Conduit + +rechunk :: Monad m => Int -> Conduit BS.ByteString m BS.ByteString +rechunk = rechunk' BS.empty + +rechunk' :: Monad m => BS.ByteString -> Int -> Conduit BS.ByteString m BS.ByteString +rechunk' as n | BS.length as >= n = do + yield (BS.take n as) + rechunk' (BS.drop n as) n +rechunk' as n = do + mbss <- slurp (n - BS.length as) + case mbss of + Just bss -> do + let bs = BS.concat (as : bss) + yield (BS.take n bs) + rechunk' (BS.drop n bs) n + Nothing -> unless (BS.null as) $ yield as + +slurp :: Monad m => Int -> ConduitM BS.ByteString BS.ByteString m (Maybe [BS.ByteString]) +slurp = go [] + where go rs n | n > 0 = do + mbs <- await + case mbs of + Just bs -> go (bs : rs) (n - BS.length bs) + Nothing -> if null rs then return Nothing else return (Just (reverse rs)) + go rs _ = if null rs then return Nothing else return (Just (reverse rs)) diff --git a/src/HaskellWorks/Data/Conduit/Json.hs b/src/HaskellWorks/Data/Conduit/Json.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Conduit/Json.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} + +module HaskellWorks.Data.Conduit.Json + ( blankedJsonToInterestBits + , byteStringToBits + , blankedJsonToBalancedParens + , blankedJsonToBalancedParens2 + , compressWordAsBit + , interestingWord8s + ) where + +import Control.Monad +import Data.Array.Unboxed as A +import qualified Data.Bits as BITS +import Data.ByteString as BS +import Data.Conduit +import Data.Int +import Data.Word +import HaskellWorks.Data.Bits.BitWise +import HaskellWorks.Data.Conduit.Json.Words +import Prelude as P + +interestingWord8s :: A.UArray Word8 Word8 +interestingWord8s = A.array (0, 255) [ + (w, if w == wOpenBracket || w == wOpenBrace || w == wOpenParen || w == wt || w == wf || w == wn || w == w1 + then 1 + else 0) + | w <- [0 .. 255]] + +blankedJsonToInterestBits :: Monad m => Conduit BS.ByteString m BS.ByteString +blankedJsonToInterestBits = blankedJsonToInterestBits' "" + +padRight :: Word8 -> Int -> BS.ByteString -> BS.ByteString +padRight w n bs = if BS.length bs >= n then bs else fst (BS.unfoldrN n gen bs) + where gen :: ByteString -> Maybe (Word8, ByteString) + gen cs = case BS.uncons cs of + Just (c, ds) -> Just (c, ds) + Nothing -> Just (w, BS.empty) + +blankedJsonToInterestBits' :: Monad m => BS.ByteString -> Conduit BS.ByteString m BS.ByteString +blankedJsonToInterestBits' rs = do + mbs <- await + case mbs of + Just bs -> do + let cs = if BS.length rs /= 0 then BS.concat [rs, bs] else bs + let lencs = BS.length cs + let q = lencs + 7 `quot` 8 + let (ds, es) = BS.splitAt (q * 8) cs + let (fs, _) = BS.unfoldrN q gen ds + yield fs + blankedJsonToInterestBits' es + Nothing -> return () + where gen :: ByteString -> Maybe (Word8, ByteString) + gen as = if BS.length as == 0 + then Nothing + else Just ( BS.foldr (\b m -> (interestingWord8s ! b) .|. (m .<. 1)) 0 (padRight 0 8 (BS.take 8 as)) + , BS.drop 8 as + ) + +blankedJsonToBalancedParens :: Monad m => Conduit BS.ByteString m Bool +blankedJsonToBalancedParens = do + mbs <- await + case mbs of + Just bs -> blankedJsonToBalancedParens' bs + Nothing -> return () + +blankedJsonToBalancedParens' :: Monad m => BS.ByteString -> Conduit BS.ByteString m Bool +blankedJsonToBalancedParens' bs = case BS.uncons bs of + Just (c, cs) -> do + case c of + d | d == wOpenBrace -> yield True + d | d == wCloseBrace -> yield False + d | d == wOpenBracket -> yield True + d | d == wCloseBracket -> yield False + d | d == wOpenParen -> yield True + d | d == wCloseParen -> yield False + d | d == wt -> yield True >> yield False + d | d == wf -> yield True >> yield False + d | d == w1 -> yield True >> yield False + d | d == wn -> yield True >> yield False + _ -> return () + blankedJsonToBalancedParens' cs + Nothing -> return () + +compressWordAsBit :: Monad m => Conduit BS.ByteString m BS.ByteString +compressWordAsBit = do + mbs <- await + case mbs of + Just bs -> do + let (cs, _) = BS.unfoldrN (BS.length bs + 7 `div` 8) gen bs + yield cs + Nothing -> return () + where gen :: ByteString -> Maybe (Word8, ByteString) + gen xs = if BS.length xs == 0 + then Nothing + else Just ( BS.foldr (\b m -> ((b .&. 1) .|. (m .<. 1))) 0 (padRight 0 8 (BS.take 8 xs)) + , BS.drop 8 xs + ) + +blankedJsonToBalancedParens2 :: Monad m => Conduit BS.ByteString m BS.ByteString +blankedJsonToBalancedParens2 = do + mbs <- await + case mbs of + Just bs -> do + let (cs, _) = BS.unfoldrN (BS.length bs * 2) gen (Nothing, bs) + yield cs + Nothing -> return () + where gen :: (Maybe Bool, ByteString) -> Maybe (Word8, (Maybe Bool, ByteString)) + gen (Just True , bs) = Just (wFF, (Nothing, bs)) + gen (Just False , bs) = Just (w00, (Nothing, bs)) + gen (Nothing , bs) = case BS.uncons bs of + Just (c, cs) -> case balancedParensOf c of + MiniN -> gen (Nothing , cs) + MiniT -> Just (wFF, (Nothing , cs)) + MiniF -> Just (w00, (Nothing , cs)) + MiniTF -> Just (wFF, (Just False , cs)) + Nothing -> Nothing + +data MiniBP = MiniN | MiniT | MiniF | MiniTF + +balancedParensOf :: Word8 -> MiniBP +balancedParensOf c = case c of + d | d == wOpenBrace -> MiniT + d | d == wCloseBrace -> MiniF + d | d == wOpenBracket -> MiniT + d | d == wCloseBracket -> MiniF + d | d == wOpenParen -> MiniT + d | d == wCloseParen -> MiniF + d | d == wt -> MiniTF + d | d == wf -> MiniTF + d | d == w1 -> MiniTF + d | d == wn -> MiniTF + _ -> MiniN + +yieldBitsOfWord8 :: Monad m => Word8 -> Conduit BS.ByteString m Bool +yieldBitsOfWord8 w = do + yield ((w .&. BITS.bit 0) /= 0) + yield ((w .&. BITS.bit 1) /= 0) + yield ((w .&. BITS.bit 2) /= 0) + yield ((w .&. BITS.bit 3) /= 0) + yield ((w .&. BITS.bit 4) /= 0) + yield ((w .&. BITS.bit 5) /= 0) + yield ((w .&. BITS.bit 6) /= 0) + yield ((w .&. BITS.bit 7) /= 0) + +yieldBitsofWord8s :: Monad m => [Word8] -> Conduit BS.ByteString m Bool +yieldBitsofWord8s = P.foldr ((>>) . yieldBitsOfWord8) (return ()) + +byteStringToBits :: Monad m => Conduit BS.ByteString m Bool +byteStringToBits = do + mbs <- await + case mbs of + Just bs -> yieldBitsofWord8s (BS.unpack bs) >> byteStringToBits + Nothing -> return () diff --git a/src/HaskellWorks/Data/Conduit/Json/Blank.hs b/src/HaskellWorks/Data/Conduit/Json/Blank.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Conduit/Json/Blank.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module HaskellWorks.Data.Conduit.Json.Blank + ( blankJson + ) where + +import Control.Monad +import Control.Monad.Trans.Resource (MonadThrow) +import Data.ByteString as BS +import Data.Conduit +import Data.Word +import HaskellWorks.Data.Conduit.Json.Words +import Prelude as P + +data BlankState + = Escaped + | InJson + | InString + | InNumber + | InIdent + +blankJson :: MonadThrow m => Conduit BS.ByteString m BS.ByteString +blankJson = blankJson' InJson + +blankJson' :: MonadThrow m => BlankState -> Conduit BS.ByteString m BS.ByteString +blankJson' lastState = do + mbs <- await + case mbs of + Just bs -> do + let (!cs, Just (!nextState, _)) = unfoldrN (BS.length bs) blankByteString (lastState, bs) + yield cs + blankJson' nextState + Nothing -> return () + where + blankByteString :: (BlankState, ByteString) -> Maybe (Word8, (BlankState, ByteString)) + blankByteString (InJson, bs) = case BS.uncons bs of + Just (!c, !cs) | isLeadingDigit c -> Just (w1 , (InNumber , cs)) + Just (!c, !cs) | c == wDoubleQuote -> Just (wOpenParen , (InString , cs)) + Just (!c, !cs) | isAlphabetic c -> Just (c , (InIdent , cs)) + Just (!c, !cs) -> Just (c , (InJson , cs)) + Nothing -> Nothing + blankByteString (InString, bs) = case BS.uncons bs of + Just (!c, !cs) | c == wBackslash -> Just (wSpace , (Escaped , cs)) + Just (!c, !cs) | c == wDoubleQuote -> Just (wCloseParen, (InJson , cs)) + Just (_ , !cs) -> Just (wSpace , (InString , cs)) + Nothing -> Nothing + blankByteString (Escaped, bs) = case BS.uncons bs of + Just (_, !cs) -> Just (wSpace, (InString, cs)) + Nothing -> Nothing + blankByteString (InNumber, bs) = case BS.uncons bs of + Just (!c, !cs) | isTrailingDigit c -> Just (w0 , (InNumber , cs)) + Just (!c, !cs) | c == wDoubleQuote -> Just (wOpenParen , (InString , cs)) + Just (!c, !cs) | isAlphabetic c -> Just (c , (InIdent , cs)) + Just (!c, !cs) -> Just (c , (InJson , cs)) + Nothing -> Nothing + blankByteString (InIdent, bs) = case BS.uncons bs of + Just (!c, !cs) | isAlphabetic c -> Just (wUnderscore, (InIdent , cs)) + Just (!c, !cs) | isLeadingDigit c -> Just (w1 , (InNumber , cs)) + Just (!c, !cs) | c == wDoubleQuote -> Just (wOpenParen , (InString , cs)) + Just (!c, !cs) -> Just (c , (InJson , cs)) + Nothing -> Nothing diff --git a/src/HaskellWorks/Data/Conduit/Json/Words.hs b/src/HaskellWorks/Data/Conduit/Json/Words.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Conduit/Json/Words.hs @@ -0,0 +1,94 @@ +module HaskellWorks.Data.Conduit.Json.Words where + +import Data.Char +import Data.Word + +wBackslash :: Word8 +wBackslash = fromIntegral (ord '\\') + +wDoubleQuote :: Word8 +wDoubleQuote = fromIntegral (ord '"') + +wUnderscore :: Word8 +wUnderscore = fromIntegral (ord '_') + +wSpace :: Word8 +wSpace = fromIntegral (ord ' ') + +wOpenParen :: Word8 +wOpenParen = fromIntegral (ord '(') + +wCloseParen :: Word8 +wCloseParen = fromIntegral (ord ')') + +wOpenBracket :: Word8 +wOpenBracket = fromIntegral (ord '[') + +wCloseBracket :: Word8 +wCloseBracket = fromIntegral (ord ']') + +wOpenBrace :: Word8 +wOpenBrace = fromIntegral (ord '{') + +wCloseBrace :: Word8 +wCloseBrace = fromIntegral (ord '}') + +wPlus :: Word8 +wPlus = fromIntegral (ord '+') + +wA :: Word8 +wA = fromIntegral (ord 'A') + +wa :: Word8 +wa = fromIntegral (ord 'a') + +we :: Word8 +we = fromIntegral (ord 'e') + +wE :: Word8 +wE = fromIntegral (ord 'E') + +wf :: Word8 +wf = fromIntegral (ord 'f') + +wn :: Word8 +wn = fromIntegral (ord 'n') + +wt :: Word8 +wt = fromIntegral (ord 't') + +wz :: Word8 +wz = fromIntegral (ord 'z') + +wZ :: Word8 +wZ = fromIntegral (ord 'Z') + +wDot :: Word8 +wDot = fromIntegral (ord '.') + +wMinus :: Word8 +wMinus = fromIntegral (ord '-') + +w0 :: Word8 +w0 = fromIntegral (ord '0') + +w1 :: Word8 +w1 = fromIntegral (ord '1') + +w9 :: Word8 +w9 = fromIntegral (ord '9') + +w00 :: Word8 +w00 = fromIntegral (ord '0') + +wFF :: Word8 +wFF = fromIntegral (ord '\255') + +isLeadingDigit :: Word8 -> Bool +isLeadingDigit w = w == wMinus || (w >= w0 && w <= w9) + +isTrailingDigit :: Word8 -> Bool +isTrailingDigit w = w == wPlus || w == wMinus || (w >= w0 && w <= w9) || w == wDot || w == wE || w == we + +isAlphabetic :: Word8 -> Bool +isAlphabetic w = (w >= wA && w <= wZ) || (w >= wa && w <= wz) diff --git a/src/HaskellWorks/Data/Conduit/List.hs b/src/HaskellWorks/Data/Conduit/List.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Conduit/List.hs @@ -0,0 +1,11 @@ + +module HaskellWorks.Data.Conduit.List + ( runListConduit + ) where + +import Data.Conduit +import Data.Conduit.List as CL +import Prelude as P + +runListConduit :: Conduit i [] o -> [i] -> [o] +runListConduit c is = P.concat $ sourceList is =$ c $$ consume diff --git a/test/HaskellWorks/Data/Conduit/ByteStringSpec.hs b/test/HaskellWorks/Data/Conduit/ByteStringSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Conduit/ByteStringSpec.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HaskellWorks.Data.Conduit.ByteStringSpec (spec) where + +import HaskellWorks.Data.Conduit.ByteString +import HaskellWorks.Data.Conduit.List +import Test.Hspec + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +spec :: Spec +spec = describe "HaskellWorks.Data.Conduit.ByteStringSpec" $ do + it "Can rechunk bytestrings" $ do + runListConduit (rechunk 1) [] `shouldBe` [] + runListConduit (rechunk 1) ["0", "1", "2", "3", "4", "5"] `shouldBe` ["0", "1", "2", "3", "4", "5"] + runListConduit (rechunk 2) ["0", "1", "2", "3", "4", "5"] `shouldBe` ["01", "23", "45"] + runListConduit (rechunk 3) ["0", "1", "2", "3", "4", "5"] `shouldBe` ["012", "345"] + runListConduit (rechunk 4) ["0", "1", "2", "3", "4", "5"] `shouldBe` ["0123", "45"] + runListConduit (rechunk 5) ["0", "1", "2", "3", "4", "5"] `shouldBe` ["01234", "5"] + runListConduit (rechunk 6) ["0", "1", "2", "3", "4", "5"] `shouldBe` ["012345"] + runListConduit (rechunk 7) ["0", "1", "2", "3", "4", "5"] `shouldBe` ["012345"] + runListConduit (rechunk 1) ["01", "23", "", "45", "67"] `shouldBe` ["0", "1", "2", "3", "4", "5", "6", "7"] + runListConduit (rechunk 2) ["01", "23", "", "45", "67"] `shouldBe` ["01", "23", "45", "67"] + runListConduit (rechunk 3) ["01", "23", "", "45", "67"] `shouldBe` ["012", "345", "67"] + runListConduit (rechunk 4) ["01", "23", "", "45", "67"] `shouldBe` ["0123", "4567"] + runListConduit (rechunk 5) ["01", "23", "", "45", "67"] `shouldBe` ["01234", "567"] + runListConduit (rechunk 6) ["01", "23", "", "45", "67"] `shouldBe` ["012345", "67"] + runListConduit (rechunk 7) ["01", "23", "", "45", "67"] `shouldBe` ["0123456", "7"] + runListConduit (rechunk 8) ["01", "23", "", "45", "67"] `shouldBe` ["01234567"] + runListConduit (rechunk 9) ["01", "23", "", "45", "67"] `shouldBe` ["01234567"] diff --git a/test/HaskellWorks/Data/Conduit/Json/BlankSpec.hs b/test/HaskellWorks/Data/Conduit/Json/BlankSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/Data/Conduit/Json/BlankSpec.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HaskellWorks.Data.Conduit.Json.BlankSpec (spec) where + +import qualified Data.ByteString as BS +import HaskellWorks.Data.Conduit.Json.Blank +import HaskellWorks.Data.Conduit.List +import Test.Hspec + +{-# ANN module ("HLint: ignore Redundant do" :: String) #-} + +whenBlankedJsonShouldBe :: BS.ByteString -> BS.ByteString -> Spec +whenBlankedJsonShouldBe original expected = do + it (show original ++ " when blanked json should be " ++ show expected) $ do + BS.concat (runListConduit blankJson [original]) `shouldBe` expected + +spec :: Spec +spec = describe "HaskellWorks.Data.Conduit.Json.BlankSpec" $ do + describe "Can blank json" $ do + "\"\"" `whenBlankedJsonShouldBe` "()" + "\"\\\\\"" `whenBlankedJsonShouldBe` "( )" + "\"\\\\\\\"" `whenBlankedJsonShouldBe` "( " + "\" \\\\\\\"" `whenBlankedJsonShouldBe` "( " + "\" \\n\\\\\"" `whenBlankedJsonShouldBe` "( )" + "" `whenBlankedJsonShouldBe` "" + "\"\"" `whenBlankedJsonShouldBe` "()" + "\" \"" `whenBlankedJsonShouldBe` "( )" + "\" a \"" `whenBlankedJsonShouldBe` "( )" + " \"a \" x" `whenBlankedJsonShouldBe` " ( ) x" + " \"a\"b\"c\"d" `whenBlankedJsonShouldBe` " ( )b( )d" + "" `whenBlankedJsonShouldBe` "" + "1" `whenBlankedJsonShouldBe` "1" + "11" `whenBlankedJsonShouldBe` "10" + "00" `whenBlankedJsonShouldBe` "10" + "00" `whenBlankedJsonShouldBe` "10" + "-0.12e+34" `whenBlankedJsonShouldBe` "100000000" + "10.12E-34 " `whenBlankedJsonShouldBe` "100000000 " + "10.12E-34 12" `whenBlankedJsonShouldBe` "100000000 10" + " 10.12E-34 -1" `whenBlankedJsonShouldBe` " 100000000 10" + "" `whenBlankedJsonShouldBe` "" + "a" `whenBlankedJsonShouldBe` "a" + "z" `whenBlankedJsonShouldBe` "z" + " Aaa " `whenBlankedJsonShouldBe` " A__ " + " Za def " `whenBlankedJsonShouldBe` " Z_ d__ " + "" `whenBlankedJsonShouldBe` "" + " { \"ff\": 1.0, [\"\", true], null}" `whenBlankedJsonShouldBe` " { ( ): 100, [(), t___], n___}" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/data/sample.json b/test/data/sample.json new file mode 100644 --- /dev/null +++ b/test/data/sample.json @@ -0,0 +1,28 @@ +{ + "widget": { + "debug": "on", + "window": { + "title": "Sample Konfabulator Widget", + "name": "main_window", + "width": 500, + "height": 500 + }, + "image": { + "src": "Images/Sun.png", + "name": "sun1", + "hOffset": 250, + "vOffset": 250, + "alignment": "center" + }, + "text": { + "data": "Click Here", + "size": 36, + "style": "bold", + "name": "text1", + "hOffset": 250, + "vOffset": 100, + "alignment": "center", + "onMouseUp": "sun1.opacity = (sun1.opacity / 100) * 90;" + } + } +}