use GetM/PutM instead
authorDon Stewart <dons@cse.unsw.edu.au>
Thu, 11 Jan 2007 11:52:42 +0000 (12:52 +0100)
committerDon Stewart <dons@cse.unsw.edu.au>
Thu, 11 Jan 2007 11:52:42 +0000 (12:52 +0100)
binary.cabal
src/Data/Binary.hs
src/Data/Binary/GetM.hs [moved from src/Data/Binary/DecM.hs with 68% similarity]
src/Data/Binary/PutM.hs [moved from src/Data/Binary/EncM.hs with 66% similarity]

index f67fd48..861b3b9 100644 (file)
@@ -6,7 +6,7 @@ Author:          Lennart Kolmodin <kolmodin@dtek.chalmers.se>
 Synopsis:        Binary serialization using lazy ByteStrings
 Build-Depends:   base, mtl
 Exposed-Modules: Data.Binary,
-                 Data.Binary.DecM,
-                 Data.Binary.EncM
+                 Data.Binary.PutM,
+                 Data.Binary.GetM
 Extensions:      ForeignFunctionInterface, FlexibleInstances
 hs-source-dirs:  src
index 18edb3b..3cd3a06 100644 (file)
 -----------------------------------------------------------------------------
 
 module Data.Binary (
-      module Data.Binary.EncM
-    , module Data.Binary.DecM
+      module Data.Binary.PutM
+    , module Data.Binary.GetM
     , Binary(..)
     , encode
     , decode
   ) where
 
-import Data.Binary.EncM
-import Data.Binary.DecM
+import Data.Binary.PutM
+import Data.Binary.GetM
 
 import Control.Monad
 import Foreign
@@ -39,16 +39,16 @@ import Data.Array.Unboxed (UArray)
 ------------------------------------------------------------------------
 
 encode :: Binary a => a -> L.ByteString
-encode = runEncM . put
+encode = runPutM . put
 
 decode :: Binary a => L.ByteString -> a
-decode = runDecM get
+decode = runGetM get
 
 ------------------------------------------------------------------------
 
 class Binary t where
-    put :: t -> EncM ()
-    get :: DecM t
+    put :: t -> PutM ()
+    get :: GetM t
 
 instance Binary () where
     put ()  = return ()
@@ -79,41 +79,38 @@ instance Binary Word64 where
 
 instance Binary Int8 where
     put i   = put (fromIntegral i :: Word8)
-    get     = fromIntegral `fmap` (get :: DecM Word8)
+    get     = fromIntegral `fmap` (get :: GetM Word8)
 
 instance Binary Int16 where
     put i   = put (fromIntegral i :: Word16)
-    get     = fromIntegral `fmap` (get :: DecM Word16)
+    get     = fromIntegral `fmap` (get :: GetM Word16)
 
 instance Binary Int32 where
     put i   = put (fromIntegral i :: Word32)
-    get     = fromIntegral `fmap` (get :: DecM Word32)
+    get     = fromIntegral `fmap` (get :: GetM Word32)
 
 instance Binary Int64 where
     put i   = put (fromIntegral i :: Word64)
-    get     = fromIntegral `fmap` (get :: DecM Word64)
+    get     = fromIntegral `fmap` (get :: GetM Word64)
 
 instance Binary Int where
     put i   = put (fromIntegral i :: Int32)
-    get     = fromIntegral `fmap` (get :: DecM Int32)
+    get     = fromIntegral `fmap` (get :: GetM Int32)
 
 -- TODO Integer
 
 -- TODO profile, benchmark and test this instance
 instance Binary 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)
+          | 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
@@ -150,7 +147,7 @@ instance Binary a => Binary [a] where
         put (length l)
         mapM_ put l
     get    = do
-        (n :: Int) <- get
+        n <- get :: GetM Int
         replicateM n get
 
 instance (Binary a, Binary b) => Binary (Either a b) where
@@ -202,6 +199,9 @@ instance Binary B.ByteString where
         len <- get
         getByteString len
 
+-- 
+-- needs the newtyped' bytestring
+-- 
 instance Binary L.ByteString where
     put bs = do
         put (L.length bs)
@@ -236,6 +236,12 @@ instance (Binary i, Ix i, Binary e) => Binary (Array i e) where
         return (listArray bs es)
 
 -- todo handle UArray i Bool specially?
+--
+-- N.B.
+--
+--  Non type-variable argument in the constraint: IArray UArray e
+--  (Use -fglasgow-exts to permit this)
+--
 instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where
     put a = do
         put (bounds a)
similarity index 68%
rename from src/Data/Binary/DecM.hs
rename to src/Data/Binary/GetM.hs
index b6ccb4e..b3c2e55 100644 (file)
@@ -1,18 +1,18 @@
 -----------------------------------------------------------------------------
 -- |
--- Module      :
--- Copyright   : 
--- License     :  BSD3-style (see LICENSE)
+-- Module      : Data.Binary.GetM
+-- Copyright   : Lennart Kolmodin
+-- License     : BSD3-style (see LICENSE)
 -- 
--- Maintainer  :
--- Stability   :  stable
--- Portability :  portable
+-- Maintainer  : Lennart Kolmodin <kolmodin@dtek.chalmers.se>
+-- Stability   : stable
+-- Portability : FFI + flexibile instances
 --
 -----------------------------------------------------------------------------
 
-module Data.Binary.DecM
-    ( DecM
-    , runDecM
+module Data.Binary.GetM
+    ( GetM
+    , runGetM
     , getByteString
     , getLazyByteString
     , getWord8
@@ -39,43 +39,41 @@ import Foreign
 
 import System.IO.Unsafe
 
--- import Data.ByteString.Binary.Shift
 import GHC.Prim
 import GHC.Base
 import GHC.Word
 import GHC.Int
 
-
 type S = L.ByteString
 
-newtype DecM a = DecM { unDecM :: State S a }
+newtype GetM a = GetM { unGetM :: State S a }
 
-instance Monad DecM where
-    return a        = DecM (return a)
-    (DecM m) >>= k  = DecM (m >>= unDecM . k)
-    fail a          = DecM (fail a)
+instance Monad GetM where
+    return a        = GetM (return a)
+    (GetM m) >>= k  = GetM (m >>= unGetM . k)
+    fail a          = GetM (fail a)
 
-instance MonadState S DecM where
-    get         = DecM get
-    put f       = DecM (put f)
+instance MonadState S GetM where
+    get         = GetM get
+    put f       = GetM (put f)
 
-instance Functor DecM where
-    fmap f (DecM m) = DecM (fmap f m)
+instance Functor GetM where
+    fmap f (GetM m) = GetM (fmap f m)
 
-runDecM :: DecM a -> L.ByteString -> a
-runDecM (DecM m) str = evalState m str
+runGetM :: GetM a -> L.ByteString -> a
+runGetM (GetM m) str = evalState m str
 
-ensureLeft :: Int64 -> DecM ()
+ensureLeft :: Int64 -> GetM ()
 ensureLeft n = do
     (B.LPS strs) <- get
     worker n strs
   where
-    worker :: Int64 -> [B.ByteString] -> DecM ()
+    worker :: Int64 -> [B.ByteString] -> GetM ()
     worker n _ | n <= 0 = return ()
     worker _ []         = fail "not enough bytestring left"
     worker n (x:xs)     = worker (n - fromIntegral (B.length x)) xs
 
-readN :: Int64 -> (L.ByteString -> a) -> DecM a
+readN :: Int64 -> (L.ByteString -> a) -> GetM a
 readN n f = do
     ensureLeft n
     s <- get
@@ -83,55 +81,55 @@ readN n f = do
     put rest
     return (f consuming)
 
-getByteString :: Int -> DecM B.ByteString
+getByteString :: Int -> GetM B.ByteString
 getByteString n = readN (fromIntegral n) (B.concat . L.toChunks)
 
-getLazyByteString :: Int64 -> DecM L.ByteString
+getLazyByteString :: Int64 -> GetM L.ByteString
 getLazyByteString n = readN n id
 
 {-# INLINE getWord8 #-}
-getWord8 :: DecM Word8
+getWord8 :: GetM Word8
 getWord8 = readN 1 L.head
 
 {-# INLINE getWord16be #-}
-getWord16be :: DecM Word16
+getWord16be :: GetM Word16
 getWord16be = do
     w1 <- liftM fromIntegral getWord8
     w2 <- liftM fromIntegral getWord8
     return $! w1 `unsafeShiftL_Word16` 8 .|. w2
 
 {-# INLINE getWord16le #-}
-getWord16le :: DecM Word16
+getWord16le :: GetM Word16
 getWord16le = do
     w1 <- liftM fromIntegral getWord8
     w2 <- liftM fromIntegral getWord8
-    return $! w2 `unsafeShiftL_Word16` 8 .|. w1 
+    return $! w2 `unsafeShiftL_Word16` 8 .|. w1
 
 unsafeShiftL_Word16 (W16# x#) (I# i#) = W16# (narrow16Word# (x# `shiftL#` i#))
 
 {-# INLINE getWord32be #-}
-getWord32be :: DecM Word32
+getWord32be :: GetM Word32
 getWord32be = do
     w1 <- liftM fromIntegral getWord16be
     w2 <- liftM fromIntegral getWord16be
     return $! w1 `shiftL` 16 .|. w2
 
 {-# INLINE getWord32le #-}
-getWord32le :: DecM Word32
+getWord32le :: GetM Word32
 getWord32le = do
     w1 <- liftM fromIntegral getWord16le
     w2 <- liftM fromIntegral getWord16le
     return $! w2 `shiftL` 16 .|. w1
 
 {-# INLINE getWord64be #-}
-getWord64be :: DecM Word64
+getWord64be :: GetM Word64
 getWord64be = do
     w1 <- liftM fromIntegral getWord32be
     w2 <- liftM fromIntegral getWord32be
     return $! w1 `shiftL` 32 .|. w2
 
 {-# INLINE getWord64le #-}
-getWord64le :: DecM Word64
+getWord64le :: GetM Word64
 getWord64le = do
     w1 <- liftM fromIntegral getWord32le
     w2 <- liftM fromIntegral getWord32le
similarity index 66%
rename from src/Data/Binary/EncM.hs
rename to src/Data/Binary/PutM.hs
index 3de4a5b..e135ba2 100644 (file)
@@ -1,6 +1,18 @@
-module Data.Binary.EncM
-    ( EncM
-    , runEncM
+-----------------------------------------------------------------------------
+-- |
+-- Module      : Data.Binary.PutM
+-- Copyright   : Lennart Kolmodin
+-- License     : BSD3-style (see LICENSE)
+-- 
+-- Maintainer  : Lennart Kolmodin <kolmodin@dtek.chalmers.se>
+-- Stability   : stable
+-- Portability : FFI + flexibile instances
+--
+-----------------------------------------------------------------------------
+
+module Data.Binary.PutM
+    ( PutM
+    , runPutM
     , unsafeLiftIO
     , yield
     , pop
@@ -37,25 +49,25 @@ data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8)
                      {-# UNPACK #-} !Int                -- ^ used bytes
                      {-# UNPACK #-} !Int                -- ^ length left
 
-newtype EncM a = EncM { unEncM :: ContT [B.ByteString] (StateT Buffer IO) a }
+newtype PutM a = PutM { unPutM :: ContT [B.ByteString] (StateT Buffer IO) a }
 
-instance Monad EncM where
-    return a        = EncM (return a)
-    (EncM m) >>= k  = EncM (m >>= unEncM . k)
-    (>>)            = bEncM
-    fail a          = EncM (fail a)
+instance Monad PutM where
+    return a        = PutM (return a)
+    (PutM m) >>= k  = PutM (m >>= unPutM . k)
+    (>>)            = bPutM
+    fail a          = PutM (fail a)
 
-instance Functor EncM where
-    fmap f (EncM m) = EncM (fmap f m)
+instance Functor PutM where
+    fmap f (PutM m) = PutM (fmap f m)
 
 -- A bind for which we control the inlining
-{-# INLINE [1] bEncM #-}
-bEncM :: EncM a -> EncM b -> EncM b
-bEncM (EncM a) (EncM b) = EncM (a >> b)
+{-# INLINE [1] bPutM #-}
+bPutM :: PutM a -> PutM b -> PutM b
+bPutM (PutM a) (PutM b) = PutM (a >> b)
 
-instance MonadState Buffer EncM where
-    get     = EncM get
-    put f   = EncM (put f)
+instance MonadState Buffer PutM where
+    get     = PutM get
+    put f   = PutM (put f)
 
 defaultSize = 32 * k - overhead 
     where k = 1024
@@ -66,19 +78,19 @@ initS = do
   fp <- B.mallocByteString defaultSize 
   return $! Buffer fp 0 0 defaultSize
 
-runEncM :: EncM () -> L.ByteString
-runEncM m = unsafePerformIO $ do
+runPutM :: PutM () -> L.ByteString
+runPutM m = unsafePerformIO $ do
     i <- initS
-    liftM B.LPS $ evalStateT (runContT (unEncM $ m >> pop) (\c -> return [])) i
+    liftM B.LPS $ evalStateT (runContT (unPutM $ m >> pop) (\c -> return [])) i
 
-unsafeLiftIO :: IO a -> EncM a
-unsafeLiftIO = EncM . liftIO
+unsafeLiftIO :: IO a -> PutM a
+unsafeLiftIO = PutM . liftIO
 
 -- |Add a ByteString as output.
 -- Does a 'unsafeInterleaveIO' trick, which will lazely suspend the rest of
 -- the computation till that ByteString has been consumed.
-yield :: B.ByteString -> EncM ()
-yield bs = EncM . ContT $ \c -> do
+yield :: B.ByteString -> PutM ()
+yield bs = PutM . ContT $ \c -> do
     s@(Buffer _ _ u _) <- get
     assert (u == 0) $ do
     -- this truly is a beautyful piece of magic
@@ -87,7 +99,7 @@ yield bs = EncM . ContT $ \c -> do
 
 -- |Pop the ByteString we have constructed so far, if any.
 {-# INLINE [1] pop #-}
-pop :: EncM ()
+pop :: PutM ()
 pop = do
     Buffer p o u l <- get
     when (u /= 0) $ do
@@ -96,7 +108,7 @@ pop = do
 
 -- |Ensure that there are at least @n@ many bytes available.
 {-# INLINE [1] ensureFree #-}
-ensureFree :: Int -> EncM ()
+ensureFree :: Int -> PutM ()
 ensureFree n = do
     Buffer _ _ _ l <- get
     when (n > l) $ do
@@ -108,7 +120,7 @@ ensureFree n = do
 -- |Ensure that @n@ many bytes are available, and then use @f@ to write some
 -- bytes into the memory.
 {-# INLINE [1] writeN #-}
-writeN :: Int -> (Ptr Word8 -> IO ()) -> EncM ()
+writeN :: Int -> (Ptr Word8 -> IO ()) -> PutM ()
 writeN n f = do
     ensureFree n
     Buffer fp o u l <- get
@@ -116,62 +128,62 @@ writeN n f = do
         withForeignPtr fp (\p -> f (p `plusPtr` (o+u)))
     put $ Buffer fp o (u+n) (l-n)
 
-putByteString :: B.ByteString -> EncM ()
+putByteString :: B.ByteString -> PutM ()
 putByteString bs = do
     pop
     yield bs
 
-putLazyByteString :: L.ByteString -> EncM ()
+putLazyByteString :: L.ByteString -> PutM ()
 putLazyByteString bs = do
     pop
     mapM_ yield (L.toChunks bs)
 
 {-# INLINE putWord8 #-}
-putWord8 :: Word8 -> EncM ()
+putWord8 :: Word8 -> PutM ()
 putWord8 = writeN 1 . flip poke
 
 {-# INLINE putWord16be #-}
-putWord16be :: Word16 -> EncM ()
+putWord16be :: Word16 -> PutM ()
 putWord16be w16 = do
     let (w1, w2) = divMod w16 0x0100
     putWord8 (fromIntegral w1)
     putWord8 (fromIntegral w2)
 
 {-# INLINE putWord16le #-}
-putWord16le :: Word16 -> EncM ()
+putWord16le :: Word16 -> PutM ()
 putWord16le w16 = do
     let (w2, w1) = divMod w16 0x0100
     putWord8 (fromIntegral w1)
     putWord8 (fromIntegral w2)
 
 {-# INLINE putWord32be #-}
-putWord32be :: Word32 -> EncM ()
+putWord32be :: Word32 -> PutM ()
 putWord32be w32 = do
     let (w1, w2) = divMod w32 0x00010000
     putWord16be (fromIntegral w1)
     putWord16be (fromIntegral w2)
 
 {-# INLINE putWord32le #-}
-putWord32le :: Word32 -> EncM ()
+putWord32le :: Word32 -> PutM ()
 putWord32le w32 = do
     let (w2, w1) = divMod w32 0x00010000
     putWord16le (fromIntegral w1)
     putWord16le (fromIntegral w2)
 
 {-# INLINE putWord64be #-}
-putWord64be :: Word64 -> EncM ()
+putWord64be :: Word64 -> PutM ()
 putWord64be w64 = do
     let (w1, w2) = divMod w64 0x0000000100000000
     putWord32be (fromIntegral w1)
     putWord32be (fromIntegral w2)
 
 {-# INLINE putWord64le #-}
-putWord64le :: Word64 -> EncM ()
+putWord64le :: Word64 -> PutM ()
 putWord64le w64 = do
     let (w2, w1) = divMod w64 0x0000000100000000
     putWord32le (fromIntegral w1)
     putWord32le (fromIntegral w2)
 
-{-# RULES "writeN/combine" forall s1 s2 f1 f2. bEncM (writeN s1 f1) (writeN s2 f2) = writeN (s1+s2) (\p -> f1 p >> f2 (p `plusPtr` s1)) #-}
-{-# RULES "ensureFree/combine" forall a b. bEncM (ensureFree a) (ensureFree b) = ensureFree (max a b) #-}
-{-# RULES "pop/combine" bEncM pop pop = pop #-}
+{-# RULES "writeN/combine" forall s1 s2 f1 f2. bPutM (writeN s1 f1) (writeN s2 f2) = writeN (s1+s2) (\p -> f1 p >> f2 (p `plusPtr` s1)) #-}
+{-# RULES "ensureFree/combine" forall a b. bPutM (ensureFree a) (ensureFree b) = ensureFree (max a b) #-}
+{-# RULES "pop/combine" bPutM pop pop = pop #-}