cereal-0.3.5.2/0000755000000000000000000000000011763507414011310 5ustar0000000000000000cereal-0.3.5.2/cereal.cabal0000644000000000000000000000435211763507414013533 0ustar0000000000000000name: cereal version: 0.3.5.2 license: BSD3 license-file: LICENSE author: Lennart Kolmodin , Galois Inc., Lemmih , Bas van Dijk maintainer: Trevor Elliott category: Data, Parsing stability: provisional build-type: Simple cabal-version: >= 1.6 synopsis: A binary serialization library extra-source-files: tests/Benchmark.hs, tests/CBenchmark.c, tests/CBenchmark.h, tests/Makefile, tests/MemBench.hs, tests/Tests.hs description: A binary serialization library, similar to binary, that introduces an isolate primitive for parser isolation, and replaces the asynchronous errors with a user-handleable Either type. Similar to binary in performance, but uses a strict ByteString instead of a lazy ByteString, thus restricting it to operating on finite inputs. source-repository head type: git location: git://github.com/GaloisInc/cereal.git flag split-base default: True library build-depends: bytestring if flag(split-base) build-depends: base == 4.*, containers, array else build-depends: base < 3.0 if impl(ghc >= 7.2.1) cpp-options: -DGENERICS build-depends: ghc-prim >= 0.2 hs-source-dirs: src exposed-modules: Data.Serialize, Data.Serialize.Put, Data.Serialize.Get, Data.Serialize.Builder, Data.Serialize.IEEE754 extensions: CPP, FlexibleContexts, FlexibleInstances, Rank2Types, MagicHash ghc-options: -Wall -funbox-strict-fields ghc-prof-options: -prof -auto-all cereal-0.3.5.2/Setup.lhs0000644000000000000000000000011411763507414013114 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain cereal-0.3.5.2/LICENSE0000644000000000000000000000270111763507414012315 0ustar0000000000000000Copyright (c) Lennart Kolmodin, Galois, Inc. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. 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. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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. cereal-0.3.5.2/tests/0000755000000000000000000000000011763507414012452 5ustar0000000000000000cereal-0.3.5.2/tests/MemBench.hs0000644000000000000000000000557011763507414014473 0ustar0000000000000000{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-} module MemBench (memBench) where import Foreign import Foreign.C import Control.Exception import System.CPUTime import Numeric memBench :: Int -> IO () memBench mb = do let bytes = mb * 2^20 allocaBytes bytes $ \ptr -> do let bench label test = do seconds <- time $ test (castPtr ptr) (fromIntegral bytes) let throughput = fromIntegral mb / seconds putStrLn $ show mb ++ "MB of " ++ label ++ " in " ++ showFFloat (Just 3) seconds "s, at: " ++ showFFloat (Just 1) throughput "MB/s" bench "setup " c_wordwrite putStrLn "" putStrLn "C memory throughput benchmarks:" bench "bytes written" c_bytewrite bench "bytes read " c_byteread bench "words written" c_wordwrite bench "words read " c_wordread putStrLn "" putStrLn "Haskell memory throughput benchmarks:" bench "bytes written" hs_bytewrite bench "bytes read " hs_byteread bench "words written" hs_wordwrite bench "words read " hs_wordread hs_bytewrite :: Ptr CUChar -> Int -> IO () hs_bytewrite !ptr bytes = loop 0 0 where iterations = bytes loop :: Int -> CUChar -> IO () loop !i !n | i == iterations = return () | otherwise = do pokeByteOff ptr i n loop (i+1) (n+1) hs_byteread :: Ptr CUChar -> Int -> IO CUChar hs_byteread !ptr bytes = loop 0 0 where iterations = bytes loop :: Int -> CUChar -> IO CUChar loop !i !n | i == iterations = return n | otherwise = do x <- peekByteOff ptr i loop (i+1) (n+x) hs_wordwrite :: Ptr CULong -> Int -> IO () hs_wordwrite !ptr bytes = loop 0 0 where iterations = bytes `div` sizeOf (undefined :: CULong) loop :: Int -> CULong -> IO () loop !i !n | i == iterations = return () | otherwise = do pokeByteOff ptr i n loop (i+1) (n+1) hs_wordread :: Ptr CULong -> Int -> IO CULong hs_wordread !ptr bytes = loop 0 0 where iterations = bytes `div` sizeOf (undefined :: CULong) loop :: Int -> CULong -> IO CULong loop !i !n | i == iterations = return n | otherwise = do x <- peekByteOff ptr i loop (i+1) (n+x) foreign import ccall unsafe "CBenchmark.h byteread" c_byteread :: Ptr CUChar -> CInt -> IO () foreign import ccall unsafe "CBenchmark.h bytewrite" c_bytewrite :: Ptr CUChar -> CInt -> IO () foreign import ccall unsafe "CBenchmark.h wordread" c_wordread :: Ptr CUInt -> CInt -> IO () foreign import ccall unsafe "CBenchmark.h wordwrite" c_wordwrite :: Ptr CUInt -> CInt -> IO () time :: IO a -> IO Double time action = do start <- getCPUTime action end <- getCPUTime return $! (fromIntegral (end - start)) / (10^12) cereal-0.3.5.2/tests/CBenchmark.h0000644000000000000000000000030311763507414014614 0ustar0000000000000000void bytewrite(unsigned char *a, int bytes); unsigned char byteread(unsigned char *a, int bytes); void wordwrite(unsigned long *a, int bytes); unsigned int wordread(unsigned long *a, int bytes); cereal-0.3.5.2/tests/Benchmark.hs0000644000000000000000000012445711763507414014715 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Main (main) where import qualified Data.ByteString as L import Data.Serialize import Data.Serialize.Put import Data.Serialize.Get import Control.Exception import Data.Word import System.CPUTime import Numeric import Text.Printf import System.Environment import MemBench data Endian = Big | Little | Host deriving (Eq,Ord,Show) main :: IO () main = do mb <- getArgs >>= readIO . head memBench (mb*10) putStrLn "" putStrLn "Binary (de)serialisation benchmarks:" -- do bytewise sequence_ [ test wordSize chunkSize Host mb | wordSize <- [1] , chunkSize <- [16] --1,2,4,8,16] ] -- now Word16 .. Word64 sequence_ [ test wordSize chunkSize end mb | wordSize <- [2,4,8] , chunkSize <- [16] , end <- [Host] -- ,Big,Little] ] ------------------------------------------------------------------------ time :: IO a -> IO Double time action = do start <- getCPUTime action end <- getCPUTime return $! (fromIntegral (end - start)) / (10^12) ------------------------------------------------------------------------ test :: Int -> Int -> Endian -> Int -> IO () test wordSize chunkSize end mb = do let bytes :: Int bytes = mb * 2^20 iterations = bytes `div` wordSize bs = runPut (doPut wordSize chunkSize end iterations) sum = runGet (doGet wordSize chunkSize end iterations) bs case (chunkSize,end) of (1,Host) -> putStrLn "" ; _ -> return () printf "%dMB of Word%-2d in chunks of %2d (%6s endian): " (mb :: Int) (8 * wordSize :: Int) (chunkSize :: Int) (show end) putSeconds <- time $ evaluate (L.length bs) getSeconds <- time $ evaluate sum -- print (L.length bs, sum) let putThroughput = fromIntegral mb / putSeconds getThroughput = fromIntegral mb / getSeconds printf "%6.1f MB/s write, %6.1f MB/s read, %5.1f get/put-ratio\n" putThroughput getThroughput (getThroughput/putThroughput) ------------------------------------------------------------------------ doPut :: Int -> Int -> Endian -> Int -> Put doPut wordSize chunkSize end = case (wordSize, chunkSize, end) of (1, 1,_) -> putWord8N1 (1, 2,_) -> putWord8N2 (1, 4,_) -> putWord8N4 (1, 8,_) -> putWord8N8 (1, 16, _) -> putWord8N16 (2, 1, Big) -> putWord16N1Big (2, 2, Big) -> putWord16N2Big (2, 4, Big) -> putWord16N4Big (2, 8, Big) -> putWord16N8Big (2, 16, Big) -> putWord16N16Big (2, 1, Little) -> putWord16N1Little (2, 2, Little) -> putWord16N2Little (2, 4, Little) -> putWord16N4Little (2, 8, Little) -> putWord16N8Little (2, 16, Little) -> putWord16N16Little (2, 1, Host) -> putWord16N1Host (2, 2, Host) -> putWord16N2Host (2, 4, Host) -> putWord16N4Host (2, 8, Host) -> putWord16N8Host (2, 16, Host) -> putWord16N16Host (4, 1, Big) -> putWord32N1Big (4, 2, Big) -> putWord32N2Big (4, 4, Big) -> putWord32N4Big (4, 8, Big) -> putWord32N8Big (4, 16, Big) -> putWord32N16Big (4, 1, Little) -> putWord32N1Little (4, 2, Little) -> putWord32N2Little (4, 4, Little) -> putWord32N4Little (4, 8, Little) -> putWord32N8Little (4, 16, Little) -> putWord32N16Little (4, 1, Host) -> putWord32N1Host (4, 2, Host) -> putWord32N2Host (4, 4, Host) -> putWord32N4Host (4, 8, Host) -> putWord32N8Host (4, 16, Host) -> putWord32N16Host (8, 1, Host) -> putWord64N1Host (8, 2, Host) -> putWord64N2Host (8, 4, Host) -> putWord64N4Host (8, 8, Host) -> putWord64N8Host (8, 16, Host) -> putWord64N16Host (8, 1, Big) -> putWord64N1Big (8, 2, Big) -> putWord64N2Big (8, 4, Big) -> putWord64N4Big (8, 8, Big) -> putWord64N8Big (8, 16, Big) -> putWord64N16Big (8, 1, Little) -> putWord64N1Little (8, 2, Little) -> putWord64N2Little (8, 4, Little) -> putWord64N4Little (8, 8, Little) -> putWord64N8Little (8, 16, Little) -> putWord64N16Little ------------------------------------------------------------------------ doGet :: Int -> Int -> Endian -> Int -> Get Int doGet wordSize chunkSize end = case (wordSize, chunkSize, end) of (1, 1,_) -> fmap fromIntegral . getWord8N1 (1, 2,_) -> fmap fromIntegral . getWord8N2 (1, 4,_) -> fmap fromIntegral . getWord8N4 (1, 8,_) -> fmap fromIntegral . getWord8N8 (1, 16,_) -> fmap fromIntegral . getWord8N16 (2, 1,Big) -> fmap fromIntegral . getWord16N1Big (2, 2,Big) -> fmap fromIntegral . getWord16N2Big (2, 4,Big) -> fmap fromIntegral . getWord16N4Big (2, 8,Big) -> fmap fromIntegral . getWord16N8Big (2, 16,Big) -> fmap fromIntegral . getWord16N16Big (2, 1,Little) -> fmap fromIntegral . getWord16N1Little (2, 2,Little) -> fmap fromIntegral . getWord16N2Little (2, 4,Little) -> fmap fromIntegral . getWord16N4Little (2, 8,Little) -> fmap fromIntegral . getWord16N8Little (2, 16,Little) -> fmap fromIntegral . getWord16N16Little (2, 1,Host) -> fmap fromIntegral . getWord16N1Host (2, 2,Host) -> fmap fromIntegral . getWord16N2Host (2, 4,Host) -> fmap fromIntegral . getWord16N4Host (2, 8,Host) -> fmap fromIntegral . getWord16N8Host (2, 16,Host) -> fmap fromIntegral . getWord16N16Host (4, 1,Big) -> fmap fromIntegral . getWord32N1Big (4, 2,Big) -> fmap fromIntegral . getWord32N2Big (4, 4,Big) -> fmap fromIntegral . getWord32N4Big (4, 8,Big) -> fmap fromIntegral . getWord32N8Big (4, 16,Big) -> fmap fromIntegral . getWord32N16Big (4, 1,Little) -> fmap fromIntegral . getWord32N1Little (4, 2,Little) -> fmap fromIntegral . getWord32N2Little (4, 4,Little) -> fmap fromIntegral . getWord32N4Little (4, 8,Little) -> fmap fromIntegral . getWord32N8Little (4, 16,Little) -> fmap fromIntegral . getWord32N16Little (4, 1,Host) -> fmap fromIntegral . getWord32N1Host (4, 2,Host) -> fmap fromIntegral . getWord32N2Host (4, 4,Host) -> fmap fromIntegral . getWord32N4Host (4, 8,Host) -> fmap fromIntegral . getWord32N8Host (4, 16,Host) -> fmap fromIntegral . getWord32N16Host (8, 1,Host) -> fmap fromIntegral . getWord64N1Host (8, 2,Host) -> fmap fromIntegral . getWord64N2Host (8, 4,Host) -> fmap fromIntegral . getWord64N4Host (8, 8,Host) -> fmap fromIntegral . getWord64N8Host (8, 16,Host) -> fmap fromIntegral . getWord64N16Host (8, 1,Big) -> fmap fromIntegral . getWord64N1Big (8, 2,Big) -> fmap fromIntegral . getWord64N2Big (8, 4,Big) -> fmap fromIntegral . getWord64N4Big (8, 8,Big) -> fmap fromIntegral . getWord64N8Big (8, 16,Big) -> fmap fromIntegral . getWord64N16Big (8, 1,Little) -> fmap fromIntegral . getWord64N1Little (8, 2,Little) -> fmap fromIntegral . getWord64N2Little (8, 4,Little) -> fmap fromIntegral . getWord64N4Little (8, 8,Little) -> fmap fromIntegral . getWord64N8Little (8, 16,Little) -> fmap fromIntegral . getWord64N16Little ------------------------------------------------------------------------ putWord8N1 bytes = loop 0 0 where loop :: Word8 -> Int -> Put loop !s !n | n == bytes = return () | otherwise = do putWord8 s loop (s+1) (n+1) putWord8N2 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord8 (s+0) putWord8 (s+1) loop (s+2) (n-2) putWord8N4 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord8 (s+0) putWord8 (s+1) putWord8 (s+2) putWord8 (s+3) loop (s+4) (n-4) putWord8N8 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord8 (s+0) putWord8 (s+1) putWord8 (s+2) putWord8 (s+3) putWord8 (s+4) putWord8 (s+5) putWord8 (s+6) putWord8 (s+7) loop (s+8) (n-8) putWord8N16 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord8 (s+0) putWord8 (s+1) putWord8 (s+2) putWord8 (s+3) putWord8 (s+4) putWord8 (s+5) putWord8 (s+6) putWord8 (s+7) putWord8 (s+8) putWord8 (s+9) putWord8 (s+10) putWord8 (s+11) putWord8 (s+12) putWord8 (s+13) putWord8 (s+14) putWord8 (s+15) loop (s+16) (n-16) ------------------------------------------------------------------------ -- Big endian, word16 writes putWord16N1Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16be (s+0) loop (s+1) (n-1) putWord16N2Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16be (s+0) putWord16be (s+1) loop (s+2) (n-2) putWord16N4Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16be (s+0) putWord16be (s+1) putWord16be (s+2) putWord16be (s+3) loop (s+4) (n-4) putWord16N8Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16be (s+0) putWord16be (s+1) putWord16be (s+2) putWord16be (s+3) putWord16be (s+4) putWord16be (s+5) putWord16be (s+6) putWord16be (s+7) loop (s+8) (n-8) putWord16N16Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16be (s+0) putWord16be (s+1) putWord16be (s+2) putWord16be (s+3) putWord16be (s+4) putWord16be (s+5) putWord16be (s+6) putWord16be (s+7) putWord16be (s+8) putWord16be (s+9) putWord16be (s+10) putWord16be (s+11) putWord16be (s+12) putWord16be (s+13) putWord16be (s+14) putWord16be (s+15) loop (s+16) (n-16) ------------------------------------------------------------------------ -- Little endian, word16 writes putWord16N1Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16le (s+0) loop (s+1) (n-1) putWord16N2Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16le (s+0) putWord16le (s+1) loop (s+2) (n-2) putWord16N4Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16le (s+0) putWord16le (s+1) putWord16le (s+2) putWord16le (s+3) loop (s+4) (n-4) putWord16N8Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16le (s+0) putWord16le (s+1) putWord16le (s+2) putWord16le (s+3) putWord16le (s+4) putWord16le (s+5) putWord16le (s+6) putWord16le (s+7) loop (s+8) (n-8) putWord16N16Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16le (s+0) putWord16le (s+1) putWord16le (s+2) putWord16le (s+3) putWord16le (s+4) putWord16le (s+5) putWord16le (s+6) putWord16le (s+7) putWord16le (s+8) putWord16le (s+9) putWord16le (s+10) putWord16le (s+11) putWord16le (s+12) putWord16le (s+13) putWord16le (s+14) putWord16le (s+15) loop (s+16) (n-16) ------------------------------------------------------------------------ -- Host endian, unaligned, word16 writes putWord16N1Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16host (s+0) loop (s+1) (n-1) putWord16N2Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16host (s+0) putWord16host (s+1) loop (s+2) (n-2) putWord16N4Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16host (s+0) putWord16host (s+1) putWord16host (s+2) putWord16host (s+3) loop (s+4) (n-4) putWord16N8Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16host (s+0) putWord16host (s+1) putWord16host (s+2) putWord16host (s+3) putWord16host (s+4) putWord16host (s+5) putWord16host (s+6) putWord16host (s+7) loop (s+8) (n-8) putWord16N16Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord16host (s+0) putWord16host (s+1) putWord16host (s+2) putWord16host (s+3) putWord16host (s+4) putWord16host (s+5) putWord16host (s+6) putWord16host (s+7) putWord16host (s+8) putWord16host (s+9) putWord16host (s+10) putWord16host (s+11) putWord16host (s+12) putWord16host (s+13) putWord16host (s+14) putWord16host (s+15) loop (s+16) (n-16) ------------------------------------------------------------------------ putWord32N1Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32be (s+0) loop (s+1) (n-1) putWord32N2Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32be (s+0) putWord32be (s+1) loop (s+2) (n-2) putWord32N4Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32be (s+0) putWord32be (s+1) putWord32be (s+2) putWord32be (s+3) loop (s+4) (n-4) putWord32N8Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32be (s+0) putWord32be (s+1) putWord32be (s+2) putWord32be (s+3) putWord32be (s+4) putWord32be (s+5) putWord32be (s+6) putWord32be (s+7) loop (s+8) (n-8) putWord32N16Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32be (s+0) putWord32be (s+1) putWord32be (s+2) putWord32be (s+3) putWord32be (s+4) putWord32be (s+5) putWord32be (s+6) putWord32be (s+7) putWord32be (s+8) putWord32be (s+9) putWord32be (s+10) putWord32be (s+11) putWord32be (s+12) putWord32be (s+13) putWord32be (s+14) putWord32be (s+15) loop (s+16) (n-16) ------------------------------------------------------------------------ putWord32N1Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32le (s+0) loop (s+1) (n-1) putWord32N2Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32le (s+0) putWord32le (s+1) loop (s+2) (n-2) putWord32N4Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32le (s+0) putWord32le (s+1) putWord32le (s+2) putWord32le (s+3) loop (s+4) (n-4) putWord32N8Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32le (s+0) putWord32le (s+1) putWord32le (s+2) putWord32le (s+3) putWord32le (s+4) putWord32le (s+5) putWord32le (s+6) putWord32le (s+7) loop (s+8) (n-8) putWord32N16Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32le (s+0) putWord32le (s+1) putWord32le (s+2) putWord32le (s+3) putWord32le (s+4) putWord32le (s+5) putWord32le (s+6) putWord32le (s+7) putWord32le (s+8) putWord32le (s+9) putWord32le (s+10) putWord32le (s+11) putWord32le (s+12) putWord32le (s+13) putWord32le (s+14) putWord32le (s+15) loop (s+16) (n-16) ------------------------------------------------------------------------ putWord32N1Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32host (s+0) loop (s+1) (n-1) putWord32N2Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32host (s+0) putWord32host (s+1) loop (s+2) (n-2) putWord32N4Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32host (s+0) putWord32host (s+1) putWord32host (s+2) putWord32host (s+3) loop (s+4) (n-4) putWord32N8Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32host (s+0) putWord32host (s+1) putWord32host (s+2) putWord32host (s+3) putWord32host (s+4) putWord32host (s+5) putWord32host (s+6) putWord32host (s+7) loop (s+8) (n-8) putWord32N16Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord32host (s+0) putWord32host (s+1) putWord32host (s+2) putWord32host (s+3) putWord32host (s+4) putWord32host (s+5) putWord32host (s+6) putWord32host (s+7) putWord32host (s+8) putWord32host (s+9) putWord32host (s+10) putWord32host (s+11) putWord32host (s+12) putWord32host (s+13) putWord32host (s+14) putWord32host (s+15) loop (s+16) (n-16) ------------------------------------------------------------------------ putWord64N1Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64be (s+0) loop (s+1) (n-1) putWord64N2Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64be (s+0) putWord64be (s+1) loop (s+2) (n-2) putWord64N4Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64be (s+0) putWord64be (s+1) putWord64be (s+2) putWord64be (s+3) loop (s+4) (n-4) putWord64N8Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64be (s+0) putWord64be (s+1) putWord64be (s+2) putWord64be (s+3) putWord64be (s+4) putWord64be (s+5) putWord64be (s+6) putWord64be (s+7) loop (s+8) (n-8) putWord64N16Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64be (s+0) putWord64be (s+1) putWord64be (s+2) putWord64be (s+3) putWord64be (s+4) putWord64be (s+5) putWord64be (s+6) putWord64be (s+7) putWord64be (s+8) putWord64be (s+9) putWord64be (s+10) putWord64be (s+11) putWord64be (s+12) putWord64be (s+13) putWord64be (s+14) putWord64be (s+15) loop (s+16) (n-16) ------------------------------------------------------------------------ putWord64N1Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64le (s+0) loop (s+1) (n-1) putWord64N2Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64le (s+0) putWord64le (s+1) loop (s+2) (n-2) putWord64N4Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64le (s+0) putWord64le (s+1) putWord64le (s+2) putWord64le (s+3) loop (s+4) (n-4) putWord64N8Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64le (s+0) putWord64le (s+1) putWord64le (s+2) putWord64le (s+3) putWord64le (s+4) putWord64le (s+5) putWord64le (s+6) putWord64le (s+7) loop (s+8) (n-8) putWord64N16Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64le (s+0) putWord64le (s+1) putWord64le (s+2) putWord64le (s+3) putWord64le (s+4) putWord64le (s+5) putWord64le (s+6) putWord64le (s+7) putWord64le (s+8) putWord64le (s+9) putWord64le (s+10) putWord64le (s+11) putWord64le (s+12) putWord64le (s+13) putWord64le (s+14) putWord64le (s+15) loop (s+16) (n-16) ------------------------------------------------------------------------ putWord64N1Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64host (s+0) loop (s+1) (n-1) putWord64N2Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64host (s+0) putWord64host (s+1) loop (s+2) (n-2) putWord64N4Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64host (s+0) putWord64host (s+1) putWord64host (s+2) putWord64host (s+3) loop (s+4) (n-4) putWord64N8Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64host (s+0) putWord64host (s+1) putWord64host (s+2) putWord64host (s+3) putWord64host (s+4) putWord64host (s+5) putWord64host (s+6) putWord64host (s+7) loop (s+8) (n-8) putWord64N16Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop _ 0 = return () loop s n = do putWord64host (s+0) putWord64host (s+1) putWord64host (s+2) putWord64host (s+3) putWord64host (s+4) putWord64host (s+5) putWord64host (s+6) putWord64host (s+7) putWord64host (s+8) putWord64host (s+9) putWord64host (s+10) putWord64host (s+11) putWord64host (s+12) putWord64host (s+13) putWord64host (s+14) putWord64host (s+15) loop (s+16) (n-16) ------------------------------------------------------------------------ ------------------------------------------------------------------------ getWord8N1 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord8 loop (s+s0) (n-1) getWord8N2 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord8 s1 <- getWord8 loop (s+s0+s1) (n-2) getWord8N4 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord8 s1 <- getWord8 s2 <- getWord8 s3 <- getWord8 loop (s+s0+s1+s2+s3) (n-4) getWord8N8 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord8 s1 <- getWord8 s2 <- getWord8 s3 <- getWord8 s4 <- getWord8 s5 <- getWord8 s6 <- getWord8 s7 <- getWord8 loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) getWord8N16 = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord8 s1 <- getWord8 s2 <- getWord8 s3 <- getWord8 s4 <- getWord8 s5 <- getWord8 s6 <- getWord8 s7 <- getWord8 s8 <- getWord8 s9 <- getWord8 s10 <- getWord8 s11 <- getWord8 s12 <- getWord8 s13 <- getWord8 s14 <- getWord8 s15 <- getWord8 loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) ------------------------------------------------------------------------ getWord16N1Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord16be loop (s+s0) (n-1) getWord16N2Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord16be s1 <- getWord16be loop (s+s0+s1) (n-2) getWord16N4Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord16be s1 <- getWord16be s2 <- getWord16be s3 <- getWord16be loop (s+s0+s1+s2+s3) (n-4) getWord16N8Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord16be s1 <- getWord16be s2 <- getWord16be s3 <- getWord16be s4 <- getWord16be s5 <- getWord16be s6 <- getWord16be s7 <- getWord16be loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) getWord16N16Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord16be s1 <- getWord16be s2 <- getWord16be s3 <- getWord16be s4 <- getWord16be s5 <- getWord16be s6 <- getWord16be s7 <- getWord16be s8 <- getWord16be s9 <- getWord16be s10 <- getWord16be s11 <- getWord16be s12 <- getWord16be s13 <- getWord16be s14 <- getWord16be s15 <- getWord16be loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) ------------------------------------------------------------------------ getWord16N1Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord16le loop (s+s0) (n-1) getWord16N2Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord16le s1 <- getWord16le loop (s+s0+s1) (n-2) getWord16N4Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord16le s1 <- getWord16le s2 <- getWord16le s3 <- getWord16le loop (s+s0+s1+s2+s3) (n-4) getWord16N8Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord16le s1 <- getWord16le s2 <- getWord16le s3 <- getWord16le s4 <- getWord16le s5 <- getWord16le s6 <- getWord16le s7 <- getWord16le loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) getWord16N16Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord16le s1 <- getWord16le s2 <- getWord16le s3 <- getWord16le s4 <- getWord16le s5 <- getWord16le s6 <- getWord16le s7 <- getWord16le s8 <- getWord16le s9 <- getWord16le s10 <- getWord16le s11 <- getWord16le s12 <- getWord16le s13 <- getWord16le s14 <- getWord16le s15 <- getWord16le loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) ------------------------------------------------------------------------ getWord16N1Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord16host loop (s+s0) (n-1) getWord16N2Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord16host s1 <- getWord16host loop (s+s0+s1) (n-2) getWord16N4Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord16host s1 <- getWord16host s2 <- getWord16host s3 <- getWord16host loop (s+s0+s1+s2+s3) (n-4) getWord16N8Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord16host s1 <- getWord16host s2 <- getWord16host s3 <- getWord16host s4 <- getWord16host s5 <- getWord16host s6 <- getWord16host s7 <- getWord16host loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) getWord16N16Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord16host s1 <- getWord16host s2 <- getWord16host s3 <- getWord16host s4 <- getWord16host s5 <- getWord16host s6 <- getWord16host s7 <- getWord16host s8 <- getWord16host s9 <- getWord16host s10 <- getWord16host s11 <- getWord16host s12 <- getWord16host s13 <- getWord16host s14 <- getWord16host s15 <- getWord16host loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) ------------------------------------------------------------------------ getWord32N1Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord32be loop (s+s0) (n-1) getWord32N2Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord32be s1 <- getWord32be loop (s+s0+s1) (n-2) getWord32N4Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord32be s1 <- getWord32be s2 <- getWord32be s3 <- getWord32be loop (s+s0+s1+s2+s3) (n-4) getWord32N8Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord32be s1 <- getWord32be s2 <- getWord32be s3 <- getWord32be s4 <- getWord32be s5 <- getWord32be s6 <- getWord32be s7 <- getWord32be loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) -- getWordhostN16 = loop 0 getWord32N16Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord32be s1 <- getWord32be s2 <- getWord32be s3 <- getWord32be s4 <- getWord32be s5 <- getWord32be s6 <- getWord32be s7 <- getWord32be s8 <- getWord32be s9 <- getWord32be s10 <- getWord32be s11 <- getWord32be s12 <- getWord32be s13 <- getWord32be s14 <- getWord32be s15 <- getWord32be loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) ------------------------------------------------------------------------ getWord32N1Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord32le loop (s+s0) (n-1) getWord32N2Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord32le s1 <- getWord32le loop (s+s0+s1) (n-2) getWord32N4Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord32le s1 <- getWord32le s2 <- getWord32le s3 <- getWord32le loop (s+s0+s1+s2+s3) (n-4) getWord32N8Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord32le s1 <- getWord32le s2 <- getWord32le s3 <- getWord32le s4 <- getWord32le s5 <- getWord32le s6 <- getWord32le s7 <- getWord32le loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) -- getWordhostN16 = loop 0 getWord32N16Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord32le s1 <- getWord32le s2 <- getWord32le s3 <- getWord32le s4 <- getWord32le s5 <- getWord32le s6 <- getWord32le s7 <- getWord32le s8 <- getWord32le s9 <- getWord32le s10 <- getWord32le s11 <- getWord32le s12 <- getWord32le s13 <- getWord32le s14 <- getWord32le s15 <- getWord32le loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) ------------------------------------------------------------------------ getWord32N1Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord32host loop (s+s0) (n-1) getWord32N2Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord32host s1 <- getWord32host loop (s+s0+s1) (n-2) getWord32N4Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord32host s1 <- getWord32host s2 <- getWord32host s3 <- getWord32host loop (s+s0+s1+s2+s3) (n-4) getWord32N8Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord32host s1 <- getWord32host s2 <- getWord32host s3 <- getWord32host s4 <- getWord32host s5 <- getWord32host s6 <- getWord32host s7 <- getWord32host loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) -- getWordhostN16 = loop 0 getWord32N16Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord32host s1 <- getWord32host s2 <- getWord32host s3 <- getWord32host s4 <- getWord32host s5 <- getWord32host s6 <- getWord32host s7 <- getWord32host s8 <- getWord32host s9 <- getWord32host s10 <- getWord32host s11 <- getWord32host s12 <- getWord32host s13 <- getWord32host s14 <- getWord32host s15 <- getWord32host loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) ------------------------------------------------------------------------ getWord64N1Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord64be loop (s+s0) (n-1) getWord64N2Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord64be s1 <- getWord64be loop (s+s0+s1) (n-2) getWord64N4Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord64be s1 <- getWord64be s2 <- getWord64be s3 <- getWord64be loop (s+s0+s1+s2+s3) (n-4) getWord64N8Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord64be s1 <- getWord64be s2 <- getWord64be s3 <- getWord64be s4 <- getWord64be s5 <- getWord64be s6 <- getWord64be s7 <- getWord64be loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) getWord64N16Big = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord64be s1 <- getWord64be s2 <- getWord64be s3 <- getWord64be s4 <- getWord64be s5 <- getWord64be s6 <- getWord64be s7 <- getWord64be s8 <- getWord64be s9 <- getWord64be s10 <- getWord64be s11 <- getWord64be s12 <- getWord64be s13 <- getWord64be s14 <- getWord64be s15 <- getWord64be loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) ------------------------------------------------------------------------ getWord64N1Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord64le loop (s+s0) (n-1) getWord64N2Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord64le s1 <- getWord64le loop (s+s0+s1) (n-2) getWord64N4Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord64le s1 <- getWord64le s2 <- getWord64le s3 <- getWord64le loop (s+s0+s1+s2+s3) (n-4) getWord64N8Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord64le s1 <- getWord64le s2 <- getWord64le s3 <- getWord64le s4 <- getWord64le s5 <- getWord64le s6 <- getWord64le s7 <- getWord64le loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) getWord64N16Little = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord64le s1 <- getWord64le s2 <- getWord64le s3 <- getWord64le s4 <- getWord64le s5 <- getWord64le s6 <- getWord64le s7 <- getWord64le s8 <- getWord64le s9 <- getWord64le s10 <- getWord64le s11 <- getWord64le s12 <- getWord64le s13 <- getWord64le s14 <- getWord64le s15 <- getWord64le loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) ------------------------------------------------------------------------ getWord64N1Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord64host loop (s+s0) (n-1) getWord64N2Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord64host s1 <- getWord64host loop (s+s0+s1) (n-2) getWord64N4Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord64host s1 <- getWord64host s2 <- getWord64host s3 <- getWord64host loop (s+s0+s1+s2+s3) (n-4) getWord64N8Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord64host s1 <- getWord64host s2 <- getWord64host s3 <- getWord64host s4 <- getWord64host s5 <- getWord64host s6 <- getWord64host s7 <- getWord64host loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) getWord64N16Host = loop 0 where loop s n | s `seq` n `seq` False = undefined loop s 0 = return s loop s n = do s0 <- getWord64host s1 <- getWord64host s2 <- getWord64host s3 <- getWord64host s4 <- getWord64host s5 <- getWord64host s6 <- getWord64host s7 <- getWord64host s8 <- getWord64host s9 <- getWord64host s10 <- getWord64host s11 <- getWord64host s12 <- getWord64host s13 <- getWord64host s14 <- getWord64host s15 <- getWord64host loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) cereal-0.3.5.2/tests/Makefile0000644000000000000000000000074511763507414014120 0ustar0000000000000000GHC = ghc -O2 -fforce-recomp -i../src all: bench qc bench:: Benchmark.hs MemBench.hs CBenchmark.o $(GHC) -fliberate-case-threshold=1000 --make Benchmark.hs CBenchmark.o -o $@ ./$@ 100 bench-prof: Benchmark.hs MemBench.hs CBenchmark.o $(GHC) -prof -auto-all -rtsopts --make Benchmark.hs CBenchmark.o -o $@ ./$@ 100 +RTS -p CBenchmark.o: CBenchmark.c gcc -O3 -c $< -o $@ qc: Tests.hs $(GHC) --make $< -o $@ ./$@ clean: $(RM) *.o *.hi bench qc .PHONY: clean bench bench-nb cereal-0.3.5.2/tests/CBenchmark.c0000644000000000000000000000135611763507414014620 0ustar0000000000000000#include "CBenchmark.h" void bytewrite(unsigned char *a, int bytes) { unsigned char n = 0; int i = 0; int iterations = bytes; while (i < iterations) { a[i++] = n++; } } unsigned char byteread(unsigned char *a, int bytes) { unsigned char n = 0; int i = 0; int iterations = bytes; while (i < iterations) { n += a[i++]; } return n; } void wordwrite(unsigned long *a, int bytes) { unsigned long n = 0; int i = 0; int iterations = bytes / sizeof(unsigned long) ; while (i < iterations) { a[i++] = n++; } } unsigned int wordread(unsigned long *a, int bytes) { unsigned long n = 0; int i = 0; int iterations = bytes / sizeof(unsigned long); while (i < iterations) { n += a[i++]; } return n; } cereal-0.3.5.2/tests/Tests.hs0000644000000000000000000000427611763507414014121 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} -------------------------------------------------------------------------------- -- | -- Module : -- Copyright : (c) Galois, Inc, 2009 -- License : AllRightsReserved -- -- Maintainer : Trevor Elliott -- Stability : -- Portability : -- import Data.Serialize import Data.Serialize.Get import Data.Serialize.Put import Data.Serialize.IEEE754 import Data.Word (Word8,Word16,Word32,Word64) import Test.QuickCheck as QC roundTrip :: Eq a => Putter a -> Get a -> a -> Bool roundTrip p g a = res == Right a where res = runGet g (runPut (p a)) main :: IO () main = mapM_ quickCheck [ QC.label "Word8 Round Trip" $ roundTrip putWord8 getWord8 , QC.label "Word16be Round Trip" $ roundTrip putWord16be getWord16be , QC.label "Word16le Round Trip" $ roundTrip putWord16le getWord16le , QC.label "Word32be Round Trip" $ roundTrip putWord32be getWord32be , QC.label "Word32le Round Trip" $ roundTrip putWord32le getWord32le , QC.label "Word64be Round Trip" $ roundTrip putWord64be getWord64be , QC.label "Word64le Round Trip" $ roundTrip putWord64le getWord64le , QC.label "Word16host Round Trip" $ roundTrip putWord16host getWord16host , QC.label "Word32host Round Trip" $ roundTrip putWord32host getWord32host , QC.label "Word64host Round Trip" $ roundTrip putWord64host getWord64host , QC.label "Float32le Round Trip" $ roundTrip putFloat32le getFloat32le , QC.label "Float32be Round Trip" $ roundTrip putFloat32be getFloat32be , QC.label "Float64le Round Trip" $ roundTrip putFloat64le getFloat64le , QC.label "Float64be Round Trip" $ roundTrip putFloat64be getFloat64be -- Containers , QC.label "(Word8,Word8) Round Trip" $ roundTrip (putTwoOf putWord8 putWord8) (getTwoOf getWord8 getWord8) , QC.label "[Word8] Round Trip" $ roundTrip (putListOf putWord8) (getListOf getWord8) , QC.label "Maybe Word8 Round Trip" $ roundTrip (putMaybeOf putWord8) (getMaybeOf getWord8) , QC.label "Either Word8 Word16be Round Trip " $ roundTrip (putEitherOf putWord8 putWord16be) (getEitherOf getWord8 getWord16be) ] cereal-0.3.5.2/src/0000755000000000000000000000000011763507414012077 5ustar0000000000000000cereal-0.3.5.2/src/Data/0000755000000000000000000000000011763507414012750 5ustar0000000000000000cereal-0.3.5.2/src/Data/Serialize.hs0000644000000000000000000004457111763507414015246 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} #ifdef GENERICS {-# LANGUAGE DefaultSignatures , TypeOperators , BangPatterns , KindSignatures , ScopedTypeVariables #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Data.Serialize -- Copyright : Lennart Kolmodin, Galois Inc. 2009 -- License : BSD3-style (see LICENSE) -- -- Maintainer : Trevor Elliott -- Stability : -- Portability : -- ----------------------------------------------------------------------------- module Data.Serialize ( -- * The Serialize class Serialize(..) -- $example -- * Serialize serialisation , encode, encodeLazy , decode, decodeLazy , module Data.Serialize.Get , module Data.Serialize.Put , module Data.Serialize.IEEE754 ) where import Data.Serialize.Put import Data.Serialize.Get import Data.Serialize.IEEE754 import Control.Monad import Data.Array.Unboxed import Data.ByteString (ByteString) import Data.Char (chr,ord) import Data.List (unfoldr) import Data.Word import Foreign -- And needed for the instances: import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Ratio as R import qualified Data.Tree as T import qualified Data.Sequence as Seq #ifdef GENERICS import GHC.Generics import Control.Applicative ((*>),(<*>),(<$>),pure) #endif ------------------------------------------------------------------------ -- | If your compiler has support for the @DeriveGeneric@ and -- @DefaultSignatures@ language extensions (@ghc >= 7.2.1@), the 'put' and 'get' -- methods will have default generic implementations. -- -- To use this option, simply add a @deriving 'Generic'@ clause to your datatype -- and declare a 'Serialize' instance for it without giving a definition for -- 'put' and 'get'. class Serialize t where -- | Encode a value in the Put monad. put :: Putter t -- | Decode a value in the Get monad get :: Get t #ifdef GENERICS default put :: (Generic t, GSerialize (Rep t)) => Putter t put = gPut . from default get :: (Generic t, GSerialize (Rep t)) => Get t get = to <$> gGet #endif ------------------------------------------------------------------------ -- Wrappers to run the underlying monad -- | Encode a value using binary serialization to a strict ByteString. encode :: Serialize a => a -> ByteString encode = runPut . put -- | Encode a value using binary serialization to a lazy ByteString. encodeLazy :: Serialize a => a -> L.ByteString encodeLazy = runPutLazy . put -- | Decode a value from a strict ByteString, reconstructing the original -- structure. decode :: Serialize a => ByteString -> Either String a decode = runGet get -- | Decode a value from a lazy ByteString, reconstructing the original -- structure. decodeLazy :: Serialize a => L.ByteString -> Either String a decodeLazy = runGetLazy get ------------------------------------------------------------------------ -- Simple instances -- The () type need never be written to disk: values of singleton type -- can be reconstructed from the type alone instance Serialize () where put () = return () get = return () -- Bools are encoded as a byte in the range 0 .. 1 instance Serialize Bool where put = putWord8 . fromIntegral . fromEnum get = liftM (toEnum . fromIntegral) getWord8 -- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2 instance Serialize Ordering where put = putWord8 . fromIntegral . fromEnum get = liftM (toEnum . fromIntegral) getWord8 ------------------------------------------------------------------------ -- Words and Ints -- Words8s are written as bytes instance Serialize Word8 where put = putWord8 get = getWord8 -- Words16s are written as 2 bytes in big-endian (network) order instance Serialize Word16 where put = putWord16be get = getWord16be -- Words32s are written as 4 bytes in big-endian (network) order instance Serialize Word32 where put = putWord32be get = getWord32be -- Words64s are written as 8 bytes in big-endian (network) order instance Serialize Word64 where put = putWord64be get = getWord64be -- Int8s are written as a single byte. instance Serialize Int8 where put i = put (fromIntegral i :: Word8) get = liftM fromIntegral (get :: Get Word8) -- Int16s are written as a 2 bytes in big endian format instance Serialize Int16 where put i = put (fromIntegral i :: Word16) get = liftM fromIntegral (get :: Get Word16) -- Int32s are written as a 4 bytes in big endian format instance Serialize Int32 where put i = put (fromIntegral i :: Word32) get = liftM fromIntegral (get :: Get Word32) -- Int64s are written as a 8 bytes in big endian format instance Serialize Int64 where put i = put (fromIntegral i :: Word64) get = liftM fromIntegral (get :: Get Word64) ------------------------------------------------------------------------ -- Words are are written as Word64s, that is, 8 bytes in big endian format instance Serialize Word where put i = put (fromIntegral i :: Word64) get = liftM fromIntegral (get :: Get Word64) -- Ints are are written as Int64s, that is, 8 bytes in big endian format instance Serialize Int where put i = put (fromIntegral i :: Int64) get = liftM fromIntegral (get :: Get Int64) ------------------------------------------------------------------------ -- -- Portable, and pretty efficient, serialisation of Integer -- -- Fixed-size type for a subset of Integer type SmallInt = Int32 -- Integers are encoded in two ways: if they fit inside a SmallInt, -- they're written as a byte tag, and that value. If the Integer value -- is too large to fit in a SmallInt, it is written as a byte array, -- along with a sign and length field. instance Serialize Integer where put n | n >= lo && n <= hi = do putWord8 0 put (fromIntegral n :: SmallInt) -- fast path where lo = fromIntegral (minBound :: SmallInt) :: Integer hi = fromIntegral (maxBound :: SmallInt) :: Integer put n = do putWord8 1 put sign put (unroll (abs n)) -- unroll the bytes where sign = fromIntegral (signum n) :: Word8 get = do tag <- get :: Get Word8 case tag of 0 -> liftM fromIntegral (get :: Get SmallInt) _ -> do sign <- get bytes <- get let v = roll bytes return $! if sign == (1 :: Word8) then v else - v -- -- Fold and unfold an Integer to and from a list of its bytes -- unroll :: Integer -> [Word8] unroll = unfoldr step where step 0 = Nothing step i = Just (fromIntegral i, i `shiftR` 8) roll :: [Word8] -> Integer roll = foldr unstep 0 where unstep b a = a `shiftL` 8 .|. fromIntegral b instance (Serialize a,Integral a) => Serialize (R.Ratio a) where put r = put (R.numerator r) >> put (R.denominator r) get = liftM2 (R.%) get get ------------------------------------------------------------------------ -- Char is serialised as UTF-8 instance Serialize Char where put a | c <= 0x7f = put (fromIntegral c :: Word8) | c <= 0x7ff = do put (0xc0 .|. y) put (0x80 .|. z) | c <= 0xffff = do put (0xe0 .|. x) put (0x80 .|. y) put (0x80 .|. z) | c <= 0x10ffff = do put (0xf0 .|. w) put (0x80 .|. x) put (0x80 .|. y) put (0x80 .|. z) | otherwise = error "Not a valid Unicode code point" where c = ord a z, y, x, w :: Word8 z = fromIntegral (c .&. 0x3f) y = fromIntegral (shiftR c 6 .&. 0x3f) x = fromIntegral (shiftR c 12 .&. 0x3f) w = fromIntegral (shiftR c 18 .&. 0x7) get = do let getByte = liftM (fromIntegral :: Word8 -> Int) get shiftL6 = flip shiftL 6 :: Int -> Int w <- getByte r <- case () of _ | w < 0x80 -> return w | w < 0xe0 -> do x <- liftM (xor 0x80) getByte return (x .|. shiftL6 (xor 0xc0 w)) | w < 0xf0 -> do x <- liftM (xor 0x80) getByte y <- liftM (xor 0x80) getByte return (y .|. shiftL6 (x .|. shiftL6 (xor 0xe0 w))) | otherwise -> do x <- liftM (xor 0x80) getByte y <- liftM (xor 0x80) getByte z <- liftM (xor 0x80) getByte return (z .|. shiftL6 (y .|. shiftL6 (x .|. shiftL6 (xor 0xf0 w)))) return $! chr r ------------------------------------------------------------------------ -- Instances for the first few tuples instance (Serialize a, Serialize b) => Serialize (a,b) where put = putTwoOf put put get = getTwoOf get get instance (Serialize a, Serialize b, Serialize c) => Serialize (a,b,c) where put (a,b,c) = put a >> put b >> put c get = liftM3 (,,) get get get instance (Serialize a, Serialize b, Serialize c, Serialize d) => Serialize (a,b,c,d) where put (a,b,c,d) = put a >> put b >> put c >> put d get = liftM4 (,,,) get get get get instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e) => Serialize (a,b,c,d,e) where put (a,b,c,d,e) = put a >> put b >> put c >> put d >> put e get = liftM5 (,,,,) get get get get get -- -- and now just recurse: -- instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e , Serialize f) => Serialize (a,b,c,d,e,f) where put (a,b,c,d,e,f) = put (a,(b,c,d,e,f)) get = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f) instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e , Serialize f, Serialize g) => Serialize (a,b,c,d,e,f,g) where put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g)) get = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g) instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e, Serialize f, Serialize g, Serialize h) => Serialize (a,b,c,d,e,f,g,h) where put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h)) get = do (a,(b,c,d,e,f,g,h)) <- get return (a,b,c,d,e,f,g,h) instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e, Serialize f, Serialize g, Serialize h, Serialize i) => Serialize (a,b,c,d,e,f,g,h,i) where put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i)) get = do (a,(b,c,d,e,f,g,h,i)) <- get return (a,b,c,d,e,f,g,h,i) instance (Serialize a, Serialize b, Serialize c, Serialize d, Serialize e, Serialize f, Serialize g, Serialize h, Serialize i, Serialize j) => Serialize (a,b,c,d,e,f,g,h,i,j) where put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j)) get = do (a,(b,c,d,e,f,g,h,i,j)) <- get return (a,b,c,d,e,f,g,h,i,j) ------------------------------------------------------------------------ -- Container types instance Serialize a => Serialize [a] where put = putListOf put get = getListOf get instance (Serialize a) => Serialize (Maybe a) where put = putMaybeOf put get = getMaybeOf get instance (Serialize a, Serialize b) => Serialize (Either a b) where put = putEitherOf put put get = getEitherOf get get ------------------------------------------------------------------------ -- ByteStrings (have specially efficient instances) instance Serialize B.ByteString where put bs = do put (B.length bs :: Int) putByteString bs get = get >>= getByteString instance Serialize L.ByteString where put bs = do put (L.length bs :: Int64) putLazyByteString bs get = get >>= getLazyByteString ------------------------------------------------------------------------ -- Maps and Sets instance (Ord a, Serialize a) => Serialize (Set.Set a) where put = putSetOf put get = getSetOf get instance (Ord k, Serialize k, Serialize e) => Serialize (Map.Map k e) where put = putMapOf put put get = getMapOf get get instance Serialize IntSet.IntSet where put = putIntSetOf put get = getIntSetOf get instance (Serialize e) => Serialize (IntMap.IntMap e) where put = putIntMapOf put put get = getIntMapOf get get ------------------------------------------------------------------------ -- Queues and Sequences instance (Serialize e) => Serialize (Seq.Seq e) where put = putSeqOf put get = getSeqOf get ------------------------------------------------------------------------ -- Floating point instance Serialize Double where put d = put (decodeFloat d) get = liftM2 encodeFloat get get instance Serialize Float where put f = put (decodeFloat f) get = liftM2 encodeFloat get get ------------------------------------------------------------------------ -- Trees instance (Serialize e) => Serialize (T.Tree e) where put = putTreeOf put get = getTreeOf get ------------------------------------------------------------------------ -- Arrays instance (Serialize i, Ix i, Serialize e) => Serialize (Array i e) where put = putIArrayOf put put get = getIArrayOf get get -- -- The IArray UArray e constraint is non portable. Requires flexible instances -- instance (Serialize i, Ix i, Serialize e, IArray UArray e) => Serialize (UArray i e) where put = putIArrayOf put put get = getIArrayOf get get #ifdef GENERICS ------------------------------------------------------------------------ -- Generic Serialze class GSerialize f where gPut :: Putter (f a) gGet :: Get (f a) instance GSerialize a => GSerialize (M1 i c a) where gPut = gPut . unM1 gGet = M1 <$> gGet {-# INLINE gPut #-} {-# INLINE gGet #-} instance Serialize a => GSerialize (K1 i a) where gPut = put . unK1 gGet = K1 <$> get {-# INLINE gPut #-} {-# INLINE gGet #-} instance GSerialize U1 where gPut _ = pure () gGet = pure U1 {-# INLINE gPut #-} {-# INLINE gGet #-} instance (GSerialize a, GSerialize b) => GSerialize (a :*: b) where gPut (a :*: b) = gPut a *> gPut b gGet = (:*:) <$> gGet <*> gGet {-# INLINE gPut #-} {-# INLINE gGet #-} -- The following GSerialize instance for sums has support for serializing types -- with up to 2^64-1 constructors. It will use the minimal number of bytes -- needed to encode the constructor. For example when a type has 2^8 -- constructors or less it will use a single byte to encode the constructor. If -- it has 2^16 constructors or less it will use two bytes, and so on till 2^64-1. #define GUARD(WORD) (size - 1) <= fromIntegral (maxBound :: WORD) #define PUTSUM(WORD) GUARD(WORD) = putSum (0 :: WORD) (fromIntegral size) #define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size) instance ( PutSum a, PutSum b , GetSum a, GetSum b , GSerialize a, GSerialize b , SumSize a, SumSize b) => GSerialize (a :+: b) where gPut | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64) | otherwise = sizeError "encode" size where size = unTagged (sumSize :: Tagged (a :+: b) Word64) gGet | GETSUM(Word8) | GETSUM(Word16) | GETSUM(Word32) | GETSUM(Word64) | otherwise = sizeError "decode" size where size = unTagged (sumSize :: Tagged (a :+: b) Word64) {-# INLINE gPut #-} {-# INLINE gGet #-} sizeError :: Show size => String -> size -> error sizeError s size = error $ "Can't " ++ s ++ " a type with " ++ show size ++ " constructors" ------------------------------------------------------------------------ class PutSum f where putSum :: (Num word, Bits word, Serialize word) => word -> word -> Putter (f a) instance (PutSum a, PutSum b, GSerialize a, GSerialize b) => PutSum (a :+: b) where putSum !code !size s = case s of L1 x -> putSum code sizeL x R1 x -> putSum (code + sizeL) sizeR x where #if MIN_VERSION_base(4,5,0) sizeL = size `unsafeShiftR` 1 #else sizeL = size `shiftR` 1 #endif sizeR = size - sizeL {-# INLINE putSum #-} instance GSerialize a => PutSum (C1 c a) where putSum !code _ x = put code *> gPut x {-# INLINE putSum #-} ------------------------------------------------------------------------ checkGetSum :: (Ord word, Num word, Bits word, GetSum f) => word -> word -> Get (f a) checkGetSum size code | code < size = getSum code size | otherwise = fail "Unknown encoding for constructor" {-# INLINE checkGetSum #-} class GetSum f where getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a) instance (GetSum a, GetSum b, GSerialize a, GSerialize b) => GetSum (a :+: b) where getSum !code !size | code < sizeL = L1 <$> getSum code sizeL | otherwise = R1 <$> getSum (code - sizeL) sizeR where #if MIN_VERSION_base(4,5,0) sizeL = size `unsafeShiftR` 1 #else sizeL = size `shiftR` 1 #endif sizeR = size - sizeL {-# INLINE getSum #-} instance GSerialize a => GetSum (C1 c a) where getSum _ _ = gGet {-# INLINE getSum #-} ------------------------------------------------------------------------ class SumSize f where sumSize :: Tagged f Word64 newtype Tagged (s :: * -> *) b = Tagged {unTagged :: b} instance (SumSize a, SumSize b) => SumSize (a :+: b) where sumSize = Tagged $ unTagged (sumSize :: Tagged a Word64) + unTagged (sumSize :: Tagged b Word64) instance SumSize (C1 c a) where sumSize = Tagged 1 #endif cereal-0.3.5.2/src/Data/Serialize/0000755000000000000000000000000011763507414014677 5ustar0000000000000000cereal-0.3.5.2/src/Data/Serialize/Get.hs0000644000000000000000000004702111763507414015756 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE Rank2Types #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Serialize.Get -- Copyright : Lennart Kolmodin, Galois Inc. 2009 -- License : BSD3-style (see LICENSE) -- -- Maintainer : Trevor Elliott -- Stability : -- Portability : -- -- The Get monad. A monad for efficiently building structures from -- strict ByteStrings -- ----------------------------------------------------------------------------- #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) #include "MachDeps.h" #endif module Data.Serialize.Get ( -- * The Get type Get , runGet , runGetLazy , runGetState , runGetLazyState , Result(..) , runGetPartial -- * Parsing , ensure , isolate , label , skip , uncheckedSkip , lookAhead , lookAheadM , lookAheadE , uncheckedLookAhead -- * Utility , getBytes , remaining , isEmpty -- * Parsing particular types , getWord8 -- ** ByteStrings , getByteString , getLazyByteString -- ** Big-endian reads , getWord16be , getWord32be , getWord64be -- ** Little-endian reads , getWord16le , getWord32le , getWord64le -- ** Host-endian, unaligned reads , getWordhost , getWord16host , getWord32host , getWord64host -- ** Containers , getTwoOf , getListOf , getIArrayOf , getTreeOf , getSeqOf , getMapOf , getIntMapOf , getSetOf , getIntSetOf , getMaybeOf , getEitherOf ) where import Control.Applicative (Applicative(..),Alternative(..)) import Control.Monad (unless,when,ap,MonadPlus(..),liftM2) import Data.Array.IArray (IArray,listArray) import Data.Ix (Ix) import Data.List (intercalate) import Data.Maybe (isNothing,fromMaybe) import Foreign import qualified Data.ByteString 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.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Tree as T #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) import GHC.Base import GHC.Word #endif -- | The result of a parse. data Result r = Fail String -- ^ The parse failed. The 'String' is the -- message describing the error, if any. | Partial (B.ByteString -> Result r) -- ^ Supply this continuation with more input so that -- the parser can resume. To indicate that no more -- input is available, use an 'B.empty' string. | Done r B.ByteString -- ^ The parse succeeded. The 'B.ByteString' is the -- input that had not yet been consumed (if any) when -- the parse succeeded. instance Show r => Show (Result r) where show (Fail msg) = "Fail " ++ show msg show (Partial _) = "Partial _" show (Done r bs) = "Done " ++ show r ++ " " ++ show bs instance Functor Result where fmap _ (Fail msg) = Fail msg fmap f (Partial k) = Partial (fmap f . k) fmap f (Done r bs) = Done (f r) bs -- | The Get monad is an Exception and State monad. newtype Get a = Get { unGet :: forall r. Input -> Buffer -> More -> Failure r -> Success a r -> Result r } type Input = B.ByteString type Buffer = Maybe B.ByteString append :: Buffer -> Buffer -> Buffer append l r = B.append `fmap` l <*> r {-# INLINE append #-} bufferBytes :: Buffer -> B.ByteString bufferBytes = fromMaybe B.empty {-# INLINE bufferBytes #-} type Failure r = Input -> Buffer -> More -> [String] -> String -> Result r type Success a r = Input -> Buffer -> More -> a -> Result r -- | Have we read all available input? data More = Complete | Incomplete (Maybe Int) deriving (Eq) moreLength :: More -> Int moreLength m = case m of Complete -> 0 Incomplete mb -> fromMaybe 0 mb instance Functor Get where fmap p m = Get $ \s0 b0 m0 kf ks -> let ks' s1 b1 m1 a = ks s1 b1 m1 (p a) in unGet m s0 b0 m0 kf ks' instance Applicative Get where pure = return (<*>) = ap instance Alternative Get where empty = failDesc "empty" (<|>) = mplus -- Definition directly from Control.Monad.State.Strict instance Monad Get where return a = Get $ \ s0 b0 m0 _ ks -> ks s0 b0 m0 a m >>= g = Get $ \s0 b0 m0 kf ks -> let ks' s1 b1 m1 a = unGet (g a) s1 b1 m1 kf ks in unGet m s0 b0 m0 kf ks' fail = failDesc instance MonadPlus Get where mzero = failDesc "mzero" mplus a b = Get $ \s0 b0 m0 kf ks -> let kf' _ b1 m1 _ _ = unGet b (s0 `B.append` bufferBytes b1) (b0 `append` b1) m1 kf ks in unGet a s0 (Just B.empty) m0 kf' ks ------------------------------------------------------------------------ formatTrace :: [String] -> String formatTrace [] = "Empty call stack" formatTrace ls = "From:\t" ++ intercalate "\n\t" ls ++ "\n" get :: Get B.ByteString get = Get (\s0 b0 m0 _ k -> k s0 b0 m0 s0) {-# INLINE get #-} put :: B.ByteString -> Get () put s = Get (\_ b0 m _ k -> k s b0 m ()) {-# INLINE put #-} label :: String -> Get a -> Get a label l m = Get $ \ s0 b0 m0 kf ks -> let kf' s1 b1 m1 ls = kf s1 b1 m1 (l:ls) in unGet m s0 b0 m0 kf' ks finalK :: Success a a finalK s _ _ a = Done a s failK :: Failure a failK _ _ _ ls s = Fail (unlines [s, formatTrace ls]) -- | Run the Get monad applies a 'get'-based parser on the input ByteString runGet :: Get a -> B.ByteString -> Either String a runGet m str = case unGet m str Nothing Complete failK finalK of Fail i -> Left i Done a _ -> Right a Partial{} -> Left "Failed reading: Internal error: unexpected Partial." {-# INLINE runGet #-} -- | Run the Get monad applies a 'get'-based parser on the input ByteString runGetPartial :: Get a -> B.ByteString -> Result a runGetPartial m str = unGet m str Nothing (Incomplete Nothing) failK finalK {-# INLINE runGetPartial #-} -- | Run the Get monad applies a 'get'-based parser on the input -- ByteString. Additional to the result of get it returns the number of -- consumed bytes and the rest of the input. runGetState :: Get a -> B.ByteString -> Int -> Either String (a, B.ByteString) runGetState m str off = case unGet m (B.drop off str) Nothing Complete failK finalK of Fail i -> Left i Done a bs -> Right (a, bs) Partial{} -> Left "Failed reading: Internal error: unexpected Partial." {-# INLINE runGetState #-} -- Lazy Get -------------------------------------------------------------------- runGetLazy' :: Get a -> L.ByteString -> (Either String a,L.ByteString) runGetLazy' m lstr = loop run (L.toChunks lstr) where remLen c = fromIntegral (L.length lstr) - B.length c run str = unGet m str Nothing (Incomplete (Just (remLen str))) failK finalK loop k chunks = case chunks of c:cs -> case k c of Fail str -> (Left str,L.empty) Partial k' -> loop k' cs Done r c' -> (Right r,L.fromChunks (c':cs)) [] -> case k B.empty of Fail str -> (Left str,L.empty) Partial k' -> (Left "Failed reading: Internal error: unexpected end of input",L.empty) Done r c' -> (Right r,L.empty) {-# INLINE runGetLazy' #-} -- | Run the Get monad over a Lazy ByteString. Note that this will not run the -- Get parser lazily, but will operate on lazy ByteStrings. runGetLazy :: Get a -> L.ByteString -> Either String a runGetLazy m lstr = fst (runGetLazy' m lstr) {-# INLINE runGetLazy #-} -- | Run the Get monad over a Lazy ByteString. Note that this does not run the -- Get parser lazily, but will operate on lazy ByteStrings. runGetLazyState :: Get a -> L.ByteString -> Either String (a,L.ByteString) runGetLazyState m lstr = case runGetLazy' m lstr of (Right a,rest) -> Right (a,rest) (Left err,_) -> Left err {-# INLINE runGetLazyState #-} ------------------------------------------------------------------------ -- | If at least @n@ bytes of input are available, return the current -- input, otherwise fail. ensure :: Int -> Get B.ByteString ensure n = n `seq` Get $ \ s0 b0 m0 kf ks -> if B.length s0 >= n then ks s0 b0 m0 s0 else unGet (demandInput >> ensureRec n) s0 b0 m0 kf ks {-# INLINE ensure #-} -- | If at least @n@ bytes of input are available, return the current -- input, otherwise fail. ensureRec :: Int -> Get B.ByteString ensureRec n = Get $ \s0 b0 m0 kf ks -> if B.length s0 >= n then ks s0 b0 m0 s0 else unGet (demandInput >> ensureRec n) s0 b0 m0 kf ks -- | Isolate an action to operating within a fixed block of bytes. The action -- is required to consume all the bytes that it is isolated to. isolate :: Int -> Get a -> Get a isolate n m = do when (n < 0) (fail "Attempted to isolate a negative number of bytes") s <- ensure n let (s',rest) = B.splitAt n s put s' a <- m used <- get unless (B.null used) (fail "not all bytes parsed in isolate") put rest return a -- | Immediately demand more input via a 'Partial' continuation -- result. demandInput :: Get () demandInput = Get $ \s0 b0 m0 kf ks -> case m0 of Complete -> kf s0 b0 m0 ["demandInput"] "too few bytes" Incomplete mb -> Partial $ \s -> if B.null s then kf s0 b0 m0 ["demandInput"] "too few bytes" else let update l = l - B.length s s1 = s0 `B.append` s b1 = b0 `append` Just s in ks s1 b1 (Incomplete (update `fmap` mb)) () failDesc :: String -> Get a failDesc err = do let msg = "Failed reading: " ++ err Get (\s0 b0 m0 kf _ -> kf s0 b0 m0 [] msg) -- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available. skip :: Int -> Get () skip n = do s <- ensure n put (B.drop n s) -- | Skip ahead @n@ bytes. No error if there isn't enough bytes. uncheckedSkip :: Int -> Get () uncheckedSkip n = do s <- get put (B.drop n s) -- | Run @ga@, but return without consuming its input. -- Fails if @ga@ fails. lookAhead :: Get a -> Get a lookAhead ga = Get $ \ s0 b0 m0 kf ks -> let ks' _s1 b1 = ks (s0 `B.append` bufferBytes b1) (b0 `append` b1) in unGet ga s0 (Just B.empty) m0 kf ks' -- | Like 'lookAhead', but consume the input if @gma@ returns 'Just _'. -- Fails if @gma@ fails. lookAheadM :: Get (Maybe a) -> Get (Maybe a) lookAheadM gma = do s <- get ma <- gma when (isNothing ma) (put s) return ma -- | Like 'lookAhead', but consume the input if @gea@ returns 'Right _'. -- Fails if @gea@ fails. lookAheadE :: Get (Either a b) -> Get (Either a b) lookAheadE gea = do s <- get ea <- gea case ea of Left _ -> put s _ -> return () return ea -- | Get the next up to @n@ bytes as a ByteString, without consuming them. uncheckedLookAhead :: Int -> Get B.ByteString uncheckedLookAhead n = do s <- get return (B.take n s) ------------------------------------------------------------------------ -- Utility -- | Get the number of remaining unparsed bytes. Useful for checking whether -- all input has been consumed. -- -- WARNING: when run with @runGetPartial@, remaining will only return the number -- of bytes that are remaining in the current input. remaining :: Get Int remaining = Get (\ s0 b0 m0 _ ks -> ks s0 b0 m0 (B.length s0 + moreLength m0)) -- | Test whether all input has been consumed. -- -- WARNING: when run with @runGetPartial@, isEmpty will only tell you if you're -- at the end of the current chunk. isEmpty :: Get Bool isEmpty = Get (\ s0 b0 m0 _ ks -> ks s0 b0 m0 (B.null s0 && moreLength m0 == 0)) ------------------------------------------------------------------------ -- Utility with ByteStrings -- | An efficient 'get' method for strict ByteStrings. Fails if fewer -- than @n@ bytes are left in the input. This function creates a fresh -- copy of the underlying bytes. getByteString :: Int -> Get B.ByteString getByteString n = do bs <- getBytes n return $! B.copy bs getLazyByteString :: Int64 -> Get L.ByteString getLazyByteString n = f `fmap` getByteString (fromIntegral n) where f bs = L.fromChunks [bs] ------------------------------------------------------------------------ -- Helpers -- | Pull @n@ bytes from the input, as a strict ByteString. getBytes :: Int -> Get B.ByteString getBytes n | n < 0 = fail "getBytes: negative length requested" getBytes n = do s <- ensure n let consume = B.unsafeTake n s rest = B.unsafeDrop n s -- (consume,rest) = B.splitAt n s put rest return consume {-# INLINE getBytes #-} ------------------------------------------------------------------------ -- Primtives -- helper, get a raw Ptr onto a strict ByteString copied out of the -- underlying strict byteString. getPtr :: Storable a => Int -> Get a getPtr n = do (fp,o,_) <- B.toForeignPtr `fmap` getBytes n let k p = peek (castPtr (p `plusPtr` o)) return (B.inlinePerformIO (withForeignPtr fp k)) {-# INLINE getPtr #-} ------------------------------------------------------------------------ -- | Read a Word8 from the monad state getWord8 :: Get Word8 getWord8 = getPtr (sizeOf (undefined :: Word8)) -- | Read a Word16 in big endian format getWord16be :: Get Word16 getWord16be = do s <- getBytes 2 return $! (fromIntegral (s `B.index` 0) `shiftl_w16` 8) .|. (fromIntegral (s `B.index` 1)) -- | Read a Word16 in little endian format getWord16le :: Get Word16 getWord16le = do s <- getBytes 2 return $! (fromIntegral (s `B.index` 1) `shiftl_w16` 8) .|. (fromIntegral (s `B.index` 0) ) -- | Read a Word32 in big endian format getWord32be :: Get Word32 getWord32be = do s <- getBytes 4 return $! (fromIntegral (s `B.index` 0) `shiftl_w32` 24) .|. (fromIntegral (s `B.index` 1) `shiftl_w32` 16) .|. (fromIntegral (s `B.index` 2) `shiftl_w32` 8) .|. (fromIntegral (s `B.index` 3) ) -- | Read a Word32 in little endian format getWord32le :: Get Word32 getWord32le = do s <- getBytes 4 return $! (fromIntegral (s `B.index` 3) `shiftl_w32` 24) .|. (fromIntegral (s `B.index` 2) `shiftl_w32` 16) .|. (fromIntegral (s `B.index` 1) `shiftl_w32` 8) .|. (fromIntegral (s `B.index` 0) ) -- | Read a Word64 in big endian format getWord64be :: Get Word64 getWord64be = do s <- getBytes 8 return $! (fromIntegral (s `B.index` 0) `shiftl_w64` 56) .|. (fromIntegral (s `B.index` 1) `shiftl_w64` 48) .|. (fromIntegral (s `B.index` 2) `shiftl_w64` 40) .|. (fromIntegral (s `B.index` 3) `shiftl_w64` 32) .|. (fromIntegral (s `B.index` 4) `shiftl_w64` 24) .|. (fromIntegral (s `B.index` 5) `shiftl_w64` 16) .|. (fromIntegral (s `B.index` 6) `shiftl_w64` 8) .|. (fromIntegral (s `B.index` 7) ) -- | Read a Word64 in little endian format getWord64le :: Get Word64 getWord64le = do s <- getBytes 8 return $! (fromIntegral (s `B.index` 7) `shiftl_w64` 56) .|. (fromIntegral (s `B.index` 6) `shiftl_w64` 48) .|. (fromIntegral (s `B.index` 5) `shiftl_w64` 40) .|. (fromIntegral (s `B.index` 4) `shiftl_w64` 32) .|. (fromIntegral (s `B.index` 3) `shiftl_w64` 24) .|. (fromIntegral (s `B.index` 2) `shiftl_w64` 16) .|. (fromIntegral (s `B.index` 1) `shiftl_w64` 8) .|. (fromIntegral (s `B.index` 0) ) ------------------------------------------------------------------------ -- Host-endian reads -- | /O(1)./ Read a single native machine word. The word is read in -- host order, host endian form, for the machine you're on. On a 64 bit -- machine the Word is an 8 byte value, on a 32 bit machine, 4 bytes. getWordhost :: Get Word getWordhost = getPtr (sizeOf (undefined :: Word)) -- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness. getWord16host :: Get Word16 getWord16host = getPtr (sizeOf (undefined :: Word16)) -- | /O(1)./ Read a Word32 in native host order and host endianness. getWord32host :: Get Word32 getWord32host = getPtr (sizeOf (undefined :: Word32)) -- | /O(1)./ Read a Word64 in native host order and host endianess. getWord64host :: Get Word64 getWord64host = getPtr (sizeOf (undefined :: Word64)) ------------------------------------------------------------------------ -- Unchecked shifts shiftl_w16 :: Word16 -> Int -> Word16 shiftl_w32 :: Word32 -> Int -> Word32 shiftl_w64 :: Word64 -> Int -> Word64 #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i) shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i) #if WORD_SIZE_IN_BITS < 64 shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i) #if __GLASGOW_HASKELL__ <= 606 -- Exported by GHC.Word in GHC 6.8 and higher foreign import ccall unsafe "stg_uncheckedShiftL64" uncheckedShiftL64# :: Word64# -> Int# -> Word64# #endif #else shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i) #endif #else shiftl_w16 = shiftL shiftl_w32 = shiftL shiftl_w64 = shiftL #endif -- Containers ------------------------------------------------------------------ getTwoOf :: Get a -> Get b -> Get (a,b) getTwoOf ma mb = liftM2 (,) ma mb -- | Get a list in the following format: -- Word64 (big endian format) -- element 1 -- ... -- element n getListOf :: Get a -> Get [a] getListOf m = go [] =<< getWord64be where go as 0 = return (reverse as) go as i = do x <- m x `seq` go (x:as) (i - 1) -- | Get an IArray in the following format: -- index (lower bound) -- index (upper bound) -- Word64 (big endian format) -- element 1 -- ... -- element n getIArrayOf :: (Ix i, IArray a e) => Get i -> Get e -> Get (a i e) getIArrayOf ix e = liftM2 listArray (getTwoOf ix ix) (getListOf e) -- | Get a sequence in the following format: -- Word64 (big endian format) -- element 1 -- ... -- element n getSeqOf :: Get a -> Get (Seq.Seq a) getSeqOf m = go Seq.empty =<< getWord64be where go xs 0 = return $! xs go xs n = xs `seq` n `seq` do x <- m go (xs Seq.|> x) (n - 1) -- | Read as a list of lists. getTreeOf :: Get a -> Get (T.Tree a) getTreeOf m = liftM2 T.Node m (getListOf (getTreeOf m)) -- | Read as a list of pairs of key and element. getMapOf :: Ord k => Get k -> Get a -> Get (Map.Map k a) getMapOf k m = Map.fromDistinctAscList `fmap` getListOf (getTwoOf k m) -- | Read as a list of pairs of int and element. getIntMapOf :: Get Int -> Get a -> Get (IntMap.IntMap a) getIntMapOf i m = IntMap.fromDistinctAscList `fmap` getListOf (getTwoOf i m) -- | Read as a list of elements. getSetOf :: Ord a => Get a -> Get (Set.Set a) getSetOf m = Set.fromDistinctAscList `fmap` getListOf m -- | Read as a list of ints. getIntSetOf :: Get Int -> Get IntSet.IntSet getIntSetOf m = IntSet.fromDistinctAscList `fmap` getListOf m -- | Read in a Maybe in the following format: -- Word8 (0 for Nothing, anything else for Just) -- element (when Just) getMaybeOf :: Get a -> Get (Maybe a) getMaybeOf m = do tag <- getWord8 case tag of 0 -> return Nothing _ -> Just `fmap` m -- | Read an Either, in the following format: -- Word8 (0 for Left, anything else for Right) -- element a when 0, element b otherwise getEitherOf :: Get a -> Get b -> Get (Either a b) getEitherOf ma mb = do tag <- getWord8 case tag of 0 -> Left `fmap` ma _ -> Right `fmap` mb cereal-0.3.5.2/src/Data/Serialize/IEEE754.hs0000644000000000000000000000434311763507414016206 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} -- | IEEE-754 parsing, as described in this stack-overflow article: -- -- http://stackoverflow.com/questions/6976684/converting-ieee-754-floating-point-in-haskell-word32-64-to-and-from-haskell-float/7002812#7002812 module Data.Serialize.IEEE754 ( -- * IEEE-754 reads getFloat32le , getFloat32be , getFloat64le , getFloat64be -- * IEEE-754 writes , putFloat32le , putFloat32be , putFloat64le , putFloat64be ) where import Control.Applicative ( (<$>) ) import Control.Monad.ST ( runST, ST ) import Data.Array.ST ( newArray, castSTUArray, readArray, MArray, STUArray ) import Data.Word ( Word32, Word64 ) import Data.Serialize.Get import Data.Serialize.Put -- | Read a Float in little endian IEEE-754 format getFloat32le :: Get Float getFloat32le = wordToFloat <$> getWord32le -- | Read a Float in big endian IEEE-754 format getFloat32be :: Get Float getFloat32be = wordToFloat <$> getWord32be -- | Read a Double in little endian IEEE-754 format getFloat64le :: Get Double getFloat64le = wordToDouble <$> getWord64le -- | Read a Double in big endian IEEE-754 format getFloat64be :: Get Double getFloat64be = wordToDouble <$> getWord64be -- | Write a Float in little endian IEEE-754 format putFloat32le :: Float -> Put putFloat32le = putWord32le . floatToWord -- | Write a Float in big endian IEEE-754 format putFloat32be :: Float -> Put putFloat32be = putWord32be . floatToWord -- | Write a Double in little endian IEEE-754 format putFloat64le :: Double -> Put putFloat64le = putWord64le . doubleToWord -- | Write a Double in big endian IEEE-754 format putFloat64be :: Double -> Put putFloat64be = putWord64be . doubleToWord {-# INLINE wordToFloat #-} wordToFloat :: Word32 -> Float wordToFloat x = runST (cast x) {-# INLINE floatToWord #-} floatToWord :: Float -> Word32 floatToWord x = runST (cast x) {-# INLINE wordToDouble #-} wordToDouble :: Word64 -> Double wordToDouble x = runST (cast x) {-# INLINE doubleToWord #-} doubleToWord :: Double -> Word64 doubleToWord x = runST (cast x) {-# INLINE cast #-} cast :: (MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) => a -> ST s b cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0 cereal-0.3.5.2/src/Data/Serialize/Builder.hs0000644000000000000000000003602111763507414016623 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -- for unboxed shifts ----------------------------------------------------------------------------- -- | -- Module : Data.Serialize.Builder -- Copyright : Lennart Kolmodin, Ross Paterson, Galois Inc. 2009 -- License : BSD3-style (see LICENSE) -- -- Maintainer : Trevor Elliott -- Stability : -- Portability : -- -- Efficient construction of lazy bytestrings. -- ----------------------------------------------------------------------------- #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) #include "MachDeps.h" #endif module Data.Serialize.Builder ( -- * The Builder type Builder , toByteString , toLazyByteString -- * Constructing Builders , empty , singleton , append , fromByteString -- :: S.ByteString -> Builder , fromLazyByteString -- :: L.ByteString -> Builder -- * Flushing the buffer state , flush -- * Derived Builders -- ** Big-endian writes , putWord16be -- :: Word16 -> Builder , putWord32be -- :: Word32 -> Builder , putWord64be -- :: Word64 -> Builder -- ** Little-endian writes , putWord16le -- :: Word16 -> Builder , putWord32le -- :: Word32 -> Builder , putWord64le -- :: Word64 -> Builder -- ** Host-endian, unaligned writes , putWordhost -- :: Word -> Builder , putWord16host -- :: Word16 -> Builder , putWord32host -- :: Word32 -> Builder , putWord64host -- :: Word64 -> Builder ) where import Data.Monoid import Data.Word import Foreign.ForeignPtr import Foreign.Ptr (Ptr,plusPtr) import Foreign.Storable import System.IO.Unsafe (unsafePerformIO) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Internal as S #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) import GHC.Base import GHC.Word (Word32(..),Word16(..),Word64(..)) #if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608 import GHC.Word (uncheckedShiftRL64#) #endif #else import Data.Word #endif ------------------------------------------------------------------------ -- | A 'Builder' is an efficient way to build lazy 'L.ByteString's. -- There are several functions for constructing 'Builder's, but only one -- to inspect them: to extract any data, you have to turn them into lazy -- 'L.ByteString's using 'toLazyByteString'. -- -- Internally, a 'Builder' constructs a lazy 'L.Bytestring' by filling byte -- arrays piece by piece. As each buffer is filled, it is \'popped\' -- off, to become a new chunk of the resulting lazy 'L.ByteString'. -- All this is hidden from the user of the 'Builder'. newtype Builder = Builder { -- Invariant (from Data.ByteString.Lazy): -- The lists include no null ByteStrings. runBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString] } instance Monoid Builder where mempty = empty {-# INLINE mempty #-} mappend = append {-# INLINE mappend #-} ------------------------------------------------------------------------ -- | /O(1)./ The empty Builder, satisfying -- -- * @'toLazyByteString' 'empty' = 'L.empty'@ -- empty :: Builder empty = Builder id {-# INLINE empty #-} -- | /O(1)./ A Builder taking a single byte, satisfying -- -- * @'toLazyByteString' ('singleton' b) = 'L.singleton' b@ -- singleton :: Word8 -> Builder singleton = writeN 1 . flip poke {-# INLINE singleton #-} ------------------------------------------------------------------------ -- | /O(1)./ The concatenation of two Builders, an associative operation -- with identity 'empty', satisfying -- -- * @'toLazyByteString' ('append' x y) = 'L.append' ('toLazyByteString' x) ('toLazyByteString' y)@ -- append :: Builder -> Builder -> Builder append (Builder f) (Builder g) = Builder (f . g) {-# INLINE append #-} -- | /O(1)./ A Builder taking a 'S.ByteString', satisfying -- -- * @'toLazyByteString' ('fromByteString' bs) = 'L.fromChunks' [bs]@ -- fromByteString :: S.ByteString -> Builder fromByteString bs | S.null bs = empty | otherwise = flush `append` mapBuilder (bs :) {-# INLINE fromByteString #-} -- | /O(1)./ A Builder taking a lazy 'L.ByteString', satisfying -- -- * @'toLazyByteString' ('fromLazyByteString' bs) = bs@ -- fromLazyByteString :: L.ByteString -> Builder fromLazyByteString bss = flush `append` mapBuilder (L.toChunks bss ++) {-# INLINE fromLazyByteString #-} ------------------------------------------------------------------------ -- Our internal buffer type data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8) {-# UNPACK #-} !Int -- offset {-# UNPACK #-} !Int -- used bytes {-# UNPACK #-} !Int -- length left ------------------------------------------------------------------------ toByteString :: Builder -> S.ByteString toByteString m = S.concat $ unsafePerformIO $ do buf <- newBuffer defaultSize return (runBuilder (m `append` flush) (const []) buf) -- | /O(n)./ Extract a lazy 'L.ByteString' from a 'Builder'. -- The construction work takes place if and when the relevant part of -- the lazy 'L.ByteString' is demanded. -- toLazyByteString :: Builder -> L.ByteString toLazyByteString m = L.fromChunks $ unsafePerformIO $ do buf <- newBuffer defaultSize return (runBuilder (m `append` flush) (const []) buf) -- | /O(1)./ Pop the 'S.ByteString' we have constructed so far, if any, -- yielding a new chunk in the result lazy 'L.ByteString'. flush :: Builder flush = Builder $ \ k buf@(Buffer p o u l) -> if u == 0 then k buf else S.PS p o u : k (Buffer p (o+u) 0 l) ------------------------------------------------------------------------ -- -- copied from Data.ByteString.Lazy -- defaultSize :: Int defaultSize = 32 * k - overhead where k = 1024 overhead = 2 * sizeOf (undefined :: Int) ------------------------------------------------------------------------ -- | Sequence an IO operation on the buffer unsafeLiftIO :: (Buffer -> IO Buffer) -> Builder unsafeLiftIO f = Builder $ \ k buf -> S.inlinePerformIO $ do buf' <- f buf return (k buf') {-# INLINE unsafeLiftIO #-} -- | Get the size of the buffer withSize :: (Int -> Builder) -> Builder withSize f = Builder $ \ k buf@(Buffer _ _ _ l) -> runBuilder (f l) k buf -- | Map the resulting list of bytestrings. mapBuilder :: ([S.ByteString] -> [S.ByteString]) -> Builder mapBuilder f = Builder (f .) ------------------------------------------------------------------------ -- | Ensure that there are at least @n@ many bytes available. ensureFree :: Int -> Builder ensureFree n = n `seq` withSize $ \ l -> if n <= l then empty else flush `append` unsafeLiftIO (const (newBuffer (max n defaultSize))) {-# INLINE ensureFree #-} -- | Ensure that @n@ many bytes are available, and then use @f@ to write some -- bytes into the memory. writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder writeN n f = ensureFree n `append` unsafeLiftIO (writeNBuffer n f) {-# INLINE writeN #-} writeNBuffer :: Int -> (Ptr Word8 -> IO ()) -> Buffer -> IO Buffer writeNBuffer n f (Buffer fp o u l) = do withForeignPtr fp (\p -> f (p `plusPtr` (o+u))) return (Buffer fp o (u+n) (l-n)) {-# INLINE writeNBuffer #-} newBuffer :: Int -> IO Buffer newBuffer size = do fp <- S.mallocByteString size return $! Buffer fp 0 0 size {-# INLINE newBuffer #-} ------------------------------------------------------------------------ -- Aligned, host order writes of storable values -- | Ensure that @n@ many bytes are available, and then use @f@ to write some -- storable values into the memory. writeNbytes :: Storable a => Int -> (Ptr a -> IO ()) -> Builder writeNbytes n f = ensureFree n `append` unsafeLiftIO (writeNBufferBytes n f) {-# INLINE writeNbytes #-} writeNBufferBytes :: Storable a => Int -> (Ptr a -> IO ()) -> Buffer -> IO Buffer writeNBufferBytes n f (Buffer fp o u l) = do withForeignPtr fp (\p -> f (p `plusPtr` (o+u))) return (Buffer fp o (u+n) (l-n)) {-# INLINE writeNBufferBytes #-} ------------------------------------------------------------------------ -- -- We rely on the fromIntegral to do the right masking for us. -- The inlining here is critical, and can be worth 4x performance -- -- | Write a Word16 in big endian format putWord16be :: Word16 -> Builder putWord16be w = writeN 2 $ \p -> do poke p (fromIntegral (shiftr_w16 w 8) :: Word8) poke (p `plusPtr` 1) (fromIntegral (w) :: Word8) {-# INLINE putWord16be #-} -- | Write a Word16 in little endian format putWord16le :: Word16 -> Builder putWord16le w = writeN 2 $ \p -> do poke p (fromIntegral (w) :: Word8) poke (p `plusPtr` 1) (fromIntegral (shiftr_w16 w 8) :: Word8) {-# INLINE putWord16le #-} -- putWord16le w16 = writeN 2 (\p -> poke (castPtr p) w16) -- | Write a Word32 in big endian format putWord32be :: Word32 -> Builder putWord32be w = writeN 4 $ \p -> do poke p (fromIntegral (shiftr_w32 w 24) :: Word8) poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8) poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 8) :: Word8) poke (p `plusPtr` 3) (fromIntegral (w) :: Word8) {-# INLINE putWord32be #-} -- -- a data type to tag Put/Check. writes construct these which are then -- inlined and flattened. matching Checks will be more robust with rules. -- -- | Write a Word32 in little endian format putWord32le :: Word32 -> Builder putWord32le w = writeN 4 $ \p -> do poke p (fromIntegral (w) :: Word8) poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 8) :: Word8) poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 16) :: Word8) poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 w 24) :: Word8) {-# INLINE putWord32le #-} -- on a little endian machine: -- putWord32le w32 = writeN 4 (\p -> poke (castPtr p) w32) -- | Write a Word64 in big endian format putWord64be :: Word64 -> Builder #if WORD_SIZE_IN_BITS < 64 -- -- To avoid expensive 64 bit shifts on 32 bit machines, we cast to -- Word32, and write that -- putWord64be w = let a = fromIntegral (shiftr_w64 w 32) :: Word32 b = fromIntegral w :: Word32 in writeN 8 $ \p -> do poke p (fromIntegral (shiftr_w32 a 24) :: Word8) poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 16) :: Word8) poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 8) :: Word8) poke (p `plusPtr` 3) (fromIntegral (a) :: Word8) poke (p `plusPtr` 4) (fromIntegral (shiftr_w32 b 24) :: Word8) poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 16) :: Word8) poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 8) :: Word8) poke (p `plusPtr` 7) (fromIntegral (b) :: Word8) #else putWord64be w = writeN 8 $ \p -> do poke p (fromIntegral (shiftr_w64 w 56) :: Word8) poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 48) :: Word8) poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 40) :: Word8) poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 32) :: Word8) poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 24) :: Word8) poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 16) :: Word8) poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 8) :: Word8) poke (p `plusPtr` 7) (fromIntegral (w) :: Word8) #endif {-# INLINE putWord64be #-} -- | Write a Word64 in little endian format putWord64le :: Word64 -> Builder #if WORD_SIZE_IN_BITS < 64 putWord64le w = let b = fromIntegral (shiftr_w64 w 32) :: Word32 a = fromIntegral w :: Word32 in writeN 8 $ \p -> do poke (p) (fromIntegral (a) :: Word8) poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 8) :: Word8) poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 16) :: Word8) poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 a 24) :: Word8) poke (p `plusPtr` 4) (fromIntegral (b) :: Word8) poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 8) :: Word8) poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 16) :: Word8) poke (p `plusPtr` 7) (fromIntegral (shiftr_w32 b 24) :: Word8) #else putWord64le w = writeN 8 $ \p -> do poke p (fromIntegral (w) :: Word8) poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 8) :: Word8) poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 16) :: Word8) poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 24) :: Word8) poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 32) :: Word8) poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 40) :: Word8) poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 48) :: Word8) poke (p `plusPtr` 7) (fromIntegral (shiftr_w64 w 56) :: Word8) #endif {-# INLINE putWord64le #-} -- on a little endian machine: -- putWord64le w64 = writeN 8 (\p -> poke (castPtr p) w64) ------------------------------------------------------------------------ -- Unaligned, word size ops -- | /O(1)./ A Builder taking a single native machine word. The word is -- written in host order, host endian form, for the machine you're on. -- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine, -- 4 bytes. Values written this way are not portable to -- different endian or word sized machines, without conversion. -- putWordhost :: Word -> Builder putWordhost w = writeNbytes (sizeOf (undefined :: Word)) (\p -> poke p w) {-# INLINE putWordhost #-} -- | Write a Word16 in native host order and host endianness. -- 2 bytes will be written, unaligned. putWord16host :: Word16 -> Builder putWord16host w16 = writeNbytes (sizeOf (undefined :: Word16)) (\p -> poke p w16) {-# INLINE putWord16host #-} -- | Write a Word32 in native host order and host endianness. -- 4 bytes will be written, unaligned. putWord32host :: Word32 -> Builder putWord32host w32 = writeNbytes (sizeOf (undefined :: Word32)) (\p -> poke p w32) {-# INLINE putWord32host #-} -- | Write a Word64 in native host order. -- On a 32 bit machine we write two host order Word32s, in big endian form. -- 8 bytes will be written, unaligned. putWord64host :: Word64 -> Builder putWord64host w = writeNbytes (sizeOf (undefined :: Word64)) (\p -> poke p w) {-# INLINE putWord64host #-} ------------------------------------------------------------------------ -- Unchecked shifts {-# INLINE shiftr_w16 #-} shiftr_w16 :: Word16 -> Int -> Word16 {-# INLINE shiftr_w32 #-} shiftr_w32 :: Word32 -> Int -> Word32 {-# INLINE shiftr_w64 #-} shiftr_w64 :: Word64 -> Int -> Word64 #if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i) shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) #if WORD_SIZE_IN_BITS < 64 shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i) #if __GLASGOW_HASKELL__ <= 606 -- Exported by GHC.Word in GHC 6.8 and higher foreign import ccall unsafe "stg_uncheckedShiftRL64" uncheckedShiftRL64# :: Word64# -> Int# -> Word64# #endif #else shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i) #endif #else shiftr_w16 = shiftR shiftr_w32 = shiftR shiftr_w64 = shiftR #endif cereal-0.3.5.2/src/Data/Serialize/Put.hs0000644000000000000000000002144511763507414016011 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Data.Serialize.Put -- Copyright : Lennart Kolmodin, Galois Inc. 2009 -- License : BSD3-style (see LICENSE) -- -- Maintainer : Trevor Elliott -- Stability : -- Portability : -- -- The Put monad. A monad for efficiently constructing bytestrings. -- ----------------------------------------------------------------------------- module Data.Serialize.Put ( -- * The Put type Put , PutM(..) , Putter , runPut , runPutM , runPutLazy , runPutMLazy , putBuilder , execPut -- * Flushing the implicit parse state , flush -- * Primitives , putWord8 , putByteString , putLazyByteString -- * Big-endian primitives , putWord16be , putWord32be , putWord64be -- * Little-endian primitives , putWord16le , putWord32le , putWord64le -- * Host-endian, unaligned writes , putWordhost , putWord16host , putWord32host , putWord64host -- * Containers , putTwoOf , putListOf , putIArrayOf , putSeqOf , putTreeOf , putMapOf , putIntMapOf , putSetOf , putIntSetOf , putMaybeOf , putEitherOf ) where import Data.Serialize.Builder (Builder, toByteString, toLazyByteString) import qualified Data.Serialize.Builder as B import Control.Applicative import Data.Array.Unboxed import Data.Monoid import Data.Foldable (foldMap) import Data.Word import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.IntMap as IntMap import qualified Data.IntSet as IntSet import qualified Data.Map as Map import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Tree as T ------------------------------------------------------------------------ -- XXX Strict in builder only. data PairS a = PairS a !Builder sndS :: PairS a -> Builder sndS (PairS _ b) = b -- | The PutM type. A Writer monad over the efficient Builder monoid. newtype PutM a = Put { unPut :: PairS a } -- | Put merely lifts Builder into a Writer monad, applied to (). type Put = PutM () type Putter a = a -> Put instance Functor PutM where fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w {-# INLINE fmap #-} instance Applicative PutM where pure = return {-# INLINE pure #-} m <*> k = Put $ let PairS f w = unPut m PairS x w' = unPut k in PairS (f x) (w `mappend` w') {-# INLINE (<*>) #-} instance Monad PutM where return a = Put (PairS a mempty) {-# INLINE return #-} m >>= k = Put $ let PairS a w = unPut m PairS b w' = unPut (k a) in PairS b (w `mappend` w') {-# INLINE (>>=) #-} m >> k = Put $ let PairS _ w = unPut m PairS b w' = unPut k in PairS b (w `mappend` w') {-# INLINE (>>) #-} tell :: Putter Builder tell b = Put $ PairS () b {-# INLINE tell #-} putBuilder :: Putter Builder putBuilder = tell {-# INLINE putBuilder #-} -- | Run the 'Put' monad execPut :: PutM a -> Builder execPut = sndS . unPut {-# INLINE execPut #-} -- | Run the 'Put' monad with a serialiser runPut :: Put -> S.ByteString runPut = toByteString . sndS . unPut {-# INLINE runPut #-} -- | Run the 'Put' monad with a serialiser and get its result runPutM :: PutM a -> (a, S.ByteString) runPutM (Put (PairS f s)) = (f, toByteString s) {-# INLINE runPutM #-} -- | Run the 'Put' monad with a serialiser runPutLazy :: Put -> L.ByteString runPutLazy = toLazyByteString . sndS . unPut {-# INLINE runPutLazy #-} -- | Run the 'Put' monad with a serialiser runPutMLazy :: PutM a -> (a, L.ByteString) runPutMLazy (Put (PairS f s)) = (f, toLazyByteString s) {-# INLINE runPutMLazy #-} ------------------------------------------------------------------------ -- | Pop the ByteString we have constructed so far, if any, yielding a -- new chunk in the result ByteString. flush :: Put flush = tell B.flush {-# INLINE flush #-} -- | Efficiently write a byte into the output buffer putWord8 :: Putter Word8 putWord8 = tell . B.singleton {-# INLINE putWord8 #-} -- | An efficient primitive to write a strict ByteString into the output buffer. -- It flushes the current buffer, and writes the argument into a new chunk. putByteString :: Putter S.ByteString putByteString = tell . B.fromByteString {-# INLINE putByteString #-} -- | Write a lazy ByteString efficiently, simply appending the lazy -- ByteString chunks to the output buffer putLazyByteString :: Putter L.ByteString putLazyByteString = tell . B.fromLazyByteString {-# INLINE putLazyByteString #-} -- | Write a Word16 in big endian format putWord16be :: Putter Word16 putWord16be = tell . B.putWord16be {-# INLINE putWord16be #-} -- | Write a Word16 in little endian format putWord16le :: Putter Word16 putWord16le = tell . B.putWord16le {-# INLINE putWord16le #-} -- | Write a Word32 in big endian format putWord32be :: Putter Word32 putWord32be = tell . B.putWord32be {-# INLINE putWord32be #-} -- | Write a Word32 in little endian format putWord32le :: Putter Word32 putWord32le = tell . B.putWord32le {-# INLINE putWord32le #-} -- | Write a Word64 in big endian format putWord64be :: Putter Word64 putWord64be = tell . B.putWord64be {-# INLINE putWord64be #-} -- | Write a Word64 in little endian format putWord64le :: Putter Word64 putWord64le = tell . B.putWord64le {-# INLINE putWord64le #-} ------------------------------------------------------------------------ -- | /O(1)./ Write a single native machine word. The word is -- written in host order, host endian form, for the machine you're on. -- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine, -- 4 bytes. Values written this way are not portable to -- different endian or word sized machines, without conversion. -- putWordhost :: Putter Word putWordhost = tell . B.putWordhost {-# INLINE putWordhost #-} -- | /O(1)./ Write a Word16 in native host order and host endianness. -- For portability issues see @putWordhost@. putWord16host :: Putter Word16 putWord16host = tell . B.putWord16host {-# INLINE putWord16host #-} -- | /O(1)./ Write a Word32 in native host order and host endianness. -- For portability issues see @putWordhost@. putWord32host :: Putter Word32 putWord32host = tell . B.putWord32host {-# INLINE putWord32host #-} -- | /O(1)./ Write a Word64 in native host order -- On a 32 bit machine we write two host order Word32s, in big endian form. -- For portability issues see @putWordhost@. putWord64host :: Putter Word64 putWord64host = tell . B.putWord64host {-# INLINE putWord64host #-} -- Containers ------------------------------------------------------------------ encodeListOf :: (a -> Builder) -> [a] -> Builder encodeListOf f = -- allow inlining with just a single argument \xs -> execPut (putWord64be (fromIntegral $ length xs)) `mappend` foldMap f xs {-# INLINE encodeListOf #-} putTwoOf :: Putter a -> Putter b -> Putter (a,b) putTwoOf pa pb (a,b) = pa a >> pb b {-# INLINE putTwoOf #-} putListOf :: Putter a -> Putter [a] putListOf pa = tell . encodeListOf (execPut . pa) {-# INLINE putListOf #-} putIArrayOf :: (Ix i, IArray a e) => Putter i -> Putter e -> Putter (a i e) putIArrayOf pix pe a = do putTwoOf pix pix (bounds a) putListOf pe (elems a) {-# INLINE putIArrayOf #-} putSeqOf :: Putter a -> Putter (Seq.Seq a) putSeqOf pa = \s -> do putWord64be (fromIntegral $ Seq.length s) tell (foldMap (execPut . pa) s) {-# INLINE putSeqOf #-} putTreeOf :: Putter a -> Putter (T.Tree a) putTreeOf pa = tell . go where go (T.Node x cs) = execPut (pa x) `mappend` encodeListOf go cs {-# INLINE putTreeOf #-} putMapOf :: Ord k => Putter k -> Putter a -> Putter (Map.Map k a) putMapOf pk pa = putListOf (putTwoOf pk pa) . Map.toAscList {-# INLINE putMapOf #-} putIntMapOf :: Putter Int -> Putter a -> Putter (IntMap.IntMap a) putIntMapOf pix pa = putListOf (putTwoOf pix pa) . IntMap.toAscList {-# INLINE putIntMapOf #-} putSetOf :: Putter a -> Putter (Set.Set a) putSetOf pa = putListOf pa . Set.toAscList {-# INLINE putSetOf #-} putIntSetOf :: Putter Int -> Putter IntSet.IntSet putIntSetOf pix = putListOf pix . IntSet.toAscList {-# INLINE putIntSetOf #-} putMaybeOf :: Putter a -> Putter (Maybe a) putMaybeOf _ Nothing = putWord8 0 putMaybeOf pa (Just a) = putWord8 1 >> pa a {-# INLINE putMaybeOf #-} putEitherOf :: Putter a -> Putter b -> Putter (Either a b) putEitherOf pa _ (Left a) = putWord8 0 >> pa a putEitherOf _ pb (Right b) = putWord8 1 >> pb b {-# INLINE putEitherOf #-}