binary 0.3 → 0.4
raw patch · 10 files changed
+303/−58 lines, 10 filesdep +arraydep +bytestringdep +containersdep ~base
Dependencies added: array, bytestring, containers
Dependency ranges changed: base
Files
- binary.cabal +10/−6
- src/Data/Binary.hs +20/−4
- src/Data/Binary/Builder.hs +5/−4
- src/Data/Binary/Get.hs +65/−21
- src/Data/Binary/Put.hs +1/−1
- tests/Benchmark.hs +3/−4
- tests/Makefile +6/−6
- tests/Parallel.hs +147/−0
- tests/QC.hs +38/−9
- tests/QuickCheckUtils.hs +8/−3
binary.cabal view
@@ -1,22 +1,26 @@ name: binary-version: 0.3+version: 0.4 license: BSD3 license-file: LICENSE author: Lennart Kolmodin <kolmodin@dtek.chalmers.se>-maintainer: Lennart Kolmodin+maintainer: Lennart Kolmodin, Don Stewart <dons@galois.com> homepage: http://www.cse.unsw.edu.au/~dons/binary.html description: Efficient, pure binary serialisation using lazy ByteStrings. Haskell values may be encoded to and form binary formats, - written to disk as binary, or set over the network.+ written to disk as binary, or sent over the network.+ Serialisation speeds of over 1 G\/sec have been observed,+ so this library should be suitable for high performance+ scenarios. synopsis: Binary serialization for Haskell values using lazy ByteStrings category: Data, Parsing-build-depends: base+build-depends: base, containers, array, bytestring>=0.9+stability: provisional -- ghc 6.4 also needs package fps exposed-modules: Data.Binary, Data.Binary.Put, Data.Binary.Get, Data.Binary.Builder-extensions: CPP,FlexibleInstances+extensions: CPP,FlexibleContexts hs-source-dirs: src-ghc-options: -O2 -Wall -Werror -fliberate-case-threshold=1000+ghc-options: -O2 -Wall -fliberate-case-threshold=1000 extra-source-files: README
src/Data/Binary.hs view
@@ -360,6 +360,7 @@ instance Binary Integer where + {-# INLINE put #-} put n | n >= lo && n <= hi = do putWord8 0 put (fromIntegral n :: SmallInt) -- fast path@@ -374,6 +375,7 @@ where sign = fromIntegral (signum n) :: Word8 + {-# INLINE get #-} get = do tag <- get :: Get Word8 case tag of@@ -666,12 +668,26 @@ -- Arrays instance (Binary i, Ix i, Binary e) => Binary (Array i e) where- put a = put (bounds a) >> put (elems a)- get = liftM2 listArray get get+ put a = do+ put (bounds a)+ put (rangeSize $ bounds a) -- write the length+ mapM_ put (elems a) -- now the elems.+ get = do+ bs <- get+ n <- get -- read the length+ xs <- replicateM n get -- now the elems.+ return (listArray bs xs) -- -- The IArray UArray e constraint is non portable. Requires flexible instances -- instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where- put a = put (bounds a) >> put (elems a)- get = liftM2 listArray get get+ put a = do+ put (bounds a)+ put (rangeSize $ bounds a) -- now write the length+ mapM_ put (elems a)+ get = do+ bs <- get+ n <- get+ xs <- replicateM n get+ return (listArray bs xs)
src/Data/Binary/Builder.hs view
@@ -58,10 +58,11 @@ import Foreign import Data.Monoid import Data.Word-import Data.ByteString.Base (inlinePerformIO)+import Data.ByteString.Internal (inlinePerformIO) import qualified Data.ByteString as S-import qualified Data.ByteString.Base as S+import qualified Data.ByteString.Internal as S import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Internal as L #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) import GHC.Base@@ -131,7 +132,7 @@ -- * @'toLazyByteString' ('fromLazyByteString' bs) = bs@ -- fromLazyByteString :: L.ByteString -> Builder-fromLazyByteString (S.LPS bss) = flush `append` mapBuilder (bss ++)+fromLazyByteString bss = flush `append` mapBuilder (L.toChunks bss ++) ------------------------------------------------------------------------ @@ -148,7 +149,7 @@ -- the lazy 'L.ByteString' is demanded. -- toLazyByteString :: Builder -> L.ByteString-toLazyByteString m = S.LPS $ inlinePerformIO $ do+toLazyByteString m = L.fromChunks $ unsafePerformIO $ do buf <- newBuffer defaultSize return (runBuilder (m `append` flush) (const []) buf)
src/Data/Binary/Get.hs view
@@ -48,6 +48,7 @@ -- ** ByteStrings , getByteString , getLazyByteString+ , getLazyByteStringNul , getRemainingLazyByteString -- ** Big-endian reads@@ -68,12 +69,14 @@ ) where -import Control.Monad (when)+import Control.Monad (when,liftM)+import Control.Monad.Fix import Data.Maybe (isNothing) import qualified Data.ByteString as B-import qualified Data.ByteString.Base as B+import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Internal as L import Foreign @@ -105,6 +108,10 @@ in unGet (k a) s') fail = failDesc +instance MonadFix Get where+ mfix f = Get (\s -> let (a,s') = unGet (f a) s + in (a,s'))+ ------------------------------------------------------------------------ get :: Get S@@ -116,18 +123,28 @@ ------------------------------------------------------------------------ initState :: L.ByteString -> S+initState xs = mkState xs 0+{-# INLINE initState #-}++{- initState (B.LPS xs) = case xs of- [] -> S B.empty L.empty 0+ [] -> S B.empty L.empty 0 (x:xs') -> S x (B.LPS xs') 0-{-# INLINE initState #-}+-} mkState :: L.ByteString -> Int64 -> S+mkState l = case l of+ L.Empty -> S B.empty L.empty+ L.Chunk x xs -> S x xs+{-# INLINE mkState #-}++{- mkState (B.LPS xs) = case xs of [] -> S B.empty L.empty (x:xs') -> S x (B.LPS xs')-{-# INLINE mkState #-}+-} -- | Run the Get monad applies a 'get'-based parser on the input ByteString runGet :: Get a -> L.ByteString -> a@@ -139,7 +156,7 @@ runGetState :: Get a -> L.ByteString -> Int64 -> (a, L.ByteString, Int64) runGetState m str off = case unGet m (mkState str off) of- (a, S s ss newOff) -> (a, s `join` ss, newOff)+ (a, ~(S s ss newOff)) -> (a, s `join` ss, newOff) ------------------------------------------------------------------------ @@ -244,6 +261,21 @@ return consume {-# INLINE getLazyByteString #-} +-- | Get a lazy ByteString that is terminated with a NUL byte. Fails+-- if it reaches the end of input without hitting a NUL.+getLazyByteStringNul :: Get L.ByteString+getLazyByteStringNul = do+ S s ss bytes <- get+ let big = s `join` ss+ (consume, t) = L.break (== 0) big+ (h, rest) = L.splitAt 1 t+ if L.null h+ then fail "too few bytes"+ else do+ put $ mkState rest (bytes + L.length consume + 1)+ return consume+{-# INLINE getLazyByteStringNul #-}+ -- | Get the remaining bytes as a lazy ByteString getRemainingLazyByteString :: Get L.ByteString getRemainingLazyByteString = do@@ -267,16 +299,24 @@ do let now = B.concat . L.toChunks $ consuming put $! mkState rest (bytes + fromIntegral n) -- forces the next chunk before this one is returned- when (B.length now < n) $- fail "too few bytes"- return now+ if (B.length now < n)+ then+ fail "too few bytes"+ else+ return now {-# INLINE getBytes #-} -- ^ important join :: B.ByteString -> L.ByteString -> L.ByteString+join bb lb+ | B.null bb = lb+ | otherwise = L.Chunk bb lb++{- join bb (B.LPS lb) | B.null bb = B.LPS lb | otherwise = B.LPS (bb:lb)+-} -- don't use L.append, it's strict in it's second argument :/ {-# INLINE join #-} @@ -289,20 +329,24 @@ -- > (ys,zs) -> consume ys ... consume zs -- splitAtST :: Int64 -> L.ByteString -> (L.ByteString, L.ByteString)-splitAtST i p | i <= 0 = (L.empty, p)-splitAtST i (B.LPS ps) = runST (- do r <- newSTRef undefined+splitAtST i ps | i <= 0 = (L.empty, ps)+splitAtST i ps = runST (+ do r <- newSTRef undefined xs <- first r i ps ys <- unsafeInterleaveST (readSTRef r)- return (B.LPS xs, B.LPS ys))- where first r 0 xs = writeSTRef r xs >> return []- first r _ [] = writeSTRef r [] >> return []- first r n (x:xs)- | n < l = do writeSTRef r (B.drop (fromIntegral n) x : xs)- return [B.take (fromIntegral n) x]- | otherwise = do writeSTRef r (L.toChunks (L.drop (n - l) (B.LPS xs)))- fmap (x:) $ unsafeInterleaveST (first r (n - l) xs)- where l = fromIntegral (B.length x) + return (xs, ys))++ where+ first r 0 xs@(L.Chunk _ _) = writeSTRef r xs >> return L.Empty+ first r _ L.Empty = writeSTRef r L.Empty >> return L.Empty++ first r n (L.Chunk x xs)+ | n < l = do writeSTRef r (L.Chunk (B.drop (fromIntegral n) x) xs)+ return $ L.Chunk (B.take (fromIntegral n) x) L.Empty+ | otherwise = do writeSTRef r (L.drop (n - l) xs)+ liftM (L.Chunk x) $ unsafeInterleaveST (first r (n - l) xs)++ where l = fromIntegral (B.length x) {-# INLINE splitAtST #-} -- Pull n bytes from the input, and apply a parser to those bytes,
src/Data/Binary/Put.hs view
@@ -49,7 +49,7 @@ import qualified Data.Binary.Builder as B import Data.Word-import qualified Data.ByteString.Base as S+import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L ------------------------------------------------------------------------
tests/Benchmark.hs view
@@ -10,6 +10,7 @@ import System.CPUTime import Numeric import Text.Printf+import System.Environment import MemBench @@ -19,12 +20,10 @@ | Host deriving (Eq,Ord,Show) -mb :: Int-mb = 10- main :: IO () main = do- memBench (mb*10)+ mb <- getArgs >>= readIO . head+ memBench (mb*10) putStrLn "" putStrLn "Binary (de)serialisation benchmarks:"
tests/Makefile view
@@ -4,16 +4,16 @@ runhaskell QC.hs 1000 compiled:- ghc --make -O QC.hs -o qc -no-recomp- time ./qc 1000+ ghc --make -O QC.hs -o qc -no-recomp -threaded+ time ./qc 500 +RTS -qw -N2 bench:: Benchmark.hs MemBench.hs CBenchmark.o- ghc --make -O Benchmark.hs -fasm CBenchmark.o -o bench -no-recomp- time ./bench+ ghc --make -O2 -fliberate-case-threshold=1000 Benchmark.hs -fasm CBenchmark.o -o bench -no-recomp+ time ./bench 100 bench-nb::- ghc --make -O NewBenchmark.hs -fasm -o bench-nb- time ./bench-nb+ ghc --make -O2 -fliberate-case-threshold=1000 NewBenchmark.hs -fasm -o bench-nb+ time ./bench-nb CBenchmark.o: CBenchmark.c gcc -O -c $< -o $@
+ tests/Parallel.hs view
@@ -0,0 +1,147 @@+-----------------------------------------------------------------------------+-- |+-- Module : Test.QuickCheck.Parallel+-- Copyright : (c) Don Stewart 2006+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : dons@cse.unsw.edu.au+-- Stability : experimental+-- Portability : non-portable (uses Control.Exception, Control.Concurrent)+--+-- A parallel batch driver for running QuickCheck on threaded or SMP systems.+-- See the /Example.hs/ file for a complete overview.+--++module Parallel (+ pRun,+ pDet,+ pNon+ ) where++import Test.QuickCheck+import Data.List+import Control.Concurrent+import Control.Exception hiding (evaluate)+import System.Random+import System.IO (hFlush,stdout)+import Text.Printf++type Name = String+type Depth = Int+type Test = (Name, Depth -> IO String)++-- | Run a list of QuickCheck properties in parallel chunks, using+-- 'n' Haskell threads (first argument), and test to a depth of 'd'+-- (second argument). Compile your application with '-threaded' and run+-- with the SMP runtime's '-N4' (or however many OS threads you want to+-- donate), for best results.+--+-- > import Test.QuickCheck.Parallel+-- >+-- > do n <- getArgs >>= readIO . head+-- > pRun n 1000 [ ("sort1", pDet prop_sort1) ]+--+-- Will run 'n' threads over the property list, to depth 1000.+--+pRun :: Int -> Int -> [Test] -> IO ()+pRun n depth tests = do+ chan <- newChan+ ps <- getChanContents chan+ work <- newMVar tests++ forM_ [1..n] $ forkIO . thread work chan++ let wait xs i+ | i >= n = return () -- done+ | otherwise = case xs of+ Nothing : xs -> wait xs $! i+1+ Just s : xs -> putStr s >> hFlush stdout >> wait xs i+ wait ps 0++ where+ thread :: MVar [Test] -> Chan (Maybe String) -> Int -> IO ()+ thread work chan me = loop+ where+ loop = do+ job <- modifyMVar work $ \jobs -> return $ case jobs of+ [] -> ([], Nothing)+ (j:js) -> (js, Just j)+ case job of+ Nothing -> writeChan chan Nothing -- done+ Just (name,prop) -> do+ v <- prop depth+ writeChan chan . Just $ printf "%d: %-25s: %s" me name v+ loop+++-- | Wrap a property, and run it on a deterministic set of data+pDet :: Testable a => a -> Int -> IO String+pDet a n = mycheck Det defaultConfig+ { configMaxTest = n+ , configEvery = \n args -> unlines args } a++-- | Wrap a property, and run it on a non-deterministic set of data+pNon :: Testable a => a -> Int -> IO String+pNon a n = mycheck NonDet defaultConfig+ { configMaxTest = n+ , configEvery = \n args -> unlines args } a++data Mode = Det | NonDet++------------------------------------------------------------------------++mycheck :: Testable a => Mode -> Config -> a -> IO String+mycheck Det config a = do+ let rnd = mkStdGen 99 -- deterministic+ mytests config (evaluate a) rnd 0 0 []++mycheck NonDet config a = do+ rnd <- newStdGen -- different each run+ mytests config (evaluate a) rnd 0 0 []++mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO String+mytests config gen rnd0 ntest nfail stamps+ | ntest == configMaxTest config = do done "OK," ntest stamps+ | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps+ | otherwise = do+ case ok result of+ Nothing ->+ mytests config gen rnd1 ntest (nfail+1) stamps+ Just True ->+ mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps)+ Just False ->+ return ( "Falsifiable after "+ ++ show ntest+ ++ " tests:\n"+ ++ unlines (arguments result)+ )+ where+ result = generate (configSize config ntest) rnd2 gen+ (rnd1,rnd2) = split rnd0++done :: String -> Int -> [[String]] -> IO String+done mesg ntest stamps =+ return ( mesg ++ " " ++ show ntest ++ " tests" ++ table )+ where+ table = display+ . map entry+ . reverse+ . sort+ . map pairLength+ . group+ . sort+ . filter (not . null)+ $ stamps++ display [] = ".\n"+ display [x] = " (" ++ x ++ ").\n"+ display xs = ".\n" ++ unlines (map (++ ".") xs)++ pairLength xss@(xs:_) = (length xss, xs)+ entry (n, xs) = percentage n ntest+ ++ " "+ ++ concat (intersperse ", " xs)++ percentage n m = show ((100 * n) `div` m) ++ "%"++forM_ = flip mapM_
tests/QC.hs view
@@ -5,9 +5,13 @@ import Data.Binary.Put import Data.Binary.Get +import Parallel+ import qualified Data.ByteString as B-import qualified Data.ByteString.Base as B+import qualified Data.ByteString.Internal as B+import qualified Data.ByteString.Unsafe as B import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Internal as L import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.IntMap as IntMap@@ -17,10 +21,12 @@ import Data.Array.IArray import Data.Array.Unboxed (UArray) +import qualified Control.Exception as C (catch,evaluate) import Control.Monad import Foreign import System.Environment import System.IO+import System.IO.Unsafe import Test.QuickCheck hiding (test) import QuickCheckUtils@@ -38,6 +44,13 @@ forAll positiveList $ \xs -> x == runGet get (refragment xs (runPut (put x))) +-- make sure that a test fails+errorish :: B a+errorish a = unsafePerformIO $+ C.catch (do C.evaluate a+ return False)+ (\_ -> return True)+ -- low level ones: prop_Word16be = roundTripWith putWord16be getWord16be@@ -54,9 +67,17 @@ prop_Wordhost = roundTripWith putWordhost getWordhost +-- read too much:++prop_bookworm x = errorish $ x == a && x /= b+ where+ (a,b) = decode (encode x)++-- sanity:+ invariant_lbs :: L.ByteString -> Bool-invariant_lbs (B.LPS []) = True-invariant_lbs (B.LPS xs) = all (not . B.null) xs+invariant_lbs (L.Empty) = True+invariant_lbs (L.Chunk x xs) = not (B.null x) && invariant_lbs xs prop_invariant :: (Binary a) => a -> Bool prop_invariant = invariant_lbs . encode@@ -87,21 +108,25 @@ main :: IO () main = do hSetBuffering stdout NoBuffering- run tests+ s <- getArgs+ let x = if null s then 100 else read (head s)+ pRun 2 x tests +{- run :: [(String, Int -> IO ())] -> IO () run tests = do x <- getArgs let n = if null x then 100 else read . head $ x mapM_ (\(s,a) -> printf "%-50s" s >> a n) tests+-} ------------------------------------------------------------------------ type T a = a -> Property type B a = a -> Bool -p :: Testable a => a -> Int -> IO ()-p = mytest+p :: Testable a => a -> Int -> IO String+p = pNon test :: (Eq a, Binary a) => a -> Property test a = forAll positiveList (roundTrip a . refragment)@@ -109,21 +134,25 @@ positiveList :: Gen [Int] positiveList = fmap (filter (/=0) . map abs) $ arbitrary +-- tests :: [(String, Int -> IO String)] tests = -- utils [ ("refragment id", p prop_refragment ) , ("refragment invariant", p prop_refragment_inv ) +-- boundaries+ , ("read to much", p (prop_bookworm :: B Word8 ))+ -- Primitives , ("Word16be", p prop_Word16be) , ("Word16le", p prop_Word16le)- , ("Word16host", p prop_Word16host)+ , ("Word16host", p prop_Word16host) , ("Word32be", p prop_Word32be) , ("Word32le", p prop_Word32le)- , ("Word32host", p prop_Word32host)+ , ("Word32host", p prop_Word32host) , ("Word64be", p prop_Word64be) , ("Word64le", p prop_Word64le)- , ("Word64host", p prop_Word64host)+ , ("Word64host", p prop_Word64host) , ("Wordhost", p prop_Wordhost) -- higher level ones using the Binary class
tests/QuickCheckUtils.hs view
@@ -11,7 +11,8 @@ import Text.Show.Functions import qualified Data.ByteString as B-import qualified Data.ByteString.Base as B+import qualified Data.ByteString.Unsafe as B+import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Lazy as L import qualified Data.Map as Map import qualified Data.Set as Set@@ -35,7 +36,7 @@ import qualified Data.ByteString as P import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Base as L (LazyByteString(..))+import qualified Data.ByteString.Lazy.Internal as L -- import qualified Data.Sequence as Seq @@ -210,17 +211,21 @@ arbitrary = choose (maxBound, minBound) coarbitrary = undefined +{- instance Arbitrary a => Arbitrary (Maybe a) where arbitrary = oneof [ return Nothing, liftM Just arbitrary] coarbitrary = undefined+ -} instance Arbitrary Ordering where arbitrary = oneof [ return LT,return GT,return EQ ] coarbitrary = undefined +{- instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where arbitrary = oneof [ liftM Left arbitrary, liftM Right arbitrary] coarbitrary = undefined+ -} instance Arbitrary IntSet.IntSet where arbitrary = fmap IntSet.fromList arbitrary@@ -245,7 +250,7 @@ -} instance Arbitrary L.ByteString where- arbitrary = arbitrary >>= return . B.LPS . filter (not. B.null) -- maintain the invariant.+ arbitrary = arbitrary >>= return . L.fromChunks . filter (not. B.null) -- maintain the invariant. coarbitrary s = coarbitrary (L.unpack s) instance Arbitrary B.ByteString where