summaryrefslogtreecommitdiff
path: root/src/Data/Binary
diff options
context:
space:
mode:
authorkrasimir <krasimir@chalmers.se>2009-12-13 18:50:29 +0000
committerkrasimir <krasimir@chalmers.se>2009-12-13 18:50:29 +0000
commitf85232947e74ee7ef8c7b0ad2338212e7e68f1be (patch)
tree667b886a5e3a4b026a63d4e3597f32497d824761 /src/Data/Binary
parentd88a865faff59c98fc91556ff8700b10ee5f2df8 (diff)
reorganize the directories under src, and rescue the JavaScript interpreter from deprecated
Diffstat (limited to 'src/Data/Binary')
-rw-r--r--src/Data/Binary/Builder.hs426
-rw-r--r--src/Data/Binary/Get.hs544
-rw-r--r--src/Data/Binary/Put.hs216
3 files changed, 0 insertions, 1186 deletions
diff --git a/src/Data/Binary/Builder.hs b/src/Data/Binary/Builder.hs
deleted file mode 100644
index cccbe6fa4..000000000
--- a/src/Data/Binary/Builder.hs
+++ /dev/null
@@ -1,426 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fglasgow-exts #-}
--- for unboxed shifts
-
------------------------------------------------------------------------------
--- |
--- Module : Data.Binary.Builder
--- Copyright : Lennart Kolmodin, Ross Paterson
--- License : BSD3-style (see LICENSE)
---
--- Maintainer : Lennart Kolmodin <kolmodin@dtek.chalmers.se>
--- Stability : experimental
--- Portability : portable to Hugs and GHC
---
--- Efficient construction of lazy bytestrings.
---
------------------------------------------------------------------------------
-
-#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
-#include "MachDeps.h"
-#endif
-
-module Data.Binary.Builder (
-
- -- * The Builder type
- Builder
- , 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 Foreign
-import Data.Monoid
-import Data.Word
-import qualified Data.ByteString as S
-import qualified Data.ByteString.Lazy as L
-
-#ifdef BYTESTRING_IN_BASE
-import Data.ByteString.Base (inlinePerformIO)
-import qualified Data.ByteString.Base as S
-#else
-import Data.ByteString.Internal (inlinePerformIO)
-import qualified Data.ByteString.Internal as S
-import qualified Data.ByteString.Lazy.Internal as L
-#endif
-
-#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
-#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
-
-------------------------------------------------------------------------
-
--- | /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 -> 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
diff --git a/src/Data/Binary/Get.hs b/src/Data/Binary/Get.hs
deleted file mode 100644
index 51062ad31..000000000
--- a/src/Data/Binary/Get.hs
+++ /dev/null
@@ -1,544 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# OPTIONS_GHC -fglasgow-exts #-}
--- for unboxed shifts
-
------------------------------------------------------------------------------
--- |
--- Module : Data.Binary.Get
--- Copyright : Lennart Kolmodin
--- License : BSD3-style (see LICENSE)
---
--- Maintainer : Lennart Kolmodin <kolmodin@dtek.chalmers.se>
--- Stability : experimental
--- Portability : portable to Hugs and GHC.
---
--- The Get monad. A monad for efficiently building structures from
--- encoded lazy ByteStrings
---
------------------------------------------------------------------------------
-
-#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
-#include "MachDeps.h"
-#endif
-
-module Data.Binary.Get (
-
- -- * The Get type
- Get
- , runGet
- , runGetState
-
- -- * Parsing
- , skip
- , uncheckedSkip
- , lookAhead
- , lookAheadM
- , lookAheadE
- , uncheckedLookAhead
-
- -- * Utility
- , bytesRead
- , getBytes
- , remaining
- , isEmpty
-
- -- * Parsing particular types
- , getWord8
-
- -- ** ByteStrings
- , getByteString
- , getLazyByteString
- , getLazyByteStringNul
- , getRemainingLazyByteString
-
- -- ** Big-endian reads
- , getWord16be
- , getWord32be
- , getWord64be
-
- -- ** Little-endian reads
- , getWord16le
- , getWord32le
- , getWord64le
-
- -- ** Host-endian, unaligned reads
- , getWordhost
- , getWord16host
- , getWord32host
- , getWord64host
-
- ) where
-
-import Control.Monad (when,liftM,ap)
-import Control.Monad.Fix
-import Data.Maybe (isNothing)
-
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Lazy as L
-
-#ifdef BYTESTRING_IN_BASE
-import qualified Data.ByteString.Base as B
-#else
-import qualified Data.ByteString.Internal as B
-import qualified Data.ByteString.Lazy.Internal as L
-#endif
-
-#ifdef APPLICATIVE_IN_BASE
-import Control.Applicative (Applicative(..))
-#endif
-
-import Foreign
-
--- used by splitAtST
-import Control.Monad.ST
-import Data.STRef
-
-#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
-import GHC.Base
-import GHC.Word
-import GHC.Int
-#endif
-
--- | The parse state
-data S = S {-# UNPACK #-} !B.ByteString -- current chunk
- L.ByteString -- the rest of the input
- {-# UNPACK #-} !Int64 -- bytes read
-
--- | The Get monad is just a State monad carrying around the input ByteString
-newtype Get a = Get { unGet :: S -> (a, S) }
-
-instance Functor Get where
- fmap f m = Get (\s -> case unGet m s of
- (a, s') -> (f a, s'))
- {-# INLINE fmap #-}
-
-#ifdef APPLICATIVE_IN_BASE
-instance Applicative Get where
- pure = return
- (<*>) = ap
-#endif
-
-instance Monad Get where
- return a = Get (\s -> (a, s))
- {-# INLINE return #-}
-
- m >>= k = Get (\s -> case unGet m s of
- (a, s') -> unGet (k a) s')
- {-# INLINE (>>=) #-}
-
- fail = failDesc
-
-instance MonadFix Get where
- mfix f = Get (\s -> let (a,s') = unGet (f a) s
- in (a,s'))
-
-------------------------------------------------------------------------
-
-get :: Get S
-get = Get (\s -> (s, s))
-
-put :: S -> Get ()
-put s = Get (\_ -> ((), s))
-
-------------------------------------------------------------------------
---
--- dons, GHC 6.10: explicit inlining disabled, was killing performance.
--- Without it, GHC seems to do just fine. And we get similar
--- performance with 6.8.2 anyway.
---
-
-initState :: L.ByteString -> S
-initState xs = mkState xs 0
-{- INLINE initState -}
-
-{-
-initState (B.LPS xs) =
- case xs of
- [] -> S B.empty L.empty 0
- (x:xs') -> S x (B.LPS xs') 0
--}
-
-#ifndef BYTESTRING_IN_BASE
-mkState :: L.ByteString -> Int64 -> S
-mkState l = case l of
- L.Empty -> S B.empty L.empty
- L.Chunk x xs -> S x xs
-{- INLINE mkState -}
-
-#else
-mkState :: L.ByteString -> Int64 -> S
-mkState (B.LPS xs) =
- case xs of
- [] -> S B.empty L.empty
- (x:xs') -> S x (B.LPS xs')
-#endif
-
--- | Run the Get monad applies a 'get'-based parser on the input ByteString
-runGet :: Get a -> L.ByteString -> a
-runGet m str = case unGet m (initState str) of (a, _) -> a
-
--- | 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 -> L.ByteString -> Int64 -> (a, L.ByteString, Int64)
-runGetState m str off =
- case unGet m (mkState str off) of
- (a, ~(S s ss newOff)) -> (a, s `join` ss, newOff)
-
-------------------------------------------------------------------------
-
-failDesc :: String -> Get a
-failDesc err = do
- S _ _ bytes <- get
- Get (error (err ++ ". Failed reading at byte position " ++ show bytes))
-
--- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available.
-skip :: Int -> Get ()
-skip n = readN (fromIntegral n) (const ())
-
--- | Skip ahead @n@ bytes. No error if there isn't enough bytes.
-uncheckedSkip :: Int64 -> Get ()
-uncheckedSkip n = do
- S s ss bytes <- get
- if fromIntegral (B.length s) >= n
- then put (S (B.drop (fromIntegral n) s) ss (bytes + n))
- else do
- let rest = L.drop (n - fromIntegral (B.length s)) ss
- put $! mkState rest (bytes + n)
-
--- | Run @ga@, but return without consuming its input.
--- Fails if @ga@ fails.
-lookAhead :: Get a -> Get a
-lookAhead ga = do
- s <- get
- a <- ga
- put s
- return a
-
--- | 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 lazy ByteString, without consuming them.
-uncheckedLookAhead :: Int64 -> Get L.ByteString
-uncheckedLookAhead n = do
- S s ss _ <- get
- if n <= fromIntegral (B.length s)
- then return (L.fromChunks [B.take (fromIntegral n) s])
- else return $ L.take n (s `join` ss)
-
-------------------------------------------------------------------------
--- Utility
-
--- | Get the total number of bytes read to this point.
-bytesRead :: Get Int64
-bytesRead = do
- S _ _ b <- get
- return b
-
--- | Get the number of remaining unparsed bytes.
--- Useful for checking whether all input has been consumed.
--- Note that this forces the rest of the input.
-remaining :: Get Int64
-remaining = do
- S s ss _ <- get
- return (fromIntegral (B.length s) + L.length ss)
-
--- | Test whether all input has been consumed,
--- i.e. there are no remaining unparsed bytes.
-isEmpty :: Get Bool
-isEmpty = do
- S s ss _ <- get
- return (B.null s && L.null ss)
-
-------------------------------------------------------------------------
--- Utility with ByteStrings
-
--- | An efficient 'get' method for strict ByteStrings. Fails if fewer
--- than @n@ bytes are left in the input.
-getByteString :: Int -> Get B.ByteString
-getByteString n = readN n id
-{-# INLINE getByteString #-}
-
--- | An efficient 'get' method for lazy ByteStrings. Does not fail if fewer than
--- @n@ bytes are left in the input.
-getLazyByteString :: Int64 -> Get L.ByteString
-getLazyByteString n = do
- S s ss bytes <- get
- let big = s `join` ss
- case splitAtST n big of
- (consume, rest) -> do put $ mkState rest (bytes + n)
- return consume
-{-# INLINE getLazyByteString #-}
-
--- | Get a lazy ByteString that is terminated with a NUL byte. Fails
--- if it reaches the end of input without hitting a NUL.
-getLazyByteStringNul :: Get L.ByteString
-getLazyByteStringNul = do
- S s ss bytes <- get
- let big = s `join` ss
- (consume, t) = L.break (== 0) big
- (h, rest) = L.splitAt 1 t
- if L.null h
- then fail "too few bytes"
- else do
- put $ mkState rest (bytes + L.length consume + 1)
- return consume
-{-# INLINE getLazyByteStringNul #-}
-
--- | Get the remaining bytes as a lazy ByteString
-getRemainingLazyByteString :: Get L.ByteString
-getRemainingLazyByteString = do
- S s ss _ <- get
- return (s `join` ss)
-
-------------------------------------------------------------------------
--- Helpers
-
--- | Pull @n@ bytes from the input, as a strict ByteString.
-getBytes :: Int -> Get B.ByteString
-getBytes n = do
- S s ss bytes <- get
- if n <= B.length s
- then do let (consume,rest) = B.splitAt n s
- put $! S rest ss (bytes + fromIntegral n)
- return $! consume
- else
- case L.splitAt (fromIntegral n) (s `join` ss) of
- (consuming, rest) ->
- do let now = B.concat . L.toChunks $ consuming
- put $! mkState rest (bytes + fromIntegral n)
- -- forces the next chunk before this one is returned
- if (B.length now < n)
- then
- fail "too few bytes"
- else
- return now
-{- INLINE getBytes -}
--- ^ important
-
-#ifndef BYTESTRING_IN_BASE
-join :: B.ByteString -> L.ByteString -> L.ByteString
-join bb lb
- | B.null bb = lb
- | otherwise = L.Chunk bb lb
-
-#else
-join :: B.ByteString -> L.ByteString -> L.ByteString
-join bb (B.LPS lb)
- | B.null bb = B.LPS lb
- | otherwise = B.LPS (bb:lb)
-#endif
- -- don't use L.append, it's strict in it's second argument :/
-{- INLINE join -}
-
--- | Split a ByteString. If the first result is consumed before the --
--- second, this runs in constant heap space.
---
--- You must force the returned tuple for that to work, e.g.
---
--- > case splitAtST n xs of
--- > (ys,zs) -> consume ys ... consume zs
---
-splitAtST :: Int64 -> L.ByteString -> (L.ByteString, L.ByteString)
-splitAtST i ps | i <= 0 = (L.empty, ps)
-#ifndef BYTESTRING_IN_BASE
-splitAtST i ps = runST (
- do r <- newSTRef undefined
- xs <- first r i ps
- ys <- unsafeInterleaveST (readSTRef r)
- return (xs, ys))
-
- where
- first r 0 xs@(L.Chunk _ _) = writeSTRef r xs >> return L.Empty
- first r _ L.Empty = writeSTRef r L.Empty >> return L.Empty
-
- first r n (L.Chunk x xs)
- | n < l = do writeSTRef r (L.Chunk (B.drop (fromIntegral n) x) xs)
- return $ L.Chunk (B.take (fromIntegral n) x) L.Empty
- | otherwise = do writeSTRef r (L.drop (n - l) xs)
- liftM (L.Chunk x) $ unsafeInterleaveST (first r (n - l) xs)
-
- where l = fromIntegral (B.length x)
-#else
-splitAtST i (B.LPS ps) = runST (
- do r <- newSTRef undefined
- xs <- first r i ps
- ys <- unsafeInterleaveST (readSTRef r)
- return (B.LPS xs, B.LPS ys))
-
- where first r 0 xs = writeSTRef r xs >> return []
- first r _ [] = writeSTRef r [] >> return []
- first r n (x:xs)
- | n < l = do writeSTRef r (B.drop (fromIntegral n) x : xs)
- return [B.take (fromIntegral n) x]
- | otherwise = do writeSTRef r (L.toChunks (L.drop (n - l) (B.LPS xs)))
- fmap (x:) $ unsafeInterleaveST (first r (n - l) xs)
-
- where l = fromIntegral (B.length x)
-#endif
-{- INLINE splitAtST -}
-
--- Pull n bytes from the input, and apply a parser to those bytes,
--- yielding a value. If less than @n@ bytes are available, fail with an
--- error. This wraps @getBytes@.
-readN :: Int -> (B.ByteString -> a) -> Get a
-readN n f = fmap f $ getBytes n
-{- INLINE readN -}
--- ^ important
-
-------------------------------------------------------------------------
--- Primtives
-
--- helper, get a raw Ptr onto a strict ByteString copied out of the
--- underlying lazy byteString. So many indirections from the raw parser
--- state that my head hurts...
-
-getPtr :: Storable a => Int -> Get a
-getPtr n = do
- (fp,o,_) <- readN n B.toForeignPtr
- return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o)
-{- INLINE getPtr -}
-
-------------------------------------------------------------------------
-
--- | Read a Word8 from the monad state
-getWord8 :: Get Word8
-getWord8 = getPtr (sizeOf (undefined :: Word8))
-{- INLINE getWord8 -}
-
--- | Read a Word16 in big endian format
-getWord16be :: Get Word16
-getWord16be = do
- s <- readN 2 id
- return $! (fromIntegral (s `B.index` 0) `shiftl_w16` 8) .|.
- (fromIntegral (s `B.index` 1))
-{- INLINE getWord16be -}
-
--- | Read a Word16 in little endian format
-getWord16le :: Get Word16
-getWord16le = do
- s <- readN 2 id
- return $! (fromIntegral (s `B.index` 1) `shiftl_w16` 8) .|.
- (fromIntegral (s `B.index` 0) )
-{- INLINE getWord16le -}
-
--- | Read a Word32 in big endian format
-getWord32be :: Get Word32
-getWord32be = do
- s <- readN 4 id
- 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) )
-{- INLINE getWord32be -}
-
--- | Read a Word32 in little endian format
-getWord32le :: Get Word32
-getWord32le = do
- s <- readN 4 id
- 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) )
-{- INLINE getWord32le -}
-
--- | Read a Word64 in big endian format
-getWord64be :: Get Word64
-getWord64be = do
- s <- readN 8 id
- 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) )
-{- INLINE getWord64be -}
-
--- | Read a Word64 in little endian format
-getWord64le :: Get Word64
-getWord64le = do
- s <- readN 8 id
- 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) )
-{- INLINE getWord64le -}
-
-------------------------------------------------------------------------
--- 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))
-{- INLINE getWordhost -}
-
--- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness.
-getWord16host :: Get Word16
-getWord16host = getPtr (sizeOf (undefined :: Word16))
-{- INLINE getWord16host -}
-
--- | /O(1)./ Read a Word32 in native host order and host endianness.
-getWord32host :: Get Word32
-getWord32host = getPtr (sizeOf (undefined :: Word32))
-{- INLINE getWord32host -}
-
--- | /O(1)./ Read a Word64 in native host order and host endianess.
-getWord64host :: Get Word64
-getWord64host = getPtr (sizeOf (undefined :: Word64))
-{- INLINE getWord64host -}
-
-------------------------------------------------------------------------
--- 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
diff --git a/src/Data/Binary/Put.hs b/src/Data/Binary/Put.hs
deleted file mode 100644
index a1f78dfba..000000000
--- a/src/Data/Binary/Put.hs
+++ /dev/null
@@ -1,216 +0,0 @@
-{-# LANGUAGE CPP #-}
------------------------------------------------------------------------------
--- |
--- Module : Data.Binary.Put
--- Copyright : Lennart Kolmodin
--- License : BSD3-style (see LICENSE)
---
--- Maintainer : Lennart Kolmodin <kolmodin@dtek.chalmers.se>
--- Stability : stable
--- Portability : Portable to Hugs and GHC. Requires MPTCs
---
--- The Put monad. A monad for efficiently constructing lazy bytestrings.
---
------------------------------------------------------------------------------
-
-module Data.Binary.Put (
-
- -- * The Put type
- Put
- , PutM(..)
- , runPut
- , runPutM
- , 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 -- :: Word -> Put
- , putWord16host -- :: Word16 -> Put
- , putWord32host -- :: Word32 -> Put
- , putWord64host -- :: Word64 -> Put
-
- ) where
-
-import Data.Monoid
-import Data.Binary.Builder (Builder, toLazyByteString)
-import qualified Data.Binary.Builder as B
-
-import Data.Word
-import qualified Data.ByteString as S
-import qualified Data.ByteString.Lazy as L
-
-#ifdef APPLICATIVE_IN_BASE
-import Control.Applicative
-#endif
-
-
-------------------------------------------------------------------------
-
--- XXX Strict in buffer only.
-data PairS a = PairS a {-# UNPACK #-}!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 ()
-
-instance Functor PutM where
- fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w
- {-# INLINE fmap #-}
-
-#ifdef APPLICATIVE_IN_BASE
-instance Applicative PutM where
- pure = return
- m <*> k = Put $
- let PairS f w = unPut m
- PairS x w' = unPut k
- in PairS (f x) (w `mappend` w')
-#endif
-
--- Standard Writer monad, with aggressive inlining
-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 :: Builder -> Put
-tell b = Put $ PairS () b
-{-# INLINE tell #-}
-
-putBuilder :: Builder -> Put
-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 -> L.ByteString
-runPut = toLazyByteString . sndS . unPut
-{-# INLINE runPut #-}
-
--- | Run the 'Put' monad with a serialiser and get its result
-runPutM :: PutM a -> (a, L.ByteString)
-runPutM (Put (PairS f s)) = (f, toLazyByteString s)
-{-# INLINE runPutM #-}
-
-------------------------------------------------------------------------
-
--- | 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 :: Word8 -> Put
-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 :: S.ByteString -> Put
-putByteString = tell . B.fromByteString
-{-# INLINE putByteString #-}
-
--- | Write a lazy ByteString efficiently, simply appending the lazy
--- ByteString chunks to the output buffer
-putLazyByteString :: L.ByteString -> Put
-putLazyByteString = tell . B.fromLazyByteString
-{-# INLINE putLazyByteString #-}
-
--- | Write a Word16 in big endian format
-putWord16be :: Word16 -> Put
-putWord16be = tell . B.putWord16be
-{-# INLINE putWord16be #-}
-
--- | Write a Word16 in little endian format
-putWord16le :: Word16 -> Put
-putWord16le = tell . B.putWord16le
-{-# INLINE putWord16le #-}
-
--- | Write a Word32 in big endian format
-putWord32be :: Word32 -> Put
-putWord32be = tell . B.putWord32be
-{-# INLINE putWord32be #-}
-
--- | Write a Word32 in little endian format
-putWord32le :: Word32 -> Put
-putWord32le = tell . B.putWord32le
-{-# INLINE putWord32le #-}
-
--- | Write a Word64 in big endian format
-putWord64be :: Word64 -> Put
-putWord64be = tell . B.putWord64be
-{-# INLINE putWord64be #-}
-
--- | Write a Word64 in little endian format
-putWord64le :: Word64 -> Put
-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 :: Word -> Put
-putWordhost = tell . B.putWordhost
-{-# INLINE putWordhost #-}
-
--- | /O(1)./ Write a Word16 in native host order and host endianness.
--- For portability issues see @putWordhost@.
-putWord16host :: Word16 -> Put
-putWord16host = tell . B.putWord16host
-{-# INLINE putWord16host #-}
-
--- | /O(1)./ Write a Word32 in native host order and host endianness.
--- For portability issues see @putWordhost@.
-putWord32host :: Word32 -> Put
-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 :: Word64 -> Put
-putWord64host = tell . B.putWord64host
-{-# INLINE putWord64host #-}