bspack (empty) → 0.0.1
raw patch · 5 files changed
+304/−0 lines, 5 filesdep +basedep +bspackdep +bytestringsetup-changed
Dependencies added: base, bspack, bytestring, mtl, tasty, tasty-hunit, tasty-quickcheck
Files
- Data/ByteString/Pack.hs +155/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- Tests/Tests.hs +76/−0
- bspack.cabal +41/−0
+ Data/ByteString/Pack.hs view
@@ -0,0 +1,155 @@+-- |+-- Module : Data.ByteString.Pack+-- License : BSD-Style+-- Copyright : Copyright © 2014 Nicolas DI PRIMA+--+-- Maintainer : Nicolas DI PRIMA <nicolas@di-prima.fr>+-- Stability : experimental+-- Portability : unknown+--+module Data.ByteString.Pack+ ( Packer+ , Result(..)+ , pack+ -- * Operations+ -- ** put+ , putStorable+ , putByteString+ , fillList+ , fillUpWith+ -- ** skip+ , skip+ , skipStorable+ ) where++import Data.ByteString.Internal (ByteString(..))+import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as B+import Control.Applicative+import Data.Word+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr+import Foreign.Storable+import System.IO.Unsafe (unsafePerformIO)++-- A little cache to update the data+data Cache = Cache {-# UNPACK #-} !(Ptr Word8) -- pointer in the bytestring+ {-# UNPACK #-} !Int -- remaining size++instance Show Cache where+ show (Cache _ l) = show l++-- | Packing result:+--+-- * PackerOK a -> means the bytestring has been filled with the given data+-- * PackerMore a cache -> a temporary +data Result a =+ PackerMore a Cache+ | PackerFail String+ deriving (Show)++-- | Simple Bytestring Packer+newtype Packer a = Packer { runPacker_ :: Cache -> IO (Result a) }++instance Functor Packer where+ fmap = fmapPacker++instance Applicative Packer where+ pure = returnPacker+ (<*>) = appendPacker++instance Monad Packer where+ return = returnPacker+ (>>=) = bindPacker++fmapPacker :: (a -> b) -> Packer a -> Packer b+fmapPacker f p = Packer $ \cache -> do+ rv <- runPacker_ p cache+ return $ case rv of+ PackerMore v cache' -> PackerMore (f v) cache'+ PackerFail err -> PackerFail err++returnPacker :: a -> Packer a+returnPacker v = Packer $ \cache -> return $ PackerMore v cache++bindPacker :: Packer a -> (a -> Packer b) -> Packer b+bindPacker p fp = Packer $ \cache -> do+ rv <- runPacker_ p cache+ case rv of+ PackerMore v cache' -> runPacker_ (fp v) cache'+ PackerFail err -> return $ PackerFail err++appendPacker :: Packer (a -> b) -> Packer a -> Packer b+appendPacker p1f p2 = p1f >>= \p1 -> p2 >>= \v -> return (p1 v)++-- | pack the given packer into the given bytestring+pack :: Packer a -> Int -> Either String ByteString+pack p len =+ unsafePerformIO $ do+ fptr <- B.mallocByteString len+ val <- withForeignPtr fptr $ \ptr ->+ runPacker_ p (Cache ptr len)+ return $ case val of+ PackerMore _ (Cache _ r) -> Right (PS fptr 0 (len - r))+ PackerFail err -> Left err++-- run a sized action+actionPacker :: Int -> (Ptr Word8 -> IO a) -> Packer a+actionPacker s action = Packer $ \(Cache ptr size) ->+ case compare size s of+ LT -> return $ PackerFail "Not enough space in destination"+ _ -> do+ v <- action ptr+ return $ PackerMore v (Cache (ptr `plusPtr` s) (size - s))++-- | put a storable from the current position in the stream+putStorable :: Storable storable => storable -> Packer ()+putStorable s = actionPacker (sizeOf s) (\ptr -> poke (castPtr ptr) s)+++-- | put a Bytestring from the current position in the stream+--+-- If the ByteString ins null, then do nothing+putByteString :: ByteString -> Packer ()+putByteString bs+ | neededLength == 0 = return ()+ | otherwise = actionPacker neededLength (actionPackerByteString bs)+ where+ neededLength :: Int+ neededLength = B.length bs++ actionPackerByteString :: ByteString -> Ptr Word8 -> IO ()+ actionPackerByteString (PS fptr off _) ptr =+ withForeignPtr fptr $ \srcptr ->+ B.memcpy ptr (srcptr `plusPtr` off) neededLength++-- | skip some bytes from the current position in the stream+skip :: Int -> Packer ()+skip n = actionPacker n (\_ -> return ())++-- | skip the size of a storable from the current position in the stream+skipStorable :: Storable storable => storable -> Packer ()+skipStorable = skip . sizeOf++-- | fill up from the current position in the stream to the end+--+-- it is basically:+-- > fillUpWith s == fillList (repeat s)+fillUpWith :: Storable storable => storable -> Packer ()+fillUpWith s = fillList $ repeat s++-- | Will put the given storable list from the current position in the stream+-- to the end.+--+-- This function will fail with not enough storage if the given storable can't+-- be written (not enough space)+--+-- example:+-- > pack (fillList $ [1..] :: Word8) 9 ==> "\1\2\3\4\5\6\7\8\9"+-- > pack (fillList $ [1..] :: Word32) 4 ==> "\1\0\0\0"+-- > pack (fillList $ [1..] :: Word32) 64 -- will work+-- > pack (fillList $ [1..] :: Word32) 1 -- will fail (not enough space)+-- > pack (fillList $ [1..] :: Word32) 131 -- will fail (not enough space)+fillList :: Storable storable => [storable] -> Packer ()+fillList [] = return ()+fillList (x:xs) = putStorable x >> fillList xs
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Nicolas DI PRIMA++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Nicolas DI PRIMA nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Tests/Tests.hs view
@@ -0,0 +1,76 @@+-- |+-- Module : Tests.Tests.hs+-- License : BSD-Style+-- Copyright : Copyright © 2014 Nicolas DI PRIMA+--+-- Maintainer : Nicolas DI PRIMA <nicolas@di-prima.fr>+-- Stability : experimental+-- Portability : unknown+--+{-# LANGUAGE OverloadedStrings #-}+import Test.Tasty+import Test.Tasty.HUnit++import Data.ByteString (ByteString)+import Data.ByteString.Pack+import Data.Word+import Data.Char++------------------------------------------------------------------------------+-- Simple packers to test --+------------------------------------------------------------------------------++putWord8 :: Word8 -> Packer ()+putWord8 = putStorable++putWord16 :: Word16 -> Packer ()+putWord16 = putStorable++putWord32 :: Word32 -> Packer ()+putWord32 = putStorable++testPackerOk :: ByteString -> Int -> Packer () -> Assertion+testPackerOk expected size packer =+ case pack packer size of+ Left err -> assertFailure err+ Right result -> assertEqual ("the two given value should be equal: Test(" ++ (show expected) ++ ")")+ expected result++testPackerFail :: Int -> Packer () -> Assertion+testPackerFail size packer =+ case pack packer size of+ Left _ -> return ()+ Right result -> assertFailure $ "The given test should not pass: " ++ (show result)++testCaseOk :: String -> ByteString -> Int -> Packer () -> TestTree+testCaseOk msg expected size packer = testCase msg (testPackerOk expected size packer)++testCaseFail :: String -> Int -> Packer () -> TestTree+testCaseFail msg size packer = testCase msg (testPackerFail size packer)++------------------------------------------------------------------------------+-- Group of tests+------------------------------------------------------------------------------++fromChar :: (Num a) => Char -> a+fromChar = fromIntegral . ord++refTestsOk = testGroup "All these tests must always pass"+ [ testCaseOk "put a byte" "B" 1 (putWord8 $ fromChar 'B')+ , testCaseOk "write string" "Haskell rocks!" 42 (putByteString "Haskell" >> putWord8 0x20 >> putByteString "rocks!")+ , testCaseOk "put a 2 bytes" "XY" 2 (putWord16 0x5958)+ ]++refTestsFail = testGroup "Try to see that pack fails properly"+ [ testCaseFail "not enough space" 1 (putWord32 42)+ , testCaseFail "3 actions, enough for 1" 7 (putByteString "Haskell" >> putWord8 0x20 >> putByteString "rocks!")+ , testCaseFail "3 actions, enough for 2" 8 (putByteString "Haskell" >> putWord8 0x20 >> putByteString "rocks!")+ , testCaseFail "3 actions, enough for 2 bis" 9 (putByteString "Haskell" >> putWord8 0x20 >> putByteString "rocks!")+ ]++tests = testGroup "bspack test suit"+ [ refTestsOk+ , refTestsFail+ ]++main = defaultMain tests
+ bspack.cabal view
@@ -0,0 +1,41 @@+-- Initial bspack.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: bspack+version: 0.0.1+synopsis: A simple and fast bytestring packer+description: A simple and fast bytestring packer+homepage: https://github.com/NicolasDP/hs-bspack+license: BSD3+license-file: LICENSE+author: Nicolas DI PRIMA+maintainer: nicolas@di-prima.fr+-- copyright: +category: Data+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++library+ exposed-modules: Data.ByteString.Pack+ -- other-modules: + -- other-extensions: + build-depends: base == 4.*+ , bytestring + -- hs-source-dirs: + default-language: Haskell2010+ ghc-options: -Wall -fno-warn-orphans++Test-Suite tests+ type: exitcode-stdio-1.0+ hs-source-dirs: Tests+ Main-is: Tests.hs+ Build-Depends: base == 4.*+ , bytestring+ , mtl+ , tasty+ , tasty-quickcheck+ , tasty-hunit+ , bspack+ ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures+ default-language: Haskell2010