diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) Lennart Kolmodin
+
+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.
diff --git a/README b/README
new file mode 100644
--- /dev/null
+++ b/README
@@ -0,0 +1,34 @@
+
+  binary: efficient, pure binary serialisation using lazy ByteStrings
+------------------------------------------------------------------------
+
+The 'binary' package provides Data.Binary, containing the Binary class,
+and associated methods, for serialising values to and from lazy
+ByteStrings. 
+
+A key feature of 'binary' is that the interface is both pure, and efficient.
+
+The 'binary' package is portable to GHC and Hugs.
+
+Building:
+
+    runhaskell Setup.hs configure
+    runhaskell Setup.hs build
+    runhaskell Setup.hs install
+
+First:
+    import Data.Binary
+
+and then write an instance of Binary for the type you wish to serialise.
+More information in the haddock documentation.
+
+Contributors:
+
+    Lennart Kolmodin
+    Duncan Coutts
+    Don Stewart
+    Spencer Janssen
+    David Himmelstrup
+    Björn Bringert
+    Ross Paterson
+    Einar Karttunen
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
diff --git a/TODO b/TODO
new file mode 100644
--- /dev/null
+++ b/TODO
@@ -0,0 +1,28 @@
+layer handling:
+
+    bit packing
+    state parameters
+    string pools
+
+    reading structures from the end of a stream, seek/tell behaviour
+
+seek based protocols are too hard. 
+    hGetContents/ interleaving.
+
+user requests:
+
+    get remaining bytestring after a runGet
+
+    some kind of lookahead, or restoring parsing state, or something with
+      equal functionality. make it another layer on top?
+
+    getLazyByteString takes an Int, which in Haskell98 is only guarantied to
+      be 29 bits, ie. 512 mb.
+      maybe we should have a readN64 for allowing reading of larger stuff?
+      (which could be implemented with readN on 64bit machines)
+      reference: bringerts tar archive decoder would be limitid to 0.5GB
+                 files, alt. 2GB in GHC
+
+SYB-deriving
+
+investigate the UArray instance, it does not seem to compile in GHC 6.4
diff --git a/binary.cabal b/binary.cabal
new file mode 100644
--- /dev/null
+++ b/binary.cabal
@@ -0,0 +1,19 @@
+name:            binary
+version:         0.2
+license:         BSD3
+license-file:    LICENSE
+author:          Lennart Kolmodin <kolmodin@dtek.chalmers.se>
+maintainer:      Lennart Kolmodin
+description:     Efficient, pure binary serialisation using lazy ByteStrings
+synopsis:        Binary serialization using lazy ByteStrings
+category:        Data, Parsing
+build-depends:   base
+-- ghc 6.4 also needs package fps
+exposed-modules: Data.Binary,
+                 Data.Binary.Put,
+                 Data.Binary.Get,
+                 Data.Binary.Builder
+extensions:      ForeignFunctionInterface,CPP,FlexibleInstances
+hs-source-dirs:  src
+ghc-options:     -O2 -Wall -Werror -fliberate-case-threshold=1000
+extra-source-files: README 
diff --git a/src/Data/Binary.hs b/src/Data/Binary.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Binary.hs
@@ -0,0 +1,620 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      : Data.Binary
+-- Copyright   : Lennart Kolmodin
+-- License     : BSD3-style (see LICENSE)
+-- 
+-- Maintainer  : Lennart Kolmodin <kolmodin@dtek.chalmers.se>
+-- Stability   : unstable
+-- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances
+--
+-- Binary serialisation of Haskell values to and from lazy ByteStrings.
+-- The Binary library provides methods for encoding Haskell values as
+-- streams of bytes directly in memory. The resulting @ByteString@ can
+-- then be written to disk, sent over the network, or futher processed
+-- (for example, compressed with gzip).
+--
+-- The 'Binary' package is notable in that it provides both pure, and
+-- high performance serialisation.
+--
+-- Values are always encoded in network order (big endian) form, and
+-- encoded data should be portable across machine endianess, word size,
+-- or compiler version. For example, data encoded using the Binary class
+-- could be written from GHC, and read back in Hugs.
+--
+-----------------------------------------------------------------------------
+
+module Data.Binary (
+
+    -- * The Binary class
+      Binary(..)
+
+    -- $example
+
+    -- * The Get and Put monads
+    , Get
+    , Put
+
+    -- * Useful helpers for writing instances
+    , putWord8
+    , getWord8
+
+    -- * Binary serialisation
+    , encode                    -- :: Binary a => a -> ByteString
+    , decode                    -- :: Binary a => ByteString -> a
+
+    -- * IO functions for serialisation
+    , encodeFile                -- :: Binary a => FilePath -> a -> IO ()
+    , decodeFile                -- :: Binary a => FilePath -> IO a
+
+-- Lazy put and get
+--  , lazyPut
+--  , lazyGet
+
+    , module Data.Word -- useful
+
+    ) where
+
+import Data.Word
+
+import Data.Binary.Put
+import Data.Binary.Get
+
+import Control.Monad
+import Foreign
+import System.IO
+
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy as L
+
+import Data.Char    (chr,ord)
+import Data.List    (unfoldr)
+
+-- And needed for the instances:
+import qualified Data.ByteString as B
+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.Tree as T
+
+import Data.Array.Unboxed
+
+--
+-- This isn't available in older Hugs or older GHC
+--
+#if __GLASGOW_HASKELL__ >= 606
+import qualified Data.Sequence as Seq
+#endif
+
+------------------------------------------------------------------------
+
+-- | The @Binary@ class provides 'put' and 'get', methods to encode and
+-- decode a Haskell value to a lazy ByteString. It mirrors the Read and
+-- Show classes for textual representation of Haskell types, and is
+-- suitable for serialising Haskell values to disk, over the network.
+--
+-- For parsing and generating simple external binary formats (e.g. C
+-- structures), Binary may be used, but in general is not suitable
+-- for complex protocols. Instead use the Put and Get primitives
+-- directly.
+--
+-- Instances of Binary should satisfy the following property:
+--
+-- > get . put == id
+--
+-- A range of instances are provided for basic Haskell types. 
+--
+class Binary t where
+    -- | Encode a value in the Put monad.
+    put :: t -> Put
+    -- | Decode a value in the Get monad
+    get :: Get t
+
+-- $example
+-- To serialise a custom type, an instance of Binary for that type is
+-- required. For example, suppose we have a data structure:
+--
+-- > data Exp = IntE Int
+-- >          | OpE  String Exp Exp
+-- >    deriving Show
+--
+-- We can encode values of this type into bytestrings using the
+-- following instance, which proceeds by recursively breaking down the
+-- structure to serialise:
+--
+-- > instance Binary Exp where
+-- >       put (IntE i)          = do put (0 :: Word8)
+-- >                                  put i
+-- >       put (OpE s e1 e2)     = do put (1 :: Word8)
+-- >                                  put s
+-- >                                  put e1
+-- >                                  put e2
+-- > 
+-- >       get = do t <- get :: Get Word8
+-- >                case t of
+-- >                     0 -> do i <- get
+-- >                             return (IntE i)
+-- >                     1 -> do s  <- get
+-- >                             e1 <- get
+-- >                             e2 <- get
+-- >                             return (OpE s e1 e2)
+--
+-- Note how we write an initial tag byte to indicate each variant of the
+-- data type.
+--
+-- To serialise this to a bytestring, we use 'encode', which packs the
+-- data structure into a binary format, in a lazy bytestring
+--
+-- > > let e = OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2))
+-- > > let v = encode e
+--
+-- Where 'v' is a binary encoded data structure. To reconstruct the
+-- original data, we use 'decode'
+--
+-- > > decode v :: Exp
+-- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2))
+--
+-- The lazy ByteString that results from 'encode' can be written to
+-- disk, and read from disk using Data.ByteString.Lazy IO functions,
+-- such as hPutStr or writeFile:
+--
+-- > > writeFile "/tmp/exp.txt" (encode e)
+--
+-- And read back with:
+--
+-- > > readFile "/tmp/exp.txt" >>= return . decode :: IO Exp
+-- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2))
+--
+-- We can also directly serialise a value to and from a Handle, or a file:
+-- 
+-- > > v <- decodeFile  "/tmp/exp.txt" :: IO Exp
+-- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2))
+--
+-- And write a value to disk
+--
+-- > > encodeFile "/tmp/a.txt" v
+--
+
+------------------------------------------------------------------------
+-- Wrappers to run the underlying monad
+
+-- | Encode a value using binary serialisation to a lazy ByteString.
+--
+encode :: Binary a => a -> ByteString
+encode = runPut . put
+{-# INLINE encode #-}
+
+-- | Decode a value from a lazy ByteString, reconstructing the original structure.
+--
+decode :: Binary a => ByteString -> a
+decode = runGet get
+
+------------------------------------------------------------------------
+-- Convenience IO operations
+
+-- | Lazily serialise a value to a file
+--
+-- This is just a convenience function, it's defined simply as:
+--
+-- > encodeFile f = B.writeFile f . encode
+--
+-- So for example if you wanted to compress as well, you could use:
+--
+-- > B.writeFile f . compress . encode
+--
+encodeFile :: Binary a => FilePath -> a -> IO ()
+encodeFile f v = L.writeFile f (encode v)
+
+-- | Lazily reconstruct a value previously written to a file
+--
+-- This is just a convenience function, it's defined simply as:
+--
+-- > decodeFile f = return . decode =<< B.readFile f
+--
+-- So for example if you wanted to decompress as well, you could use:
+--
+-- > return . decode . decompress =<< B.readFile f
+--
+decodeFile :: Binary a => FilePath -> IO a
+decodeFile f = liftM decode (L.readFile f)
+
+------------------------------------------------------------------------
+-- Lazy put and get
+
+-- lazyPut :: (Binary a) => a -> Put
+-- lazyPut a = put (encode a)
+
+-- lazyGet :: (Binary a) => Get a
+-- lazyGet = fmap decode get
+
+------------------------------------------------------------------------
+-- Simple instances
+
+-- The () type need never be written to disk: values of singleton type
+-- can be reconstructed from the type alone
+instance Binary () where
+    put ()  = return ()
+    get     = return ()
+
+-- Bools are encoded as a byte in the range 0 .. 1
+instance Binary 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 Binary Ordering where
+    put     = putWord8 . fromIntegral . fromEnum
+    get     = liftM (toEnum . fromIntegral) getWord8
+
+------------------------------------------------------------------------
+-- Words and Ints
+
+-- Words8s are written as bytes
+instance Binary Word8 where
+    put     = putWord8
+    get     = getWord8
+
+-- Words16s are written as 2 bytes in big-endian (network) order
+instance Binary Word16 where
+    put     = putWord16be
+    get     = getWord16be
+
+-- Words32s are written as 4 bytes in big-endian (network) order
+instance Binary Word32 where
+    put     = putWord32be
+    get     = getWord32be
+
+-- Words64s are written as 8 bytes in big-endian (network) order
+instance Binary Word64 where
+    put     = putWord64be
+    get     = getWord64be
+
+-- Int8s are written as a single byte.
+instance Binary 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 Binary 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 Binary Int32 where
+    put i   = put (fromIntegral i :: Word32)
+    get     = liftM fromIntegral (get :: Get Word32)
+
+-- Int64s are written as a 4 bytes in big endian format
+instance Binary 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 Binary 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 Binary 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 Binary 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
+
+{-
+
+--
+-- An efficient, raw serialisation for Integer (GHC only)
+--
+
+-- TODO  This instance is not architecture portable.  GMP stores numbers as
+-- arrays of machine sized words, so the byte format is not portable across
+-- architectures with different endianess and word size.
+
+import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy)
+import GHC.Base     hiding (ord, chr)
+import GHC.Prim
+import GHC.Ptr (Ptr(..))
+import GHC.IOBase (IO(..))
+
+instance Binary Integer where
+    put (S# i)    = putWord8 0 >> put (I# i)
+    put (J# s ba) = do
+        putWord8 1
+        put (I# s)
+        put (BA ba)
+
+    get = do
+        b <- getWord8
+        case b of
+            0 -> do (I# i#) <- get
+                    return (S# i#)
+            _ -> do (I# s#) <- get
+                    (BA a#) <- get
+                    return (J# s# a#)
+
+instance Binary ByteArray where
+
+    -- Pretty safe.
+    put (BA ba) =
+        let sz   = sizeofByteArray# ba   -- (primitive) in *bytes*
+            addr = byteArrayContents# ba
+            bs   = unsafePackAddress (I# sz) addr
+        in put bs   -- write as a ByteString. easy, yay!
+
+    -- Pretty scary. Should be quick though
+    get = do
+        (fp, off, n@(I# sz)) <- liftM toForeignPtr get      -- so decode a ByteString
+        assert (off == 0) $ return $ unsafePerformIO $ do
+            (MBA arr) <- newByteArray sz                    -- and copy it into a ByteArray#
+            let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe?
+            withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n)
+            freezeByteArray arr
+
+-- wrapper for ByteArray#
+data ByteArray = BA  {-# UNPACK #-} !ByteArray#
+data MBA       = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld)
+
+newByteArray :: Int# -> IO MBA
+newByteArray sz = IO $ \s ->
+  case newPinnedByteArray# sz s of { (# s', arr #) ->
+  (# s', MBA arr #) }
+
+freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
+freezeByteArray arr = IO $ \s ->
+  case unsafeFreezeByteArray# arr s of { (# s', arr' #) ->
+  (# s', BA arr' #) }
+
+-}
+
+------------------------------------------------------------------------
+
+-- Char is serialised as UTF-8
+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)
+          | 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 (Binary a, Binary b) => Binary (a,b) where
+    put (a,b)           = put a >> put b
+    get                 = liftM2 (,) get get
+
+instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
+    put (a,b,c)         = put a >> put b >> put c
+    get                 = liftM3 (,,) get get get
+
+instance (Binary a, Binary b, Binary c, Binary d) => Binary (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 (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (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 (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f)
+        => Binary (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 (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g)
+        => Binary (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 (Binary a, Binary b, Binary c, Binary d, Binary e,
+          Binary f, Binary g, Binary h)
+        => Binary (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 (Binary a, Binary b, Binary c, Binary d, Binary e,
+          Binary f, Binary g, Binary h, Binary i)
+        => Binary (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 (Binary a, Binary b, Binary c, Binary d, Binary e,
+          Binary f, Binary g, Binary h, Binary i, Binary j)
+        => Binary (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 Binary a => Binary [a] where
+    put l  = put (length l) >> mapM_ put l
+    get    = do n <- get :: Get Int
+                replicateM n get
+
+instance (Binary a) => Binary (Maybe a) where
+    put Nothing  = putWord8 0
+    put (Just x) = putWord8 1 >> put x
+    get = do
+        w <- getWord8
+        case w of
+            0 -> return Nothing
+            _ -> liftM Just get
+
+instance (Binary a, Binary b) => Binary (Either a b) where
+    put (Left  a) = putWord8 0 >> put a
+    put (Right b) = putWord8 1 >> put b
+    get = do
+        w <- getWord8
+        case w of
+            0 -> liftM Left  get
+            _ -> liftM Right get
+
+------------------------------------------------------------------------
+-- ByteStrings (have specially efficient instances)
+
+instance Binary B.ByteString where
+    put bs = do put (B.length bs)
+                putByteString bs
+    get    = get >>= getByteString
+
+--
+-- Using old versions of fps, this is a type synonym, and non portable
+-- 
+-- Requires 'flexible instances'
+--
+instance Binary ByteString where
+    put bs = do put (fromIntegral (L.length bs) :: Int)
+                putLazyByteString bs
+    get    = get >>= getLazyByteString
+
+------------------------------------------------------------------------
+-- Maps and Sets
+
+instance (Ord a, Binary a) => Binary (Set.Set a) where
+    put = put . Set.toAscList
+    get = liftM Set.fromDistinctAscList get
+
+instance (Ord k, Binary k, Binary e) => Binary (Map.Map k e) where
+    put = put . Map.toAscList
+    get = liftM Map.fromDistinctAscList get
+
+instance Binary IntSet.IntSet where
+    put = put . IntSet.toAscList
+    get = liftM IntSet.fromDistinctAscList get
+
+instance (Binary e) => Binary (IntMap.IntMap e) where
+    put = put . IntMap.toAscList
+    get = liftM IntMap.fromDistinctAscList get
+
+------------------------------------------------------------------------
+-- Queues and Sequences
+
+#if __GLASGOW_HASKELL__ >= 606
+--
+-- This is valid Hugs, but you need the most recent Hugs
+--
+
+instance (Binary e) => Binary (Seq.Seq e) where
+    -- any better way to do this?
+    put s = put . flip unfoldr s $ \sq ->
+        case Seq.viewl sq of
+            Seq.EmptyL -> Nothing
+            (Seq.:<) e sq' -> Just (e,sq')
+    get = fmap Seq.fromList get
+
+#endif
+
+------------------------------------------------------------------------
+-- Trees
+
+instance (Binary e) => Binary (T.Tree e) where
+    put (T.Node r s) = put r >> put s
+    get = liftM2 T.Node get get
+
+------------------------------------------------------------------------
+-- Arrays
+
+instance (Binary i, Ix i, Binary e) => Binary (Array i e) where
+    put a = put (bounds a) >> put (elems a)
+    get = liftM2 listArray get get
+
+--
+-- The IArray UArray e constraint is non portable. Requires flexible instances
+--
+instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where
+    put a = put (bounds a) >> put (elems a)
+    get = liftM2 listArray get get
diff --git a/src/Data/Binary/Builder.hs b/src/Data/Binary/Builder.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Binary/Builder.hs
@@ -0,0 +1,348 @@
+{-# 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
+
+  ) where
+
+import Foreign
+import Data.Monoid
+import Data.Word
+import Data.ByteString.Base (inlinePerformIO)
+import qualified Data.ByteString      as S
+import qualified Data.ByteString.Base as S
+import qualified Data.ByteString.Lazy as L
+
+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
+import GHC.Base
+import GHC.Word (Word32(..),Word16(..),Word64(..))
+#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
+    mappend = append
+
+------------------------------------------------------------------------
+
+-- | /O(1)./ The empty Builder, satisfying
+--
+--  * @'toLazyByteString' 'empty' = 'L.empty'@
+--
+empty :: Builder
+empty = Builder id
+
+-- | /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)
+
+-- | /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 :)
+
+-- | /O(1)./ A Builder taking a lazy 'L.ByteString', satisfying
+--
+--  * @'toLazyByteString' ('fromLazyByteString' bs) = bs@
+--
+fromLazyByteString :: L.ByteString -> Builder
+fromLazyByteString (S.LPS [])  = empty
+fromLazyByteString (S.LPS bss) = flush `append` mapBuilder (bss ++)
+
+------------------------------------------------------------------------
+
+-- 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 = S.LPS $ inlinePerformIO $ 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 [1] 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
+
+------------------------------------------------------------------------
+
+--
+-- 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)
+
+------------------------------------------------------------------------
+-- Unchecked shifts
+
+shiftr_w16 :: Word16 -> Int -> Word16
+shiftr_w32 :: Word32 -> Int -> Word32
+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)
+
+foreign import ccall unsafe "stg_uncheckedShiftRL64"     
+    uncheckedShiftRL64#     :: Word64# -> Int# -> Word64#
+#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
new file mode 100644
--- /dev/null
+++ b/src/Data/Binary/Get.hs
@@ -0,0 +1,323 @@
+{-# 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
+
+    -- * Parsing
+    , skip
+    , uncheckedSkip
+    , lookAhead
+    , lookAheadM
+    , lookAheadE
+    , uncheckedLookAhead
+    , getBytes
+    , remaining
+    , isEmpty
+
+    -- * Parsing particular types
+    , getWord8
+
+    -- ** ByteStrings
+    , getByteString
+    , getLazyByteString
+
+    -- ** Big-endian reads
+    , getWord16be
+    , getWord16le
+    , getWord32be
+
+    -- ** Little-endian reads
+    , getWord32le
+    , getWord64be
+    , getWord64le
+
+  ) where
+
+import Control.Monad (liftM,when)
+import Data.Maybe (isNothing)
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base as B
+import qualified Data.ByteString.Lazy as L
+
+import Foreign
+
+#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)
+import GHC.Base
+import GHC.Word
+import GHC.Int
+#endif
+
+-- | The parse state
+data S = S {-# UNPACK #-} !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 -> let (a, s') = unGet m s
+                          in (f a, s'))
+
+instance Monad Get where
+    return a  = Get (\s -> (a, s))
+    m >>= k   = Get (\s -> let (a, s') = unGet m s
+                           in unGet (k a) s')
+    fail      = failDesc
+
+------------------------------------------------------------------------
+
+get :: Get S
+get   = Get (\s -> (s, s))
+
+put :: S -> Get ()
+put s = Get (\_ -> ((), s))
+
+------------------------------------------------------------------------
+
+-- | 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 (S str 0) of (a, _) -> a
+
+------------------------------------------------------------------------
+
+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 n (const ())
+
+-- | Skip ahead @n@ bytes. 
+uncheckedSkip :: Int -> Get ()
+uncheckedSkip n = do
+    S s bytes <- get
+    let rest = L.drop (fromIntegral n) s
+    put $! S rest (bytes + (fromIntegral n))
+    return ()
+
+-- | Run @ga@, but return withou 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 @g@ 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 @g@ 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 :: Int -> Get L.ByteString
+uncheckedLookAhead n = do
+    S s _ <- get
+    return $ L.take (fromIntegral n) s
+
+-- | 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 _ <- get
+    return (L.length s)
+
+-- | Test whether all input has been consumed,
+-- i.e. there are no remaining unparsed bytes.
+isEmpty :: Get Bool
+isEmpty = do
+    S s _ <- get
+    return (L.null s)
+
+------------------------------------------------------------------------
+-- Helpers
+
+-- Fail if the ByteString does not have the right size.
+takeExactly :: Int -> L.ByteString -> Get L.ByteString
+takeExactly n bs
+    | l == n    = return bs
+    | otherwise = fail $ concat [ "Data.Binary.Get.takeExactly: Wanted "
+                                , show n, " bytes, found ", show l, "." ]
+  where l = fromIntegral (L.length bs)
+{-# INLINE takeExactly #-}
+
+-- | Pull up to @n@ bytes from the input. 
+getBytes :: Int -> Get L.ByteString
+getBytes n = do
+    S s bytes <- get
+    let (consuming, rest) = L.splitAt (fromIntegral n) s
+    put $! S rest (bytes + (fromIntegral n))
+    return consuming
+{-# INLINE getBytes #-}
+-- ^ important
+
+-- Pull n bytes from the input, and apply a parser to those bytes,
+-- yielding a value
+readN :: Int -> (L.ByteString -> a) -> Get a
+readN n f = liftM f (getBytes n >>= takeExactly n)
+{-# INLINE readN #-}
+-- ^ important
+
+------------------------------------------------------------------------
+
+-- | An efficient 'get' method for strict ByteStrings
+getByteString :: Int -> Get B.ByteString
+getByteString n = readN (fromIntegral n) (B.concat . L.toChunks)
+{-# INLINE getByteString #-}
+
+-- | An efficient 'get' method for lazy ByteStrings. Fails if fewer than
+-- @n@ bytes are left in the input.
+getLazyByteString :: Int -> Get L.ByteString
+getLazyByteString n = readN n id
+{-# INLINE getLazyByteString #-}
+
+------------------------------------------------------------------------
+-- Primtives
+
+-- | Read a Word8 from the monad state
+getWord8 :: Get Word8
+getWord8 = readN 1 L.head
+{-# INLINE getWord8 #-}
+
+-- | Read a Word16 in big endian format
+getWord16be :: Get Word16
+getWord16be = do
+    s <- readN 2 (L.take 2)
+    return $! (fromIntegral (s `L.index` 0) `shiftl_w16` 8) .|.
+              (fromIntegral (s `L.index` 1))
+{-# INLINE getWord16be #-}
+
+-- | Read a Word16 in little endian format
+getWord16le :: Get Word16
+getWord16le = do
+    w1 <- liftM fromIntegral getWord8
+    w2 <- liftM fromIntegral getWord8
+    return $! w2 `shiftl_w16` 8 .|. w1
+{-# INLINE getWord16le #-}
+
+-- | Read a Word32 in big endian format
+getWord32be :: Get Word32
+getWord32be = do
+    s <- readN 4 (L.take 4)
+    return $! (fromIntegral (s `L.index` 0) `shiftl_w32` 24) .|.
+              (fromIntegral (s `L.index` 1) `shiftl_w32` 16) .|.
+              (fromIntegral (s `L.index` 2) `shiftl_w32`  8) .|.
+              (fromIntegral (s `L.index` 3) )
+{-# INLINE getWord32be #-}
+
+-- | Read a Word32 in little endian format
+getWord32le :: Get Word32
+getWord32le = do
+    w1 <- liftM fromIntegral getWord8
+    w2 <- liftM fromIntegral getWord8
+    w3 <- liftM fromIntegral getWord8
+    w4 <- liftM fromIntegral getWord8
+    return $! (w4 `shiftl_w32` 24) .|.
+              (w3 `shiftl_w32` 16) .|.
+              (w2 `shiftl_w32`  8) .|.
+              (w1)
+{-# INLINE getWord32le #-}
+
+-- | Read a Word64 in big endian format
+getWord64be :: Get Word64
+getWord64be = do
+    s <- readN 8 (L.take 8)
+    return $! (fromIntegral (s `L.index` 0) `shiftl_w64` 56) .|.
+              (fromIntegral (s `L.index` 1) `shiftl_w64` 48) .|.
+              (fromIntegral (s `L.index` 2) `shiftl_w64` 40) .|.
+              (fromIntegral (s `L.index` 3) `shiftl_w64` 32) .|.
+              (fromIntegral (s `L.index` 4) `shiftl_w64` 24) .|.
+              (fromIntegral (s `L.index` 5) `shiftl_w64` 16) .|.
+              (fromIntegral (s `L.index` 6) `shiftl_w64`  8) .|.
+              (fromIntegral (s `L.index` 7) )
+{-# INLINE getWord64be #-}
+
+-- | Read a Word64 in little endian format
+getWord64le :: Get Word64
+getWord64le = do
+    w1 <- liftM fromIntegral getWord8
+    w2 <- liftM fromIntegral getWord8
+    w3 <- liftM fromIntegral getWord8
+    w4 <- liftM fromIntegral getWord8
+    w5 <- liftM fromIntegral getWord8
+    w6 <- liftM fromIntegral getWord8
+    w7 <- liftM fromIntegral getWord8
+    w8 <- liftM fromIntegral getWord8
+    return $! (w8 `shiftl_w64` 56) .|.
+              (w7 `shiftl_w64` 48) .|.
+              (w6 `shiftl_w64` 40) .|.
+              (w5 `shiftl_w64` 32) .|.
+              (w4 `shiftl_w64` 24) .|.
+              (w3 `shiftl_w64` 16) .|.
+              (w2 `shiftl_w64`  8) .|.
+              (w1)
+{-# INLINE getWord64le #-}
+
+------------------------------------------------------------------------
+-- 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)
+
+foreign import ccall unsafe "stg_uncheckedShiftL64"     
+    uncheckedShiftL64#     :: Word64# -> Int# -> Word64#
+#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
new file mode 100644
--- /dev/null
+++ b/src/Data/Binary/Put.hs
@@ -0,0 +1,126 @@
+-----------------------------------------------------------------------------
+-- |
+-- 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
+    , runPut
+
+    -- * Flushing the implicit parse state
+    , flush
+
+    -- * Primitives
+    , putWord8
+    , putByteString
+    , putLazyByteString
+
+    -- * Big-endian primitives
+    , putWord16be
+    , putWord32be
+    , putWord64be
+
+    -- * Little-endian primitives
+    , putWord16le
+    , putWord32le
+    , putWord64le
+
+  ) where
+
+import Data.Binary.Builder (Builder, toLazyByteString)
+import qualified Data.Binary.Builder as B
+
+import Data.Word
+import qualified Data.ByteString.Base as S
+import qualified Data.ByteString.Lazy as L
+
+------------------------------------------------------------------------
+
+-- | The Put types. A Writer monad over the efficient Builder monoid.
+-- Put merely lifts Builder into a monad
+newtype PutM a = Put { unPut :: (a, Builder) }
+type Put = PutM ()
+
+instance Functor PutM where
+        fmap f m = Put (let (a, w) = unPut m
+                         in (f a, w))
+
+instance Monad PutM where
+        return a = Put (a, B.empty)
+
+        m >>= k  = Put (let (a, w)  = unPut m
+                            (b, w') = unPut (k a)
+                         in (b, w `B.append` w'))
+
+        m1 >> m2 = Put (let (_, w)  = unPut m1
+                            (b, w') = unPut m2
+                         in (b, w `B.append` w'))
+        {-# INlINE (>>) #-}
+
+tell :: Builder -> Put
+tell b = Put ((), b)
+{-# INlINE tell #-}
+
+-- | Run the 'Put' monad with a serialiser
+runPut              :: Put -> L.ByteString
+runPut              = toLazyByteString . snd . unPut
+{-# INLINE runPut #-}
+
+-- | Pop the ByteString we have constructed so far, if any, yielding a
+-- new chunk in the result ByteString.
+flush               :: Put
+flush               = tell B.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
+
+-- | Write a lazy ByteString efficiently, simply appending the lazy
+-- ByteString chunks to the output buffer
+putLazyByteString   :: L.ByteString -> Put
+putLazyByteString   = tell . B.fromLazyByteString
+
+-- | Write a Word16 in big endian format
+putWord16be         :: Word16 -> Put
+putWord16be         = tell . B.putWord16be
+
+-- | Write a Word16 in little endian format
+putWord16le         :: Word16 -> Put
+putWord16le         = tell . B.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 #-}
diff --git a/tests/Benchmark.hs b/tests/Benchmark.hs
new file mode 100644
--- /dev/null
+++ b/tests/Benchmark.hs
@@ -0,0 +1,590 @@
+module Main (main) where
+
+import qualified Data.ByteString.Lazy as L
+import Data.Binary
+import Data.Binary.Put
+import Data.Binary.Get
+
+import Control.Exception
+import System.CPUTime
+import Numeric
+
+import MemBench
+
+mb :: Int
+mb = 10
+
+main :: IO ()
+main = do
+  memBench (mb*10)
+  putStrLn ""
+  putStrLn "Binary (de)serialisation benchmarks:"
+  sequence_
+    [ test wordSize chunkSize mb
+    | wordSize  <- [1,2,4,8]
+    , chunkSize <- [1,2,4,8,16] ]
+
+time :: IO a -> IO Double
+time action = do
+    start <- getCPUTime
+    action
+    end   <- getCPUTime
+    return $! (fromIntegral (end - start)) / (10^12)
+
+test :: Int -> Int -> Int -> IO ()
+test wordSize chunkSize mb = do
+    let bytes :: Int
+        bytes = mb * 2^20
+        iterations = bytes `div` wordSize
+        bs  = runPut (doPut wordSize chunkSize iterations)
+        sum = runGet (doGet wordSize chunkSize iterations) bs
+    putStr $ show mb ++ "MB of Word" ++ show (8 * wordSize)
+          ++ " in chunks of " ++ show chunkSize ++ ": "
+    putSeconds <- time $ evaluate (L.length bs)
+    getSeconds <- time $ evaluate sum
+--    print (L.length bs, sum)
+    let putThroughput = fromIntegral mb / putSeconds
+        getThroughput = fromIntegral mb / getSeconds
+    putStrLn $ showFFloat (Just 1) putThroughput "MB/s write, "
+            ++ showFFloat (Just 1) getThroughput "MB/s read"
+
+doPut :: Int -> Int -> Int -> Put
+doPut wordSize chunkSize =
+  case (wordSize, chunkSize) of
+    (1, 1)  -> putWord8N1
+    (1, 2)  -> putWord8N2
+    (1, 4)  -> putWord8N4
+    (1, 8)  -> putWord8N8
+    (1, 16) -> putWord8N16
+    (2, 1)  -> putWord16N1
+    (2, 2)  -> putWord16N2
+    (2, 4)  -> putWord16N4
+    (2, 8)  -> putWord16N8
+    (2, 16) -> putWord16N16
+    (4, 1)  -> putWord32N1
+    (4, 2)  -> putWord32N2
+    (4, 4)  -> putWord32N4
+    (4, 8)  -> putWord32N8
+    (4, 16) -> putWord32N16
+    (8, 1)  -> putWord64N1
+    (8, 2)  -> putWord64N2
+    (8, 4)  -> putWord64N4
+    (8, 8)  -> putWord64N8
+    (8, 16) -> putWord64N16
+
+putWord8N1 = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop _ 0 = return ()
+        loop s n = do
+          putWord8 (s+0)
+          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)
+
+
+putWord16N1 = 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)
+
+putWord16N2 = 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)
+
+putWord16N4 = 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)
+
+putWord16N8 = 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)
+
+putWord16N16 = 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)
+
+
+putWord32N1 = 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)
+
+putWord32N2 = 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)
+
+putWord32N4 = 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)
+
+putWord32N8 = 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)
+
+putWord32N16 = 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)
+
+putWord64N1 = 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)
+
+putWord64N2 = 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)
+
+putWord64N4 = 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)
+
+putWord64N8 = 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)
+
+putWord64N16 = 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)
+
+
+doGet :: Int -> Int -> Int -> Get Int
+doGet wordSize chunkSize =
+  case (wordSize, chunkSize) 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)  -> fmap fromIntegral . getWord16N1
+    (2, 2)  -> fmap fromIntegral . getWord16N2
+    (2, 4)  -> fmap fromIntegral . getWord16N4
+    (2, 8)  -> fmap fromIntegral . getWord16N8
+    (2, 16) -> fmap fromIntegral . getWord16N16
+    (4, 1)  -> fmap fromIntegral . getWord32N1
+    (4, 2)  -> fmap fromIntegral . getWord32N2
+    (4, 4)  -> fmap fromIntegral . getWord32N4
+    (4, 8)  -> fmap fromIntegral . getWord32N8
+    (4, 16) -> fmap fromIntegral . getWord32N16
+    (8, 1)  -> fmap fromIntegral . getWord64N1
+    (8, 2)  -> fmap fromIntegral . getWord64N2
+    (8, 4)  -> fmap fromIntegral . getWord64N4
+    (8, 8)  -> fmap fromIntegral . getWord64N8
+    (8, 16) -> fmap fromIntegral . getWord64N16
+
+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)
+
+
+getWord16N1 = 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)
+
+getWord16N2 = 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)
+
+getWord16N4 = 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)
+
+getWord16N8 = 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)
+
+getWord16N16 = 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)
+
+
+getWord32N1 = 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)
+
+getWord32N2 = 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)
+
+getWord32N4 = 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)
+
+getWord32N8 = 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)
+
+getWord32N16 = 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)
+
+getWord64N1 = 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)
+
+getWord64N2 = 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)
+
+getWord64N4 = 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)
+
+getWord64N8 = 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)
+
+getWord64N16 = 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)
diff --git a/tests/CBenchmark.c b/tests/CBenchmark.c
new file mode 100644
--- /dev/null
+++ b/tests/CBenchmark.c
@@ -0,0 +1,39 @@
+#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 int *a, int bytes) {
+  unsigned int n = 0;
+  int i = 0;
+  int iterations = bytes / sizeof(unsigned int) ;
+  while (i < iterations) {
+    a[i++] = n++;
+  }
+}
+
+unsigned int wordread(unsigned int *a, int bytes) {
+  unsigned int n = 0;
+  int i = 0;
+  int iterations = bytes / sizeof(unsigned int);
+  while (i < iterations) {
+    n += a[i++];
+  }
+  return n;
+}
diff --git a/tests/CBenchmark.h b/tests/CBenchmark.h
new file mode 100644
--- /dev/null
+++ b/tests/CBenchmark.h
@@ -0,0 +1,4 @@
+void bytewrite(unsigned char *a, int bytes);
+unsigned char byteread(unsigned char *a, int bytes);
+void wordwrite(unsigned int *a, int bytes);
+unsigned int wordread(unsigned int *a, int bytes);
diff --git a/tests/Makefile b/tests/Makefile
new file mode 100644
--- /dev/null
+++ b/tests/Makefile
@@ -0,0 +1,27 @@
+all: compiled
+     
+interpreted:
+	runhaskell QC.hs 1000
+
+compiled:
+	ghc --make -O QC.hs -o qc -no-recomp
+	time ./qc 1000
+
+bench:: Benchmark.hs MemBench.hs CBenchmark.o
+	ghc --make -O Benchmark.hs -fasm CBenchmark.o -o bench -no-recomp
+	time ./bench
+
+bench-nb::
+	ghc --make -O NewBenchmark.hs -fasm -o bench-nb
+	time ./bench-nb
+
+CBenchmark.o: CBenchmark.c
+	gcc -O -c $< -o $@
+
+hugs:
+	runhugs -98 QC.hs  
+
+clean:
+	rm -f *.o *.hi qc bench bench-nb *~
+
+.PHONY: clean bench bench-nb
diff --git a/tests/MemBench.hs b/tests/MemBench.hs
new file mode 100644
--- /dev/null
+++ b/tests/MemBench.hs
@@ -0,0 +1,85 @@
+{-# OPTIONS_GHC -fffi -fbang-patterns #-}
+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 CUInt -> Int -> IO ()
+hs_wordwrite ptr bytes = loop 0 0
+  where iterations = bytes `div` sizeOf (undefined :: CUInt)
+        loop :: Int -> CUInt -> IO ()
+        loop !i !n | i == iterations = return ()
+                   | otherwise = do pokeByteOff ptr i n
+                                    loop (i+1) (n+1)
+
+hs_wordread  :: Ptr CUInt -> Int -> IO CUInt
+hs_wordread ptr bytes = loop 0 0
+  where iterations = bytes `div` sizeOf (undefined :: CUInt)
+        loop :: Int -> CUInt -> IO CUInt
+        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)
diff --git a/tests/NewBenchmark.hs b/tests/NewBenchmark.hs
new file mode 100644
--- /dev/null
+++ b/tests/NewBenchmark.hs
@@ -0,0 +1,625 @@
+--
+-- benchmark NewBinary
+--
+
+module Main where
+
+import System.IO
+import Data.Word
+import NewBinary
+
+import Control.Exception
+import System.CPUTime
+import Numeric
+
+mb :: Int
+mb = 10
+
+main :: IO ()
+main = sequence_ 
+  [ test wordSize chunkSize mb
+  | wordSize  <- [1,2,4,8]
+  , chunkSize <- [1,2,4,8,16] ]
+
+time :: IO a -> IO Double
+time action = do
+    start <- getCPUTime
+    action
+    end   <- getCPUTime
+    return $! (fromIntegral (end - start)) / (10^12)
+
+test :: Int -> Int -> Int -> IO ()
+test wordSize chunkSize mb = do
+    let bytes :: Int
+        bytes = mb * 2^20
+        iterations = bytes `div` wordSize
+    putStr $ show mb ++ "MB of Word" ++ show (8 * wordSize)
+          ++ " in chunks of " ++ show chunkSize ++ ": "
+    h <- openBinMem bytes undefined
+    start <- tellBin h
+    putSeconds <- time $ do
+      doPut wordSize chunkSize h iterations
+--      BinPtr n _ <- tellBin h
+--      print n
+    getSeconds <- time $ do
+      seekBin h start
+      sum <- doGet wordSize chunkSize h iterations
+      evaluate sum
+--      BinPtr n _ <- tellBin h
+--      print (n, sum)
+    let putThroughput = fromIntegral mb / putSeconds
+        getThroughput = fromIntegral mb / getSeconds
+    putStrLn $ showFFloat (Just 2) putThroughput "MB/s write, "
+            ++ showFFloat (Just 2) getThroughput "MB/s read"
+
+doPut :: Int -> Int -> BinHandle -> Int -> IO ()
+doPut wordSize chunkSize =
+  case (wordSize, chunkSize) of
+    (1, 1)  -> putWord8N1
+    (1, 2)  -> putWord8N2
+    (1, 4)  -> putWord8N4
+    (1, 8)  -> putWord8N8
+    (1, 16) -> putWord8N16
+    (2, 1)  -> putWord16N1
+    (2, 2)  -> putWord16N2
+    (2, 4)  -> putWord16N4
+    (2, 8)  -> putWord16N8
+    (2, 16) -> putWord16N16
+    (4, 1)  -> putWord32N1
+    (4, 2)  -> putWord32N2
+    (4, 4)  -> putWord32N4
+    (4, 8)  -> putWord32N8
+    (4, 16) -> putWord32N16
+    (8, 1)  -> putWord64N1
+    (8, 2)  -> putWord64N2
+    (8, 4)  -> putWord64N4
+    (8, 8)  -> putWord64N8
+    (8, 16) -> putWord64N16
+
+putWord8 :: BinHandle -> Word8 -> IO ()
+putWord8 = put_
+{-# INLINE putWord8 #-}
+
+putWord16be :: BinHandle -> Word16 -> IO ()
+putWord16be = put_
+{-# INLINE putWord16be #-}
+
+putWord32be :: BinHandle -> Word32 -> IO ()
+putWord32be = put_
+{-# INLINE putWord32be #-}
+
+putWord64be :: BinHandle -> Word64 -> IO ()
+putWord64be = put_
+{-# INLINE putWord64be #-}
+
+getWord8 :: BinHandle -> IO Word8
+getWord8 = get
+{-# INLINE getWord8 #-}
+
+getWord16be :: BinHandle -> IO Word16
+getWord16be = get
+{-# INLINE getWord16be #-}
+
+getWord32be :: BinHandle -> IO Word32
+getWord32be = get
+{-# INLINE getWord32be #-}
+
+getWord64be :: BinHandle -> IO Word64
+getWord64be = get
+{-# INLINE getWord64be #-}
+
+putWord8N1 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop _ 0 = return ()
+        loop s n = do
+          putWord8 hnd (s+0)
+          loop (s+1) (n-1)
+
+putWord8N2 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop _ 0 = return ()
+        loop s n = do
+          putWord8 hnd (s+0)
+          putWord8 hnd (s+1)
+          loop (s+2) (n-2)
+
+putWord8N4 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop _ 0 = return ()
+        loop s n = do
+          putWord8 hnd (s+0)
+          putWord8 hnd (s+1)
+          putWord8 hnd (s+2)
+          putWord8 hnd (s+3)
+          loop (s+4) (n-4)
+
+putWord8N8 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop _ 0 = return ()
+        loop s n = do
+          putWord8 hnd (s+0)
+          putWord8 hnd (s+1)
+          putWord8 hnd (s+2)
+          putWord8 hnd (s+3)
+          putWord8 hnd (s+4)
+          putWord8 hnd (s+5)
+          putWord8 hnd (s+6)
+          putWord8 hnd (s+7)
+          loop (s+8) (n-8)
+
+putWord8N16 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop _ 0 = return ()
+        loop s n = do
+          putWord8 hnd (s+0)
+          putWord8 hnd (s+1)
+          putWord8 hnd (s+2)
+          putWord8 hnd (s+3)
+          putWord8 hnd (s+4)
+          putWord8 hnd (s+5)
+          putWord8 hnd (s+6)
+          putWord8 hnd (s+7)
+          putWord8 hnd (s+8)
+          putWord8 hnd (s+9)
+          putWord8 hnd (s+10)
+          putWord8 hnd (s+11)
+          putWord8 hnd (s+12)
+          putWord8 hnd (s+13)
+          putWord8 hnd (s+14)
+          putWord8 hnd (s+15)
+          loop (s+16) (n-16)
+
+
+putWord16N1 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop _ 0 = return ()
+        loop s n = do
+          putWord16be hnd (s+0)
+          loop (s+1) (n-1)
+
+putWord16N2 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop _ 0 = return ()
+        loop s n = do
+          putWord16be hnd (s+0)
+          putWord16be hnd (s+1)
+          loop (s+2) (n-2)
+
+putWord16N4 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop _ 0 = return ()
+        loop s n = do
+          putWord16be hnd (s+0)
+          putWord16be hnd (s+1)
+          putWord16be hnd (s+2)
+          putWord16be hnd (s+3)
+          loop (s+4) (n-4)
+
+putWord16N8 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop _ 0 = return ()
+        loop s n = do
+          putWord16be hnd (s+0)
+          putWord16be hnd (s+1)
+          putWord16be hnd (s+2)
+          putWord16be hnd (s+3)
+          putWord16be hnd (s+4)
+          putWord16be hnd (s+5)
+          putWord16be hnd (s+6)
+          putWord16be hnd (s+7)
+          loop (s+8) (n-8)
+
+putWord16N16 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop _ 0 = return ()
+        loop s n = do
+          putWord16be hnd (s+0)
+          putWord16be hnd (s+1)
+          putWord16be hnd (s+2)
+          putWord16be hnd (s+3)
+          putWord16be hnd (s+4)
+          putWord16be hnd (s+5)
+          putWord16be hnd (s+6)
+          putWord16be hnd (s+7)
+          putWord16be hnd (s+8)
+          putWord16be hnd (s+9)
+          putWord16be hnd (s+10)
+          putWord16be hnd (s+11)
+          putWord16be hnd (s+12)
+          putWord16be hnd (s+13)
+          putWord16be hnd (s+14)
+          putWord16be hnd (s+15)
+          loop (s+16) (n-16)
+
+
+putWord32N1 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop _ 0 = return ()
+        loop s n = do
+          putWord32be hnd (s+0)
+          loop (s+1) (n-1)
+
+putWord32N2 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop _ 0 = return ()
+        loop s n = do
+          putWord32be hnd (s+0)
+          putWord32be hnd (s+1)
+          loop (s+2) (n-2)
+
+putWord32N4 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop _ 0 = return ()
+        loop s n = do
+          putWord32be hnd (s+0)
+          putWord32be hnd (s+1)
+          putWord32be hnd (s+2)
+          putWord32be hnd (s+3)
+          loop (s+4) (n-4)
+
+putWord32N8 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop _ 0 = return ()
+        loop s n = do
+          putWord32be hnd (s+0)
+          putWord32be hnd (s+1)
+          putWord32be hnd (s+2)
+          putWord32be hnd (s+3)
+          putWord32be hnd (s+4)
+          putWord32be hnd (s+5)
+          putWord32be hnd (s+6)
+          putWord32be hnd (s+7)
+          loop (s+8) (n-8)
+
+putWord32N16 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop _ 0 = return ()
+        loop s n = do
+          putWord32be hnd (s+0)
+          putWord32be hnd (s+1)
+          putWord32be hnd (s+2)
+          putWord32be hnd (s+3)
+          putWord32be hnd (s+4)
+          putWord32be hnd (s+5)
+          putWord32be hnd (s+6)
+          putWord32be hnd (s+7)
+          putWord32be hnd (s+8)
+          putWord32be hnd (s+9)
+          putWord32be hnd (s+10)
+          putWord32be hnd (s+11)
+          putWord32be hnd (s+12)
+          putWord32be hnd (s+13)
+          putWord32be hnd (s+14)
+          putWord32be hnd (s+15)
+          loop (s+16) (n-16)
+
+putWord64N1 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop _ 0 = return ()
+        loop s n = do
+          putWord64be hnd (s+0)
+          loop (s+1) (n-1)
+
+putWord64N2 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop _ 0 = return ()
+        loop s n = do
+          putWord64be hnd (s+0)
+          putWord64be hnd (s+1)
+          loop (s+2) (n-2)
+
+putWord64N4 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop _ 0 = return ()
+        loop s n = do
+          putWord64be hnd (s+0)
+          putWord64be hnd (s+1)
+          putWord64be hnd (s+2)
+          putWord64be hnd (s+3)
+          loop (s+4) (n-4)
+
+putWord64N8 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop _ 0 = return ()
+        loop s n = do
+          putWord64be hnd (s+0)
+          putWord64be hnd (s+1)
+          putWord64be hnd (s+2)
+          putWord64be hnd (s+3)
+          putWord64be hnd (s+4)
+          putWord64be hnd (s+5)
+          putWord64be hnd (s+6)
+          putWord64be hnd (s+7)
+          loop (s+8) (n-8)
+
+putWord64N16 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop _ 0 = return ()
+        loop s n = do
+          putWord64be hnd (s+0)
+          putWord64be hnd (s+1)
+          putWord64be hnd (s+2)
+          putWord64be hnd (s+3)
+          putWord64be hnd (s+4)
+          putWord64be hnd (s+5)
+          putWord64be hnd (s+6)
+          putWord64be hnd (s+7)
+          putWord64be hnd (s+8)
+          putWord64be hnd (s+9)
+          putWord64be hnd (s+10)
+          putWord64be hnd (s+11)
+          putWord64be hnd (s+12)
+          putWord64be hnd (s+13)
+          putWord64be hnd (s+14)
+          putWord64be hnd (s+15)
+          loop (s+16) (n-16)
+
+doGet :: Int -> Int -> BinHandle -> Int ->  IO Int
+doGet wordSize chunkSize hnd =
+  case (wordSize, chunkSize) of
+    (1, 1)  -> fmap fromIntegral . getWord8N1 hnd
+    (1, 2)  -> fmap fromIntegral . getWord8N2 hnd
+    (1, 4)  -> fmap fromIntegral . getWord8N4 hnd
+    (1, 8)  -> fmap fromIntegral . getWord8N8 hnd
+    (1, 16) -> fmap fromIntegral . getWord8N16 hnd
+    (2, 1)  -> fmap fromIntegral . getWord16N1 hnd
+    (2, 2)  -> fmap fromIntegral . getWord16N2 hnd
+    (2, 4)  -> fmap fromIntegral . getWord16N4 hnd
+    (2, 8)  -> fmap fromIntegral . getWord16N8 hnd
+    (2, 16) -> fmap fromIntegral . getWord16N16 hnd
+    (4, 1)  -> fmap fromIntegral . getWord32N1 hnd
+    (4, 2)  -> fmap fromIntegral . getWord32N2 hnd
+    (4, 4)  -> fmap fromIntegral . getWord32N4 hnd
+    (4, 8)  -> fmap fromIntegral . getWord32N8 hnd
+    (4, 16) -> fmap fromIntegral . getWord32N16 hnd
+    (8, 1)  -> fmap fromIntegral . getWord64N1 hnd
+    (8, 2)  -> fmap fromIntegral . getWord64N2 hnd
+    (8, 4)  -> fmap fromIntegral . getWord64N4 hnd
+    (8, 8)  -> fmap fromIntegral . getWord64N8 hnd
+    (8, 16) -> fmap fromIntegral . getWord64N16 hnd
+
+getWord8N1 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop s 0 = return s
+        loop s n = do
+          s0 <- getWord8 hnd
+          loop (s+s0) (n-1)
+
+getWord8N2 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop s 0 = return s
+        loop s n = do
+          s0 <- getWord8 hnd
+          s1 <- getWord8 hnd
+          loop (s+s0+s1) (n-2)
+
+getWord8N4 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop s 0 = return s
+        loop s n = do
+          s0 <- getWord8 hnd
+          s1 <- getWord8 hnd
+          s2 <- getWord8 hnd
+          s3 <- getWord8 hnd
+          loop (s+s0+s1+s2+s3) (n-4)
+
+getWord8N8 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop s 0 = return s
+        loop s n = do
+          s0 <- getWord8 hnd
+          s1 <- getWord8 hnd
+          s2 <- getWord8 hnd
+          s3 <- getWord8 hnd
+          s4 <- getWord8 hnd
+          s5 <- getWord8 hnd
+          s6 <- getWord8 hnd
+          s7 <- getWord8 hnd
+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)
+
+getWord8N16 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop s 0 = return s
+        loop s n = do
+          s0 <- getWord8 hnd
+          s1 <- getWord8 hnd
+          s2 <- getWord8 hnd
+          s3 <- getWord8 hnd
+          s4 <- getWord8 hnd
+          s5 <- getWord8 hnd
+          s6 <- getWord8 hnd
+          s7 <- getWord8 hnd
+          s8 <- getWord8 hnd
+          s9 <- getWord8 hnd
+          s10 <- getWord8 hnd
+          s11 <- getWord8 hnd
+          s12 <- getWord8 hnd
+          s13 <- getWord8 hnd
+          s14 <- getWord8 hnd
+          s15 <- getWord8 hnd
+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)
+
+
+getWord16N1 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop s 0 = return s
+        loop s n = do
+          s0 <- getWord16be hnd
+          loop (s+s0) (n-1)
+
+getWord16N2 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop s 0 = return s
+        loop s n = do
+          s0 <- getWord16be hnd
+          s1 <- getWord16be hnd
+          loop (s+s0+s1) (n-2)
+
+getWord16N4 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop s 0 = return s
+        loop s n = do
+          s0 <- getWord16be hnd
+          s1 <- getWord16be hnd
+          s2 <- getWord16be hnd
+          s3 <- getWord16be hnd
+          loop (s+s0+s1+s2+s3) (n-4)
+
+getWord16N8 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop s 0 = return s
+        loop s n = do
+          s0 <- getWord16be hnd
+          s1 <- getWord16be hnd
+          s2 <- getWord16be hnd
+          s3 <- getWord16be hnd
+          s4 <- getWord16be hnd
+          s5 <- getWord16be hnd
+          s6 <- getWord16be hnd
+          s7 <- getWord16be hnd
+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)
+
+getWord16N16 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop s 0 = return s
+        loop s n = do
+          s0 <- getWord16be hnd
+          s1 <- getWord16be hnd
+          s2 <- getWord16be hnd
+          s3 <- getWord16be hnd
+          s4 <- getWord16be hnd
+          s5 <- getWord16be hnd
+          s6 <- getWord16be hnd
+          s7 <- getWord16be hnd
+          s8 <- getWord16be hnd
+          s9 <- getWord16be hnd
+          s10 <- getWord16be hnd
+          s11 <- getWord16be hnd
+          s12 <- getWord16be hnd
+          s13 <- getWord16be hnd
+          s14 <- getWord16be hnd
+          s15 <- getWord16be hnd
+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)
+
+
+getWord32N1 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop s 0 = return s
+        loop s n = do
+          s0 <- getWord32be hnd
+          loop (s+s0) (n-1)
+
+getWord32N2 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop s 0 = return s
+        loop s n = do
+          s0 <- getWord32be hnd
+          s1 <- getWord32be hnd
+          loop (s+s0+s1) (n-2)
+
+getWord32N4 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop s 0 = return s
+        loop s n = do
+          s0 <- getWord32be hnd
+          s1 <- getWord32be hnd
+          s2 <- getWord32be hnd
+          s3 <- getWord32be hnd
+          loop (s+s0+s1+s2+s3) (n-4)
+
+getWord32N8 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop s 0 = return s
+        loop s n = do
+          s0 <- getWord32be hnd
+          s1 <- getWord32be hnd
+          s2 <- getWord32be hnd
+          s3 <- getWord32be hnd
+          s4 <- getWord32be hnd
+          s5 <- getWord32be hnd
+          s6 <- getWord32be hnd
+          s7 <- getWord32be hnd
+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)
+
+getWord32N16 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop s 0 = return s
+        loop s n = do
+          s0 <- getWord32be hnd
+          s1 <- getWord32be hnd
+          s2 <- getWord32be hnd
+          s3 <- getWord32be hnd
+          s4 <- getWord32be hnd
+          s5 <- getWord32be hnd
+          s6 <- getWord32be hnd
+          s7 <- getWord32be hnd
+          s8 <- getWord32be hnd
+          s9 <- getWord32be hnd
+          s10 <- getWord32be hnd
+          s11 <- getWord32be hnd
+          s12 <- getWord32be hnd
+          s13 <- getWord32be hnd
+          s14 <- getWord32be hnd
+          s15 <- getWord32be hnd
+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)
+
+getWord64N1 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop s 0 = return s
+        loop s n = do
+          s0 <- getWord64be hnd
+          loop (s+s0) (n-1)
+
+getWord64N2 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop s 0 = return s
+        loop s n = do
+          s0 <- getWord64be hnd
+          s1 <- getWord64be hnd
+          loop (s+s0+s1) (n-2)
+
+getWord64N4 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop s 0 = return s
+        loop s n = do
+          s0 <- getWord64be hnd
+          s1 <- getWord64be hnd
+          s2 <- getWord64be hnd
+          s3 <- getWord64be hnd
+          loop (s+s0+s1+s2+s3) (n-4)
+
+getWord64N8 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop s 0 = return s
+        loop s n = do
+          s0 <- getWord64be hnd
+          s1 <- getWord64be hnd
+          s2 <- getWord64be hnd
+          s3 <- getWord64be hnd
+          s4 <- getWord64be hnd
+          s5 <- getWord64be hnd
+          s6 <- getWord64be hnd
+          s7 <- getWord64be hnd
+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8)
+
+getWord64N16 hnd = loop 0
+  where loop s n | s `seq` n `seq` False = undefined
+        loop s 0 = return s
+        loop s n = do
+          s0 <- getWord64be hnd
+          s1 <- getWord64be hnd
+          s2 <- getWord64be hnd
+          s3 <- getWord64be hnd
+          s4 <- getWord64be hnd
+          s5 <- getWord64be hnd
+          s6 <- getWord64be hnd
+          s7 <- getWord64be hnd
+          s8 <- getWord64be hnd
+          s9 <- getWord64be hnd
+          s10 <- getWord64be hnd
+          s11 <- getWord64be hnd
+          s12 <- getWord64be hnd
+          s13 <- getWord64be hnd
+          s14 <- getWord64be hnd
+          s15 <- getWord64be hnd
+          loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16)
diff --git a/tests/NewBinary.hs b/tests/NewBinary.hs
new file mode 100644
--- /dev/null
+++ b/tests/NewBinary.hs
@@ -0,0 +1,1006 @@
+{-# OPTIONS -cpp -fglasgow-exts  #-}
+--
+-- (c) The University of Glasgow 2002
+--
+-- Binary I/O library, with special tweaks for GHC
+--
+-- Based on the nhc98 Binary library, which is copyright
+-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.
+-- Under the terms of the license for that software, we must tell you
+-- where you can obtain the original version of the Binary library, namely
+--     http://www.cs.york.ac.uk/fp/nhc98/
+
+module NewBinary
+  ( {-type-}  Bin,
+    {-class-} Binary(..),
+    {-type-}  BinHandle(..),
+
+   openBinIO, 
+   openBinIO_,
+   openBinMem,
+--   closeBin,
+
+--   getUserData,
+
+   seekBin,
+   tellBin,
+   tellBinByte,
+   castBin,
+
+   writeBinMem,
+   readBinMem,
+
+   isEOFBin,
+
+   -- for writing instances:
+   putByte,
+   getByte,
+
+   -- bit stuff
+   putBits,
+   getBits,
+   flushByte,
+   finishByte,
+   putMaybeInt,
+   getMaybeInt,
+
+   -- lazy Bin I/O
+   lazyGet,
+   lazyPut,
+
+   -- GHC only:
+   ByteArray(..),
+   getByteArray,
+   putByteArray,
+
+--   getBinFileWithDict,    -- :: Binary a => FilePath -> IO a
+--   putBinFileWithDict,    -- :: Binary a => FilePath -> Module -> a -> IO ()
+
+  ) where
+
+#include "MachDeps.h"
+
+import GHC.Exts
+import GHC.IOBase
+import GHC.Real
+import Data.Array.IO        ( IOUArray )
+import Data.Bits
+import Data.Int
+import Data.Word
+import Data.Char
+import Control.Monad
+import Control.Exception
+import Data.Array
+import Data.Array.IO
+import Data.Array.Base
+import System.IO as IO
+import System.IO.Error      ( mkIOError, eofErrorType )
+import GHC.Handle       
+import System.IO
+
+import GHC.Exts
+#if __GLASGOW_HASKELL__ >= 504
+import GHC.IOBase
+import Data.Word
+import Data.Bits
+#else
+import PrelIOBase
+import Word
+import Bits
+#endif
+
+#ifndef SIZEOF_HSINT
+#define SIZEOF_HSINT  INT_SIZE_IN_BYTES
+#endif
+
+#if __GLASGOW_HASKELL__ < 503
+type BinArray = MutableByteArray RealWorld Int
+newArray_ bounds     = stToIO (newCharArray bounds)
+unsafeWrite arr ix e = stToIO (writeWord8Array arr ix e)
+unsafeRead  arr ix   = stToIO (readWord8Array arr ix)
+
+hPutArray h arr sz   = hPutBufBA h arr sz
+hGetArray h sz       = hGetBufBA h sz
+
+mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> Exception
+mkIOError t location maybe_hdl maybe_filename
+  = IOException (IOError maybe_hdl t location ""
+                 maybe_filename
+        )
+
+eofErrorType = EOF
+
+#ifndef SIZEOF_HSINT
+#define SIZEOF_HSINT  INT_SIZE_IN_BYTES
+#endif
+
+#ifndef SIZEOF_HSWORD
+#define SIZEOF_HSWORD WORD_SIZE_IN_BYTES
+#endif
+
+#else
+type BinArray = IOUArray Int Word8
+#endif
+
+data BinHandle
+  = BinMem {        -- binary data stored in an unboxed array
+     off_r :: !FastMutInt,      -- the current offset
+     sz_r  :: !FastMutInt,      -- size of the array (cached)
+     arr_r :: !(IORef BinArray),    -- the array (bounds: (0,size-1))
+     bit_off_r :: !FastMutInt,          -- the bit offset (see end of file)
+     bit_cache_r :: !FastMutInt           -- the bit cache  (see end of file)
+    }
+    -- XXX: should really store a "high water mark" for dumping out
+    -- the binary data to a file.
+
+  | BinIO {     -- binary data stored in a file
+     off_r :: !FastMutInt,      -- the current offset (cached)
+     hdl   :: !IO.Handle,               -- the file handle (must be seekable)
+     bit_off_r :: !FastMutInt,          -- the bit offset (see end of file)
+     bit_cache_r :: !FastMutInt           -- the bit cache  (see end of file)
+   }
+    -- cache the file ptr in BinIO; using hTell is too expensive
+    -- to call repeatedly.  If anyone else is modifying this Handle
+    -- at the same time, we'll be screwed.
+
+data Bin a = BinPtr !Int !Int -- byte/bit
+  deriving (Eq, Ord, Show, Bounded)
+
+castBin :: Bin a -> Bin b
+castBin (BinPtr i j) = BinPtr i j
+
+class Binary a where
+    put_   :: BinHandle -> a -> IO ()
+    put    :: BinHandle -> a -> IO (Bin a)
+    get    :: BinHandle -> IO a
+
+    -- define one of put_, put.  Use of put_ is recommended because it
+    -- is more likely that tail-calls can kick in, and we rarely need the
+    -- position return value.
+    put_ bh a = do put bh a; return ()
+    put bh a  = do p <- tellBin bh; put_ bh a; return p
+
+putAt  :: Binary a => BinHandle -> Bin a -> a -> IO ()
+putAt bh p x = do seekBin bh p; put bh x; return ()
+
+getAt  :: Binary a => BinHandle -> Bin a -> IO a
+getAt bh p = do seekBin bh p; get bh
+
+openBinIO_ :: IO.Handle -> IO BinHandle
+openBinIO_ h = openBinIO h noBinHandleUserData
+
+newZeroInt = do r <- newFastMutInt; writeFastMutInt r 0; return r
+
+-- openBinIO :: IO.Handle -> Module -> IO BinHandle
+openBinIO :: forall t. Handle -> t -> IO BinHandle
+openBinIO h mod = do
+  r <- newZeroInt
+  o <- newZeroInt
+  c <- newZeroInt
+--  state <- newWriteState mod
+  return (BinIO r h o c)
+
+--openBinMem :: Int -> Module -> IO BinHandle
+openBinMem :: forall t. Int -> t -> IO BinHandle
+openBinMem size mod
+ | size <= 0 = error "Data.Binary.openBinMem: size must be > 0"   -- fix, was ">= 0"
+ | otherwise = do
+   arr <- newArray_ (0,size-1)
+   arr_r <- newIORef arr
+   ix_r <- newFastMutInt
+   writeFastMutInt ix_r 0
+   sz_r <- newFastMutInt
+   writeFastMutInt sz_r size
+   o <- newZeroInt
+   c <- newZeroInt
+--   state <- newWriteState mod
+   return (BinMem ix_r sz_r arr_r o c)
+
+noBinHandleUserData = error "Binary.BinHandle: no user data"
+
+--getUserData :: BinHandle -> BinHandleState
+--getUserData bh = state bh
+
+tellBin :: BinHandle -> IO (Bin a)
+tellBin (BinIO r _ o _)   =  do ix <- readFastMutInt r; bix <- readFastMutInt o; return (BinPtr ix bix)
+tellBin (BinMem r _ _ o _) = do ix <- readFastMutInt r; bix <- readFastMutInt o; return (BinPtr ix bix)
+
+tellBinByte (BinIO r _ _ _)    = do ix <- readFastMutInt r; return ix
+tellBinByte (BinMem r _ _ _ _) = do ix <- readFastMutInt r; return ix
+
+seekBin :: BinHandle -> Bin a -> IO ()
+seekBin bh@(BinIO ix_r h o c) (BinPtr p bit) = do 
+  writeFastMutInt ix_r p
+  writeFastMutInt o 0
+  writeFastMutInt c 0
+  hSeek h AbsoluteSeek (fromIntegral p)
+  when (bit /= 0) $ getBits bh bit >> return ()
+  return ()
+seekBin h@(BinMem ix_r sz_r a o c) (BinPtr p bit) = do
+  sz <- readFastMutInt sz_r
+  if (p >= sz)
+    then do expandBin h p
+            writeFastMutInt ix_r p
+            writeFastMutInt o 0
+            writeFastMutInt c 0
+            when (bit /= 0) $ getBits h bit >> return ()
+            return ()
+
+    else do writeFastMutInt ix_r p
+            writeFastMutInt o 0
+            writeFastMutInt c 0
+            when (bit /= 0) $ getBits h bit >> return ()
+            return ()
+
+isEOFBin :: BinHandle -> IO Bool
+isEOFBin (BinMem ix_r sz_r a _ _) = do
+  ix <- readFastMutInt ix_r
+  sz <- readFastMutInt sz_r
+  return (ix >= sz)
+isEOFBin (BinIO ix_r h _ _) = hIsEOF h
+
+writeBinMem :: BinHandle -> FilePath -> IO ()
+writeBinMem (BinIO _ _ _ _) _ = error "Data.Binary.writeBinMem: not a memory handle"
+writeBinMem bh@(BinMem ix_r sz_r arr_r bit_off_r bit_cache_r) fn = do
+  flushByte bh
+  h <- openBinaryFile fn WriteMode
+  arr <- readIORef arr_r
+  ix  <- readFastMutInt ix_r
+  hPutArray h arr ix
+  hClose h
+
+flushByte :: BinHandle -> IO ()
+flushByte bh = do
+  bit_off <- readFastMutInt (bit_off_r bh)
+  if bit_off == 0
+    then return ()
+    else putBits bh (8 - bit_off) 0
+
+finishByte :: BinHandle -> IO ()
+finishByte bh = do
+  bit_off <- readFastMutInt (bit_off_r bh)
+  if bit_off == 0
+    then return ()
+    else getBits bh (8 - bit_off) >> return ()
+
+readBinMem :: FilePath -> IO BinHandle
+readBinMem filename = do
+  h <- openBinaryFile filename ReadMode
+  filesize' <- hFileSize h
+  let filesize = fromIntegral filesize'
+  arr <- newArray_ (0,filesize-1)
+  count <- hGetArray h arr filesize
+  when (count /= filesize)
+    (error ("Binary.readBinMem: only read " ++ show count ++ " bytes"))
+  hClose h
+  arr_r <- newIORef arr
+  ix_r <- newFastMutInt
+  writeFastMutInt ix_r 0
+  sz_r <- newFastMutInt
+  writeFastMutInt sz_r filesize
+  bit_off_r <- newZeroInt
+  bit_cache_r <- newZeroInt
+  return (BinMem {-initReadState-} ix_r sz_r arr_r bit_off_r bit_cache_r)
+
+-- expand the size of the array to include a specified offset
+expandBin :: BinHandle -> Int -> IO ()
+expandBin (BinMem ix_r sz_r arr_r _ _) off = do
+   sz <- readFastMutInt sz_r
+   let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
+   arr <- readIORef arr_r
+   arr' <- newArray_ (0,sz'-1)
+   sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i
+         | i <- [ 0 .. sz-1 ] ]
+   writeFastMutInt sz_r sz'
+   writeIORef arr_r arr'
+--   hPutStrLn stderr ("expanding to size: " ++ show sz')
+   return ()
+expandBin (BinIO _ _ _ _) _ = return ()
+    -- no need to expand a file, we'll assume they expand by themselves.
+
+-- -----------------------------------------------------------------------------
+-- Low-level reading/writing of bytes
+
+putWord8 :: BinHandle -> Word8 -> IO ()
+putWord8 h@(BinMem ix_r sz_r arr_r bit_off_r bit_cache_r) w = do
+    bit_off <- readFastMutInt bit_off_r
+    if bit_off /= 0 then putBits h 8 w else do   -- only do standard putWord8 if bit_off == 0
+    ix <- readFastMutInt ix_r
+    sz <- readFastMutInt sz_r
+    -- double the size of the array if it overflows
+    if (ix >= sz) 
+        then do expandBin h ix
+                putWord8 h w
+        else do arr <- readIORef arr_r
+                unsafeWrite arr ix w
+                writeFastMutInt ix_r (ix+1)
+                return ()
+
+putWord8 bh@(BinIO ix_r h bit_off_r bit_cache_r) w = do
+    bit_off <- readFastMutInt bit_off_r
+    if bit_off /= 0 then putBits bh 8 w else do
+        ix <- readFastMutInt ix_r
+        hPutChar h (chr (fromIntegral w))   -- XXX not really correct
+        writeFastMutInt ix_r (ix+1)
+        return ()
+
+putByteNoBits :: BinHandle -> Word8 -> IO ()
+putByteNoBits h@(BinMem ix_r sz_r arr_r _ _) w = do
+    ix <- readFastMutInt ix_r
+    sz <- readFastMutInt sz_r
+    -- double the size of the array if it overflows
+    if (ix >= sz) 
+        then do expandBin h ix
+                putByteNoBits h w
+        else do arr <- readIORef arr_r
+                unsafeWrite arr ix w
+                writeFastMutInt ix_r (ix+1)
+                return ()
+
+putByteNoBits bh@(BinIO ix_r h _ _) w = do
+    hPutChar h (chr (fromIntegral w))   -- XXX not really correct
+    incFastMutInt ix_r
+    return ()
+
+getByteNoBits :: BinHandle -> IO Word8
+getByteNoBits h@(BinMem ix_r sz_r arr_r _ _) = do
+    ix <- readFastMutInt ix_r
+    sz <- readFastMutInt sz_r
+    when (ix >= sz)  $
+        throw (IOException $ mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
+    arr <- readIORef arr_r
+    w <- unsafeRead arr ix
+    writeFastMutInt ix_r (ix+1)
+    return w
+
+getByteNoBits bh@(BinIO ix_r h _ _) = do
+    c <- hGetChar h
+    incFastMutInt ix_r
+    return $! (fromIntegral (ord c))    -- XXX not really correct
+
+getWord8 :: BinHandle -> IO Word8
+getWord8 h@(BinMem ix_r sz_r arr_r bit_off_r _) = do
+    bit_off <- readFastMutInt bit_off_r
+    if bit_off /= 0 then getBits h 8 else do
+    ix <- readFastMutInt ix_r
+    sz <- readFastMutInt sz_r
+    when (ix >= sz)  $
+        throw (IOException $ mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)
+    arr <- readIORef arr_r
+    w <- unsafeRead arr ix
+    writeFastMutInt ix_r (ix+1)
+    return w
+getWord8 bh@(BinIO ix_r h bit_off_r _) = do
+    bit_off <- readFastMutInt bit_off_r
+    if bit_off /= 0 then getBits bh 8 else do
+    ix <- readFastMutInt ix_r
+    c <- hGetChar h
+    writeFastMutInt ix_r (ix+1)
+    return $! (fromIntegral (ord c))    -- XXX not really correct
+
+putByte :: BinHandle -> Word8 -> IO ()
+putByte bh w = put_ bh w
+
+getByte :: BinHandle -> IO Word8
+getByte = getWord8
+
+-- -----------------------------------------------------------------------------
+-- Bit functions
+
+putBits :: BinHandle -> Int -> Word8 -> IO ()
+putBits bh num_bits bits {- | num_bits == 0 = return ()
+                         | num_bits <  0 = error "putBits cannot write negative numbers of bits"
+                         | num_bits >  8 = error "putBits cannot write more than 8 bits at a time"
+                         | otherwise    -} = do
+  bit_off <- readFastMutInt (bit_off_r bh)
+  if num_bits + bit_off < 8
+    then do incFastMutIntBy (bit_off_r bh) num_bits
+            orFastMutInt (bit_cache_r bh) (bits `shiftL` bit_off)
+    else if num_bits + bit_off == 8
+           then do writeFastMutInt (bit_off_r bh) 0
+                   bit_cache <- {-# SCC "bc1" #-} readFastMutInt (bit_cache_r bh) >>= return . fromIntegral
+                   writeFastMutInt (bit_cache_r bh) 0
+                   --putByte bh (bit_cache .|. (bits `shiftL` bit_off))    -- won't call putBits because bit_off_r == 0
+                   putByteNoBits bh (bit_cache .|. (bits `shiftL` bit_off))
+
+           else do let leftover_bits = 8 - bit_off                       -- we are going over a byte boundary
+                   bit_cache <- {-# SCC "bc2" #-} readFastMutInt (bit_cache_r bh) >>= \x -> return ({-# SCC "fi" #-} fromIntegral x)
+                   writeFastMutInt (bit_off_r bh) 0
+                   writeFastMutInt (bit_cache_r bh) 0
+                   {- putByte bh (bit_cache .|. (bits `shiftL` bit_off))  -}  -- won't call putBits
+                   putByteNoBits bh (bit_cache .|. (bits `shiftL` bit_off))
+                   putBits bh (num_bits - leftover_bits) (bits `shiftR` leftover_bits)
+
+getBits :: BinHandle -> Int -> IO Word8
+getBits bh num_bits {- | num_bits == 0 = return 0
+                    | num_bits <  0 = error "getBits cannot read negative numbers of bits"
+                    | num_bits >  8 = error "getBits cannot read more than 8 bits at a time"
+                    | otherwise     -} = do
+  bit_off <- readFastMutInt (bit_off_r bh)
+  if bit_off == 0
+    then do bit_cache <- getByte bh
+            if num_bits == 8
+              then do writeFastMutInt (bit_off_r   bh) 0
+                      writeFastMutInt (bit_cache_r bh) 0
+                      return bit_cache
+              else do writeFastMutInt (bit_off_r   bh) (fromIntegral num_bits)
+                      writeFastMutInt (bit_cache_r bh) (fromIntegral bit_cache)
+                      return (bit_cache .&. bit_mask num_bits)
+    else if bit_off + num_bits < 8
+    then do incFastMutIntBy (bit_off_r bh) num_bits
+            bit_cache <- readFastMutInt (bit_cache_r bh) >>= return . fromIntegral
+            return ((bit_cache `shiftR` bit_off) .&. bit_mask num_bits)
+    else if bit_off + num_bits == 8
+    then do writeFastMutInt (bit_off_r bh) 0
+            bit_cache <- readFastMutInt (bit_cache_r bh) >>= return . fromIntegral
+            writeFastMutInt (bit_cache_r bh) 0
+            return ((bit_cache `shiftR` bit_off) .&. bit_mask num_bits)
+    else do let leftover_bits = 8 - bit_off
+            bit_cache <- readFastMutInt (bit_cache_r bh) >>= return . fromIntegral
+            let bits = (bit_cache `shiftR` bit_off) .&. bit_mask leftover_bits
+            writeFastMutInt (bit_cache_r bh) 0
+            writeFastMutInt (bit_off_r   bh) 0
+            {- bit_cache <- getByte bh -}
+            -- use a version that doesn't care about bits
+            bit_cache <- getByteNoBits bh
+            writeFastMutInt (bit_off_r   bh) (num_bits - leftover_bits)
+            writeFastMutInt (bit_cache_r bh) (fromIntegral bit_cache)
+            return (bits .|. ((bit_cache .&. bit_mask (num_bits - leftover_bits)) `shiftL` leftover_bits))
+
+            
+bit_mask n = (complement 0) `shiftR` (8 - n)
+
+-- -----------------------------------------------------------------------------
+-- Primitve Word writes
+
+instance Binary Word8 where
+  put_ = putWord8
+  get  = getWord8
+
+instance Binary Word16 where
+  put_ h w = do -- XXX too slow.. inline putWord8?
+    putByte h (fromIntegral (w `shiftR` 8))
+    putByte h (fromIntegral (w .&. 0xff))
+  get h = do
+    w1 <- getWord8 h
+    w2 <- getWord8 h
+    return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
+
+
+instance Binary Word32 where
+  put_ h w = do
+    putByte h (fromIntegral (w `shiftR` 24))
+    putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
+    putByte h (fromIntegral ((w `shiftR` 8)  .&. 0xff))
+    putByte h (fromIntegral (w .&. 0xff))
+  get h = do
+    w1 <- getWord8 h
+    w2 <- getWord8 h
+    w3 <- getWord8 h
+    w4 <- getWord8 h
+    return $! ((fromIntegral w1 `shiftL` 24) .|. 
+           (fromIntegral w2 `shiftL` 16) .|. 
+           (fromIntegral w3 `shiftL`  8) .|. 
+           (fromIntegral w4))
+
+
+instance Binary Word64 where
+  put_ h w = do
+    putByte h (fromIntegral (w `shiftR` 56))
+    putByte h (fromIntegral ((w `shiftR` 48) .&. 0xff))
+    putByte h (fromIntegral ((w `shiftR` 40) .&. 0xff))
+    putByte h (fromIntegral ((w `shiftR` 32) .&. 0xff))
+    putByte h (fromIntegral ((w `shiftR` 24) .&. 0xff))
+    putByte h (fromIntegral ((w `shiftR` 16) .&. 0xff))
+    putByte h (fromIntegral ((w `shiftR`  8) .&. 0xff))
+    putByte h (fromIntegral (w .&. 0xff))
+  get h = do
+    w1 <- getWord8 h
+    w2 <- getWord8 h
+    w3 <- getWord8 h
+    w4 <- getWord8 h
+    w5 <- getWord8 h
+    w6 <- getWord8 h
+    w7 <- getWord8 h
+    w8 <- getWord8 h
+    return $! ((fromIntegral w1 `shiftL` 56) .|. 
+           (fromIntegral w2 `shiftL` 48) .|. 
+           (fromIntegral w3 `shiftL` 40) .|. 
+           (fromIntegral w4 `shiftL` 32) .|. 
+           (fromIntegral w5 `shiftL` 24) .|. 
+           (fromIntegral w6 `shiftL` 16) .|. 
+           (fromIntegral w7 `shiftL`  8) .|. 
+           (fromIntegral w8))
+
+-- -----------------------------------------------------------------------------
+-- Primitve Int writes
+
+instance Binary Int8 where
+  put_ h w = put_ h (fromIntegral w :: Word8)
+  get h    = do w <- get h; return $! (fromIntegral (w::Word8))
+
+instance Binary Int16 where
+  put_ h w = put_ h (fromIntegral w :: Word16)
+  get h    = do w <- get h; return $! (fromIntegral (w::Word16))
+
+instance Binary Int32 where
+  put_ h w = put_ h (fromIntegral w :: Word32)
+  get h    = do w <- get h; return $! (fromIntegral (w::Word32))
+
+put31ofInt32 :: BinHandle -> Int32 -> IO ()
+put31ofInt32 h i = do
+    putBits h 7 (fromIntegral (w `shiftR` 24))
+    putBits h 8 (fromIntegral ((w `shiftR` 16) .&. 0xff))
+    putBits h 8 (fromIntegral ((w `shiftR` 8)  .&. 0xff))
+    putBits h 8 (fromIntegral (w .&. 0xff))
+    where w = fromIntegral i :: Word32
+
+get31ofInt32 :: BinHandle -> IO Int32
+get31ofInt32 h = do
+    w1 <- getBits  h 7
+    w2 <- getWord8 h
+    w3 <- getWord8 h
+    w4 <- getWord8 h
+    return $! ((fromIntegral w1 `shiftL` 24) .|. 
+           (fromIntegral w2 `shiftL` 16) .|. 
+           (fromIntegral w3 `shiftL`  8) .|. 
+           (fromIntegral w4))
+
+instance Binary Int64 where
+  put_ h w = put_ h (fromIntegral w :: Word64)
+  get h    = do w <- get h; return $! (fromIntegral (w::Word64))
+
+-- -----------------------------------------------------------------------------
+-- Instances for standard types
+
+instance Binary () where
+    put_ bh () = return ()
+    get  _     = return ()
+--    getF bh p  = case getBitsF bh 0 p of (_,b) -> ((),b)
+
+{- updated for bits
+instance Binary Bool where
+    put_ bh b = putByte bh (fromIntegral (fromEnum b))
+    get  bh   = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
+--    getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)
+-}
+
+instance Binary Bool where
+    put_ bh True  = putBits bh 1 1
+    put_ bh False = putBits bh 1 0
+    get  bh = do b <- getBits bh 1; return (b == 1)
+
+instance Binary Char where
+    put_  bh c = put_ bh (fromIntegral (ord c) :: Word32)
+    get  bh   = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
+--    getF bh p = case getBitsF bh 8 p of (x,b) -> (toEnum x,b)
+
+instance Binary Int where
+#if SIZEOF_HSINT == 4
+    put_ bh i = put_ bh (fromIntegral i :: Int32)
+    get  bh = do
+    x <- get bh
+    return $! (fromIntegral (x :: Int32))
+#elif SIZEOF_HSINT == 8
+    put_ bh i = put_ bh (fromIntegral i :: Int64)
+    get  bh = do
+    x <- get bh
+    return $! (fromIntegral (x :: Int64))
+#else
+#error "unsupported sizeof(HsInt)"
+#endif
+--    getF bh   = getBitsF bh 32
+
+{-
+instance Binary a => Binary [a] where
+    put_ bh []     = putByte bh 0
+    put_ bh (x:xs) = do putByte bh 1; put_ bh x; put_ bh xs
+    get bh         = do h <- getWord8 bh
+                        case h of
+                          0 -> return []
+                          _ -> do x  <- get bh
+                                  xs <- get bh
+                                  return (x:xs)
+-}
+
+instance Binary a => Binary [a] where
+    put_ bh l = do
+       put_ bh (length l)
+       mapM (put_ bh) l
+       return ()
+    get bh = do
+       len <- get bh
+       mapM (\_ -> get bh) [1..(len::Int)]
+
+instance (Binary a, Binary b) => Binary (a,b) where
+    put_ bh (a,b) = do put_ bh a; put_ bh b
+    get bh        = do a <- get bh
+                       b <- get bh
+                       return (a,b)
+
+instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
+    put_ bh (a,b,c) = do put_ bh a; put_ bh b; put_ bh c
+    get bh          = do a <- get bh
+                         b <- get bh
+                         c <- get bh
+                         return (a,b,c)
+
+instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
+    put_ bh (a,b,c,d) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d
+    get bh          = do a <- get bh
+                         b <- get bh
+                         c <- get bh
+                         d <- get bh
+                         return (a,b,c,d)
+
+instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where
+    put_ bh (a,b,c,d,e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e
+    get bh          = do a <- get bh
+                         b <- get bh
+                         c <- get bh
+                         d <- get bh
+                         e <- get bh
+                         return (a,b,c,d,e)
+
+instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) => Binary (a,b,c,d,e,f) where
+    put_ bh (a,b,c,d,e,f) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; put_ bh f
+    get bh          = do a <- get bh
+                         b <- get bh
+                         c <- get bh
+                         d <- get bh
+                         e <- get bh
+                         f <- get bh
+                         return (a,b,c,d,e,f)
+
+instance Binary a => Binary (Maybe a) where
+    put_ bh Nothing  = putByte bh 0
+    put_ bh (Just a) = do putByte bh 1; put_ bh a
+    get bh           = do h <- getWord8 bh
+                          case h of
+                            0 -> return Nothing
+                            _ -> do x <- get bh; return (Just x)
+
+putMaybeInt :: BinHandle -> Maybe Int -> IO ()
+getMaybeInt :: BinHandle -> IO (Maybe Int)
+putMaybeInt bh Nothing = putBits bh 1 0
+putMaybeInt bh (Just i) = do putBits bh 1 1; put31ofInt32 bh (fromIntegral i)
+
+getMaybeInt bh = do 
+  b <- getBits bh 1
+  case b of
+    0 -> return Nothing
+    _ -> do i <- get31ofInt32 bh
+            return (Just (fromIntegral i))
+
+{- RULES get = getMaybeInt -}
+
+{- SPECIALIZE put_ :: BinHandle -> Maybe Int -> IO () = putMaybeInt -}
+{- SPECIALIZE get  :: BinHandle -> IO (Maybe Int)     = getMaybeInt -}
+
+
+instance (Binary a, Binary b) => Binary (Either a b) where
+    put_ bh (Left  a) = do putByte bh 0; put_ bh a
+    put_ bh (Right b) = do putByte bh 1; put_ bh b
+    get bh            = do h <- getWord8 bh
+                           case h of
+                             0 -> do a <- get bh ; return (Left a)
+                             _ -> do b <- get bh ; return (Right b)
+
+instance Binary Integer where
+    put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#)
+    put_ bh (J# s# a#) = do
+        p <- putByte bh 1;
+        put_ bh (I# s#)
+        let sz# = sizeofByteArray# a#  -- in *bytes*
+        put_ bh (I# sz#)  -- in *bytes*
+        putByteArray bh a# sz#
+
+    get bh = do
+        b <- getByte bh
+        case b of
+          0 -> do (I# i#) <- get bh
+                  return (S# i#)
+          _ -> do (I# s#) <- get bh
+                  sz <- get bh
+                  (BA a#) <- getByteArray bh sz
+                  return (J# s# a#)
+
+putByteArray :: BinHandle -> ByteArray# -> Int# -> IO ()
+putByteArray bh a s# = loop 0#
+  where loop n# 
+           | n# ==# s# = return ()
+           | otherwise = do
+                putByte bh (indexByteArray a n#)
+                loop (n# +# 1#)
+
+getByteArray :: BinHandle -> Int -> IO ByteArray
+getByteArray bh (I# sz) = do
+  (MBA arr) <- newByteArray sz 
+  let loop n
+       | n ==# sz = return ()
+       | otherwise = do
+        w <- getByte bh 
+        writeByteArray arr n w
+        loop (n +# 1#)
+  loop 0#
+  freezeByteArray arr
+
+
+data ByteArray = BA ByteArray#
+data MBA = MBA (MutableByteArray# RealWorld)
+
+newByteArray :: Int# -> IO MBA
+newByteArray sz = IO $ \s ->
+  case newByteArray# sz s of { (# s, arr #) ->
+  (# s, MBA arr #) }
+
+freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
+freezeByteArray arr = IO $ \s ->
+  case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
+  (# s, BA arr #) }
+
+writeByteArray :: MutableByteArray# RealWorld -> Int# -> Word8 -> IO ()
+
+writeByteArray arr i w8 = IO $ \s ->
+  case fromIntegral w8 of { W# w# -> 
+  case writeCharArray# arr i (chr# (word2Int# w#)) s  of { s ->
+  (# s , () #) }}
+
+indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# a# n#)))
+
+instance (Integral a, Binary a) => Binary (Ratio a) where
+    put_ bh (a :% b) = do put_ bh a; put_ bh b
+    get bh = do a <- get bh; b <- get bh; return (a :% b)
+
+instance Binary (Bin a) where
+  put_ bh (BinPtr i j) = put_ bh (i,j)
+  get bh = do (i,j) <- get bh; return (BinPtr i j)
+
+-- -----------------------------------------------------------------------------
+-- Lazy reading/writing
+
+lazyPut :: Binary a => BinHandle -> a -> IO ()
+lazyPut bh a = do
+    -- output the obj with a ptr to skip over it:
+    pre_a <- tellBin bh
+    put_ bh pre_a   -- save a slot for the ptr
+    put_ bh a       -- dump the object
+    q <- tellBin bh     -- q = ptr to after object
+    putAt bh pre_a q    -- fill in slot before a with ptr to q
+    seekBin bh q    -- finally carry on writing at q
+
+lazyGet :: Binary a => BinHandle -> IO a
+lazyGet bh = do
+    p <- get bh     -- a BinPtr
+    p_a <- tellBin bh
+    a <- unsafeInterleaveIO (getAt bh p_a)
+    seekBin bh p -- skip over the object for now
+    return a
+
+-- -----------------------------------------------------------------------------
+-- BinHandleState
+{-
+type BinHandleState = 
+    (Module, 
+     IORef Int,
+     IORef (UniqFM (Int,FastString)),
+     Array Int FastString)
+
+initReadState :: BinHandleState
+initReadState = (undef, undef, undef, undef)
+
+newWriteState :: Module -> IO BinHandleState
+newWriteState m = do
+  j_r <- newIORef 0
+  out_r <- newIORef emptyUFM
+  return (m,j_r,out_r,undef)
+
+undef = error "Binary.BinHandleState"
+
+-- -----------------------------------------------------------------------------
+-- FastString binary interface
+
+getBinFileWithDict :: Binary a => FilePath -> IO a
+getBinFileWithDict file_path = do
+  bh <- Binary.readBinMem file_path
+  magic <- get bh
+  when (magic /= binaryInterfaceMagic) $
+    throwDyn (ProgramError (
+       "magic number mismatch: old/corrupt interface file?"))
+  dict_p <- Binary.get bh       -- get the dictionary ptr
+  data_p <- tellBin bh
+  seekBin bh dict_p
+  dict <- getDictionary bh
+  seekBin bh data_p
+  let (mod, j_r, out_r, _) = state bh
+  get bh{ state = (mod,j_r,out_r,dict) }
+
+initBinMemSize = (1024*1024) :: Int
+
+binaryInterfaceMagic = 0x1face :: Word32
+
+putBinFileWithDict :: Binary a => FilePath -> Module -> a -> IO ()
+putBinFileWithDict file_path mod a = do
+  bh <- openBinMem initBinMemSize mod
+  put_ bh binaryInterfaceMagic
+  p <- tellBin bh
+  put_ bh p     -- placeholder for ptr to dictionary
+  put_ bh a
+  let (_, j_r, fm_r, _) = state bh
+  j <- readIORef j_r
+  fm <- readIORef fm_r
+  dict_p <- tellBin bh
+  putAt bh p dict_p -- fill in the placeholder
+  seekBin bh dict_p -- seek back to the end of the file
+  putDictionary bh j (constructDictionary j fm)
+  writeBinMem bh file_path
+  
+type Dictionary = Array Int FastString
+    -- should be 0-indexed
+
+putDictionary :: BinHandle -> Int -> Dictionary -> IO ()
+putDictionary bh sz dict = do
+  put_ bh sz
+  mapM_ (putFS bh) (elems dict)
+
+getDictionary :: BinHandle -> IO Dictionary
+getDictionary bh = do 
+  sz <- get bh
+  elems <- sequence (take sz (repeat (getFS bh)))
+  return (listArray (0,sz-1) elems)
+
+constructDictionary :: Int -> UniqFM (Int,FastString) -> Dictionary
+constructDictionary j fm = array (0,j-1) (eltsUFM fm)
+
+putFS bh (FastString id l ba) = do
+  put_ bh (I# l)
+  putByteArray bh ba l
+putFS bh s = error ("Binary.put_(FastString): " ++ unpackFS s)
+    -- Note: the length of the FastString is *not* the same as
+    -- the size of the ByteArray: the latter is rounded up to a
+    -- multiple of the word size.
+  
+{- -- possible faster version, not quite there yet:
+getFS bh@BinMem{} = do
+  (I# l) <- get bh
+  arr <- readIORef (arr_r bh)
+  off <- readFastMutInt (off_r bh)
+  return $! (mkFastSubStringBA# arr off l)
+-}
+getFS bh = do
+  (I# l) <- get bh
+  (BA ba) <- getByteArray bh (I# l)
+  return $! (mkFastSubStringBA# ba 0# l)
+
+instance Binary FastString where
+  put_ bh f@(FastString id l ba) =
+    case getUserData bh of { (_, j_r, out_r, dict) -> do
+    out <- readIORef out_r
+    let uniq = getUnique f
+    case lookupUFM out uniq of
+    Just (j,f)  -> put_ bh j
+    Nothing -> do
+       j <- readIORef j_r
+       put_ bh j
+       writeIORef j_r (j+1)
+       writeIORef out_r (addToUFM out uniq (j,f))
+    }
+  put_ bh s = error ("Binary.put_(FastString): " ++ show (unpackFS s))
+
+  get bh = do 
+    j <- get bh
+    case getUserData bh of (_, _, _, arr) -> return (arr ! j)
+-}
+
+
+
+{----------------------------------------------------------------------
+ ---------- Hal's Notes -----------------------------------------------
+ ----------------------------------------------------------------------
+
+We are adding support for 
+
+  putBits   :: BinHandle -> Int -> Word8 -> IO ()
+  getBits   :: BinHandle -> Int -> IO Word8
+  flushBits :: BinHandle -> Int -> IO ()
+  closeHandle :: BinHandle -> IO ()
+
+where
+
+  `putBits bh num_bits bits' writes the right-most num_bits of bits to
+  bh.  `getBits bh num_bits` reads num_bits from bh and stores them in
+  the right-most positions of the result.  flushBits bh n alignes the
+  stream to the next 2^n bit boundary.  closeHandle flushes all
+  remaining bits and closes the handle.
+
+In order to implement this, we need to extend the BinHandles with two
+fields: bit_off_r :: Int and bit_cache :: Word8.  Based on this, the
+basic implementations look something like this:
+
+putBits bh num_bits bits =
+  if num_bits + bit_off_r <= 8
+    then bit_off_r += num_bits
+         add num_bits of bits to the tail of bit_cache
+         if bit_off_r == 8
+           then write bit_cache and set bit_cache = 0, bit_off_r = 0
+    else let leftover_bits = 8 - bit_off_r
+         add leftover_bits of bits to tail of bit_cache
+         write bit_cache and set bit_cache = 0, bit_off_r = 0
+         putBits bh (num_bits - leftover_bits) (bits >> leftover_bits)
+
+(note that this will recurse at most once)
+
+getBits bh num_bits =
+  if bit_off_r == 0
+    then bit_cache <- read a byte
+         bit_off_r = num_bits
+         if bit_off_r == 8, set bit_off_r = 0, bit_cache = 0
+    else if bit_off_r + num_bits <= 8
+           then bit_off_r += num_bits
+                bits = bits from bit_off_r -> bit_off_r+num_bits of bit_cache
+                if bit_off_r == 8, set bit_off_r = 0, bit_cache = 0
+                return bits
+           else let leftover_bits = 8 - bit_off_r
+                bits = (last leftover_bits from bit_cache) << (num_bits - leftover_bits)
+                bit_cache <- read a byte
+                bit_off_r = num_bits - leftover_bits
+                return (bits || first (num_bits - leftover_bits) of bit_cache)
+
+Now, we must also modify putByte/getByte.  In these, we do a quick
+check to see if bit_off_r == 0; if it does, then we just execute
+normally.  Otherwise, we just call putBits/getBits with num_bits=8.
+
+closeHandle bh =
+  if bit_off_r == 0
+    then close the handle
+    else write bit_cache and set bit_cache = 0, bit_off_r =0
+         close the handle
+
+-}
+
+------------------------------------------------------------------------
+
+#if __GLASGOW_HASKELL__ < 411
+newByteArray# = newCharArray#
+#endif
+
+#ifdef __GLASGOW_HASKELL__
+
+data FastMutInt = FastMutInt (MutableByteArray# RealWorld)
+
+newFastMutInt :: IO FastMutInt
+newFastMutInt = IO $ \s ->
+  case newByteArray# size s of { (# s, arr #) ->
+  (# s, FastMutInt arr #) }
+  where I# size = SIZEOF_HSINT
+
+readFastMutInt :: FastMutInt -> IO Int
+readFastMutInt (FastMutInt arr) = IO $ \s ->
+  case readIntArray# arr 0# s of { (# s, i #) ->
+  (# s, I# i #) }
+
+writeFastMutInt :: FastMutInt -> Int -> IO ()
+writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s ->
+  case writeIntArray# arr 0# i s of { s ->
+  (# s, () #) }
+
+incFastMutInt :: FastMutInt -> IO Int   -- Returns original value
+incFastMutInt (FastMutInt arr) = IO $ \s ->
+  case readIntArray# arr 0# s of { (# s, i #) ->
+  case writeIntArray# arr 0# (i +# 1#) s of { s ->
+  (# s, I# i #) } }
+
+incFastMutIntBy :: FastMutInt -> Int -> IO Int  -- Returns original value
+incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s ->
+  case readIntArray# arr 0# s of { (# s, i #) ->
+  case writeIntArray# arr 0# (i +# n) s of { s ->
+  (# s, I# i #) } }
+
+-- we should optimize this: ask SimonM :)
+orFastMutInt :: FastMutInt -> Word8 -> IO ()
+orFastMutInt fmi w = do
+  i <- readFastMutInt fmi
+  writeFastMutInt fmi (i .|. (fromIntegral w))
+
+#endif
+
diff --git a/tests/QC.hs b/tests/QC.hs
new file mode 100644
--- /dev/null
+++ b/tests/QC.hs
@@ -0,0 +1,203 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+module Main where
+
+import Data.Binary
+import Data.Binary.Put
+import Data.Binary.Get
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base 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 Data.Array (Array)
+import Data.Array.IArray
+import Data.Array.Unboxed (UArray)
+
+import Control.Monad
+import Foreign
+import System.Environment
+import System.IO
+
+import Test.QuickCheck hiding (test)
+import QuickCheckUtils
+import Text.Printf
+
+-- import qualified Data.Sequence as Seq
+
+------------------------------------------------------------------------
+
+roundTrip :: (Eq a, Binary a) => a -> (L.ByteString -> L.ByteString) -> Bool
+roundTrip a f = a ==
+    {-# SCC "decode.refragment.encode" #-} decode (f (encode a))
+
+roundTripWith put get x =
+    forAll positiveList $ \xs ->
+    x == runGet get (refragment xs (runPut (put x)))
+
+-- low level ones:
+
+prop_Word16be = roundTripWith putWord16be getWord16be
+prop_Word16le = roundTripWith putWord16le getWord16le
+
+prop_Word32be = roundTripWith putWord32be getWord32be
+prop_Word32le = roundTripWith putWord32le getWord32le
+
+prop_Word64be = roundTripWith putWord64be getWord64be
+prop_Word64le = roundTripWith putWord64le getWord64le
+
+invariant_lbs :: L.ByteString -> Bool
+invariant_lbs (B.LPS []) = True
+invariant_lbs (B.LPS xs) = all (not . B.null) xs
+
+prop_invariant :: (Binary a) => a -> Bool
+prop_invariant = invariant_lbs . encode
+
+-- be lazy!
+
+-- doesn't do fair testing of lazy put/get.
+-- tons of untested cases
+
+-- lazyTrip :: (Binary a, Eq a) => a -> Property
+-- lazyTrip a = forAll positiveList $ \xs ->
+--     a == (runGet lazyGet . refragment xs . runPut . lazyPut $ a)
+
+-- refragment a lazy bytestring's chunks
+refragment :: [Int] -> L.ByteString -> L.ByteString
+refragment [] lps = lps
+refragment (x:xs) lps =
+    let x' = fromIntegral . (+1) . abs $ x
+        rest = refragment xs (L.drop x' lps) in
+    L.append (L.fromChunks [B.concat . L.toChunks . L.take x' $ lps]) rest
+
+-- check identity of refragmentation
+prop_refragment lps xs = lps == refragment xs lps
+
+-- check that refragmention still hold invariant
+prop_refragment_inv lps xs = invariant_lbs $ refragment xs lps
+
+main :: IO ()
+main = do
+    hSetBuffering stdout NoBuffering
+    run tests
+
+run :: [(String, Int -> IO ())] -> IO ()
+run tests = do
+    x <- getArgs
+    let n = if null x then 100 else read . head $ x
+    mapM_ (\(s,a) -> printf "%-50s" s >> a n) tests
+
+------------------------------------------------------------------------
+
+type T a = a -> Property
+type B a = a -> Bool
+
+p       :: Testable a => a -> Int -> IO ()
+p       = mytest
+
+test    :: (Eq a, Binary a) => a -> Property
+test a  = forAll positiveList (roundTrip a . refragment)
+
+positiveList :: Gen [Int]
+positiveList = fmap (filter (/=0) . map abs) $ arbitrary
+
+tests =
+-- utils
+        [ ("refragment id",        p prop_refragment     )
+        , ("refragment invariant", p prop_refragment_inv )
+
+-- Primitives
+        , ("Word16be",      p prop_Word16be)
+        , ("Word16le",      p prop_Word16le)
+        , ("Word32be",      p prop_Word32be)
+        , ("Word32le",      p prop_Word32le)
+        , ("Word64be",      p prop_Word64be)
+        , ("Word64le",      p prop_Word64le)
+
+-- higher level ones using the Binary class
+        ,("()",         p (test :: T ()                     ))
+        ,("Bool",       p (test :: T Bool                   ))
+        ,("Ordering",   p (test :: T Ordering               ))
+
+        ,("Word8",      p (test :: T Word8                  ))
+        ,("Word16",     p (test :: T Word16                 ))
+        ,("Word32",     p (test :: T Word32                 ))
+        ,("Word64",     p (test :: T Word64                 ))
+
+        ,("Int8",       p (test :: T Int8                   ))
+        ,("Int16",      p (test :: T Int16                  ))
+        ,("Int32",      p (test :: T Int32                  ))
+        ,("Int64",      p (test :: T Int64                  ))
+
+        ,("Word",       p (test :: T Word                   ))
+        ,("Int",        p (test :: T Int                    ))
+        ,("Integer",    p (test :: T Integer                ))
+
+        ,("Char",       p (test :: T Char                   ))
+
+        ,("[()]",       p (test :: T [()]                  ))
+        ,("[Word8]",    p (test :: T [Word8]               ))
+        ,("[Word32]",   p (test :: T [Word32]              ))
+        ,("[Word64]",   p (test :: T [Word64]              ))
+        ,("[Word]",     p (test :: T [Word]                ))
+        ,("[Int]",      p (test :: T [Int]                 ))
+        ,("[Integer]",  p (test :: T [Integer]             ))
+        ,("String",     p (test :: T String                ))
+
+        ,("((), ())",           p (test :: T ((), ())        ))
+        ,("(Word8, Word32)",    p (test :: T (Word8, Word32) ))
+        ,("(Int8, Int32)",      p (test :: T (Int8,  Int32)  ))
+        ,("(Int32, [Int])",     p (test :: T (Int32, [Int])  ))
+
+        ,("Maybe Int8",         p (test :: T (Maybe Int8)        ))
+        ,("Either Int8 Int16",  p (test :: T (Either Int8 Int16) ))
+
+        ,("(Maybe Word8, Bool, [Int], Either Bool Word8)",
+                p (test :: T (Maybe Word8, Bool, [Int], Either Bool Word8) ))
+
+        ,("(Int, ByteString)",        p (test     :: T (Int, B.ByteString)   ))
+--      ,("Lazy (Int, ByteString)",   p (lazyTrip :: T (Int, B.ByteString)   ))
+        ,("[(Int, ByteString)]",      p (test     :: T [(Int, B.ByteString)] ))
+--      ,("Lazy [(Int, ByteString)]", p (lazyTrip :: T [(Int, B.ByteString)] ))
+
+
+--      ,("Lazy IntMap",       p (lazyTrip  :: T IntSet.IntSet          ))
+        ,("IntSet",            p (test      :: T IntSet.IntSet          ))
+        ,("IntMap ByteString", p (test      :: T (IntMap.IntMap B.ByteString) ))
+
+        ,("B.ByteString",  p (test :: T B.ByteString        ))
+        ,("L.ByteString",  p (test :: T L.ByteString        ))
+
+        ,("B.ByteString invariant",   p (prop_invariant :: B B.ByteString                 ))
+        ,("[B.ByteString] invariant", p (prop_invariant :: B [B.ByteString]               ))
+        ,("L.ByteString invariant",   p (prop_invariant :: B L.ByteString                 ))
+        ,("[L.ByteString] invariant", p (prop_invariant :: B [L.ByteString]               ))
+        ,("IntMap invariant",         p (prop_invariant :: B (IntMap.IntMap B.ByteString) ))
+
+        ,("Set Word32",      p (test :: T (Set.Set Word32)      ))
+        ,("Map Word16 Int",  p (test :: T (Map.Map Word16 Int)  ))
+
+        ,("(Maybe Int64, Bool, [Int])", p (test :: T (Maybe Int64, Bool, [Int])))
+
+{-
+--
+-- Big tuples lack an Arbitrary instance in Hugs/QuickCheck
+--
+
+        ,("(Maybe Word16, Bool, [Int], Either Bool Word16, Int)",
+            p (test :: T (Maybe Word16, Bool, [Int], Either Bool Word16, Int) ))
+
+        ,("(Maybe Word32, Bool, [Int], Either Bool Word32, Int, Int)", p (roundTrip :: (Maybe Word32, Bool, [Int], Either Bool Word32, Int, Int) -> Bool))
+
+        ,("(Maybe Word64, Bool, [Int], Either Bool Word64, Int, Int, Int)", p (roundTrip :: (Maybe Word64, Bool, [Int], Either Bool Word64, Int, Int, Int) -> Bool))
+-}
+
+-- GHC only:
+--      ,("Sequence", p (roundTrip :: Seq.Seq Int64 -> Bool))
+
+-- Obsolete
+--      ,("ensureLeft/Fail", mytest (shouldFail (decode L.empty :: Either ParseError Int)))
+        ]
diff --git a/tests/QuickCheckUtils.hs b/tests/QuickCheckUtils.hs
new file mode 100644
--- /dev/null
+++ b/tests/QuickCheckUtils.hs
@@ -0,0 +1,253 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+--
+-- Uses multi-param type classes
+--
+module QuickCheckUtils where
+
+import Control.Monad
+
+import Test.QuickCheck.Batch
+import Test.QuickCheck
+import Text.Show.Functions
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base 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 Control.Exception as C (evaluate)
+
+import Control.Monad        ( liftM2 )
+import Data.Char
+import Data.List
+import Data.Word
+import Data.Int
+import System.Random
+import System.IO
+
+-- import Control.Concurrent
+import System.Mem
+import System.CPUTime
+import Text.Printf
+
+import qualified Data.ByteString      as P
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Base as L (LazyByteString(..))
+
+-- import qualified Data.Sequence as Seq
+
+-- Enable this to get verbose test output. Including the actual tests.
+debug = False
+
+mytest :: Testable a => a -> Int -> IO ()
+mytest a n = mycheck defaultConfig
+    { configMaxTest=n
+    , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a
+
+mycheck :: Testable a => Config -> a -> IO ()
+mycheck config a = do
+     rnd <- newStdGen
+     performGC -- >> threadDelay 100
+     t <- mytests config (evaluate a) rnd 0 0 [] 0 -- 0
+     printf " %0.3f seconds\n" (t :: Double)
+     hFlush stdout
+
+time :: a -> IO (a , Double)
+time a = do
+    start <- getCPUTime
+    v     <- C.evaluate a
+    v `seq` return ()
+    end   <- getCPUTime
+    return (v,     (      (fromIntegral (end - start)) / (10^12)))
+
+mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> Double -> IO  Double
+mytests config gen rnd0 ntest nfail stamps t0
+  | ntest == configMaxTest config = do done "OK," ntest stamps
+                                       return t0
+
+  | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps
+                                       return t0
+
+  | otherwise = do
+     (result,t1) <- time (generate (configSize config ntest) rnd2 gen)
+
+     putStr (configEvery config ntest (arguments result)) >> hFlush stdout
+     case ok result of
+       Nothing    ->
+         mytests config gen rnd1 ntest (nfail+1) stamps (t0 + t1)
+       Just True  ->
+         mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) (t0 + t1)
+       Just False -> do
+         putStr ( "Falsifiable after "
+               ++ show ntest
+               ++ " tests:\n"
+               ++ unlines (arguments result)
+                ) >> hFlush stdout
+         return t0
+
+     where
+      (rnd1,rnd2) = split rnd0
+
+done :: String -> Int -> [[String]] -> IO ()
+done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )
+ where
+  table = display
+        . map entry
+        . reverse
+        . sort
+        . map pairLength
+        . group
+        . sort
+        . filter (not . null)
+        $ stamps
+
+  display []  = ". "
+  display [x] = " (" ++ x ++ "). "
+  display xs  = ".\n" ++ unlines (map (++ ".") xs)
+
+  pairLength xss@(xs:_) = (length xss, xs)
+  entry (n, xs)         = percentage n ntest
+                       ++ " "
+                       ++ concat (intersperse ", " xs)
+
+  percentage n m        = show ((100 * n) `div` m) ++ "%"
+
+------------------------------------------------------------------------
+
+instance Random Word8 where
+  randomR = integralRandomR
+  random = randomR (minBound,maxBound)
+
+instance Random Int8 where
+  randomR = integralRandomR
+  random = randomR (minBound,maxBound)
+
+instance Random Word16 where
+  randomR = integralRandomR
+  random = randomR (minBound,maxBound)
+
+instance Random Int16 where
+  randomR = integralRandomR
+  random = randomR (minBound,maxBound)
+
+instance Random Word where
+  randomR = integralRandomR
+  random = randomR (minBound,maxBound)
+
+instance Random Word32 where
+  randomR = integralRandomR
+  random = randomR (minBound,maxBound)
+
+instance Random Int32 where
+  randomR = integralRandomR
+  random = randomR (minBound,maxBound)
+
+instance Random Word64 where
+  randomR = integralRandomR
+  random = randomR (minBound,maxBound)
+
+instance Random Int64 where
+  randomR = integralRandomR
+  random = randomR (minBound,maxBound)
+
+------------------------------------------------------------------------
+
+integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)
+integralRandomR  (a,b) g = case randomR (fromIntegral a :: Integer,
+                                         fromIntegral b :: Integer) g of
+                            (x,g) -> (fromIntegral x, g)
+
+------------------------------------------------------------------------
+
+instance Arbitrary Word8 where
+    arbitrary       = choose (0, 2^8-1)
+    coarbitrary w   = variant 0
+
+instance Arbitrary Word16 where
+    arbitrary       = choose (0, 2^16-1)
+    coarbitrary     = undefined
+
+instance Arbitrary Word32 where
+--  arbitrary       = choose (0, 2^32-1)
+    arbitrary       = choose (minBound, maxBound)
+    coarbitrary     = undefined
+
+instance Arbitrary Word64 where
+--  arbitrary       = choose (0, 2^64-1)
+    arbitrary       = choose (minBound, maxBound)
+    coarbitrary     = undefined
+
+instance Arbitrary Int8 where
+--  arbitrary       = choose (0, 2^8-1)
+    arbitrary       = choose (minBound, maxBound)
+    coarbitrary w   = variant 0
+
+instance Arbitrary Int16 where
+--  arbitrary       = choose (0, 2^16-1)
+    arbitrary       = choose (minBound, maxBound)
+    coarbitrary     = undefined
+
+instance Arbitrary Int32 where
+--  arbitrary       = choose (0, 2^32-1)
+    arbitrary       = choose (minBound, maxBound)
+    coarbitrary     = undefined
+
+instance Arbitrary Int64 where
+--  arbitrary       = choose (0, 2^64-1)
+    arbitrary       = choose (minBound, maxBound)
+    coarbitrary     = undefined
+
+instance Arbitrary Word where
+    arbitrary       = choose (minBound, maxBound)
+    coarbitrary w   = variant 0
+
+------------------------------------------------------------------------
+
+instance Arbitrary Char where
+    arbitrary = choose (maxBound, minBound)
+    coarbitrary = undefined
+
+instance Arbitrary a => Arbitrary (Maybe a) where
+    arbitrary = oneof [ return Nothing, liftM Just arbitrary]
+    coarbitrary = undefined
+
+instance Arbitrary Ordering where
+    arbitrary = oneof [ return LT,return  GT,return  EQ ]
+    coarbitrary = undefined
+
+instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where
+    arbitrary = oneof [ liftM Left arbitrary, liftM Right arbitrary]
+    coarbitrary = undefined
+
+instance Arbitrary IntSet.IntSet where
+    arbitrary = fmap IntSet.fromList arbitrary
+    coarbitrary = undefined
+
+instance (Arbitrary e) => Arbitrary (IntMap.IntMap e) where
+    arbitrary = fmap IntMap.fromList arbitrary
+    coarbitrary = undefined
+
+instance (Arbitrary a, Ord a) => Arbitrary (Set.Set a) where
+    arbitrary = fmap Set.fromList arbitrary
+    coarbitrary = undefined
+
+instance (Arbitrary a, Ord a, Arbitrary b) => Arbitrary (Map.Map a b) where
+    arbitrary = fmap Map.fromList arbitrary
+    coarbitrary = undefined
+
+{-
+instance (Arbitrary a) => Arbitrary (Seq.Seq a) where
+    arbitrary = fmap Seq.fromList arbitrary
+    coarbitrary = undefined
+-}
+
+instance Arbitrary L.ByteString where
+    arbitrary     = arbitrary >>= return . B.LPS . filter (not. B.null) -- maintain the invariant.
+    coarbitrary s = coarbitrary (L.unpack s)
+
+instance Arbitrary B.ByteString where
+  arbitrary = B.pack `fmap` arbitrary
+  coarbitrary s = coarbitrary (B.unpack s)
diff --git a/tools/derive/BinaryDerive.hs b/tools/derive/BinaryDerive.hs
new file mode 100644
--- /dev/null
+++ b/tools/derive/BinaryDerive.hs
@@ -0,0 +1,49 @@
+
+module BinaryDerive where
+
+import Data.Generics
+import Data.List
+
+derive :: (Typeable a, Show a, Data a) => a -> String
+derive x = 
+    "instance " ++ context ++ "Binary " ++ inst ++ " where\n" ++
+    concat putDefs ++ getDefs
+    where
+    context
+        | nTypeChildren > 0 =
+            wrap (join ", " (map ("Binary "++) typeLetters)) ++ " => "
+        | otherwise = ""
+    inst = wrap $ tyConString typeName ++ concatMap (" "++) typeLetters
+    wrap x = if nTypeChildren > 0 then "("++x++")" else x 
+    join sep lst = concat $ intersperse sep lst
+    nTypeChildren = length typeChildren
+    typeLetters = take nTypeChildren manyLetters
+    manyLetters = map (:[]) ['a'..'z']
+    (typeName,typeChildren) = splitTyConApp (typeOf x)
+    constrs :: [(Int, (String, Int))]
+    constrs = zip [0..] $ map gen $ dataTypeConstrs (dataTypeOf x)
+    gen con = ( showConstr con
+              , length $ gmapQ undefined $ fromConstr con `asTypeOf` x
+              )
+    putDefs = map ((++"\n") . putDef) constrs
+    putDef (n, (name, ps)) =
+        let wrap = if ps /= 0 then ("("++) . (++")") else id
+            pattern = name ++ concatMap (' ':) (take ps manyLetters)
+        in
+        "  put " ++ wrap pattern ++" = "
+        ++ concat [ "putWord8 " ++ show n | length constrs  > 1 ]
+        ++ concat [ " >> "                | length constrs  > 1 && ps  > 0 ]
+        ++ concat [ "return ()"           | length constrs == 1 && ps == 0 ]
+        ++ join " >> " (map ("put "++) (take ps manyLetters))
+    getDefs =
+       (if length constrs > 1
+            then "  get = do\n    tag_ <- getWord8\n    case tag_ of\n"
+            else "  get =")
+        ++ concatMap ((++"\n")) (map getDef constrs)
+    getDef (n, (name, ps)) =
+        let wrap = if ps /= 0 then ("("++) . (++")") else id
+        in
+        concat [ "      " ++ show n ++ " ->" | length constrs > 1 ]
+        ++ concatMap (\x -> " get >>= \\"++x++" ->") (take ps manyLetters)
+        ++ " return "
+        ++ wrap (name ++ concatMap (" "++) (take ps manyLetters))
diff --git a/tools/derive/Example.hs b/tools/derive/Example.hs
new file mode 100644
--- /dev/null
+++ b/tools/derive/Example.hs
@@ -0,0 +1,68 @@
+
+import Data.Generics
+
+import Data.Binary
+
+import BinaryDerive
+
+data Foo = Bar
+    deriving (Typeable, Data, Show, Eq)
+
+instance Binary Main.Foo where
+  put Bar = return ()
+  get = return Bar
+
+data Color = RGB Int Int Int
+           | CMYK Int Int Int Int
+    deriving (Typeable, Data, Show, Eq)
+
+instance Binary Main.Color where
+  put (RGB a b c) = putWord8 0 >> put a >> put b >> put c
+  put (CMYK a b c d) = putWord8 1 >> put a >> put b >> put c >> put d
+  get = do
+    tag_ <- getWord8
+    case tag_ of
+      0 -> get >>= \a -> get >>= \b -> get >>= \c -> return (RGB a b c)
+      1 -> get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return (CMYK a b c d)
+
+data Computer = Laptop { weight :: Int }
+              | Desktop { speed :: Int, memory :: Int }
+    deriving (Typeable, Data, Show, Eq)
+
+instance Binary Main.Computer where
+  put (Laptop a) = putWord8 0 >> put a
+  put (Desktop a b) = putWord8 1 >> put a >> put b
+  get = do
+    tag_ <- getWord8
+    case tag_ of
+      0 -> get >>= \a -> return (Laptop a)
+      1 -> get >>= \a -> get >>= \b -> return (Desktop a b)
+
+-- | All drinks mankind will ever need
+data Drinks = Beer Bool{-ale?-}
+            | Coffee
+            | Tea
+            | EnergyDrink
+            | Water
+            | Wine
+            | Whisky
+    deriving (Typeable, Data, Show, Eq)
+
+instance Binary Main.Drinks where
+  put (Beer a) = putWord8 0 >> put a
+  put Coffee = putWord8 1
+  put Tea = putWord8 2
+  put EnergyDrink = putWord8 3
+  put Water = putWord8 4
+  put Wine = putWord8 5
+  put Whisky = putWord8 6
+  get = do
+    tag_ <- getWord8
+    case tag_ of
+      0 -> get >>= \a -> return (Beer a)
+      1 -> return Coffee
+      2 -> return Tea
+      3 -> return EnergyDrink
+      4 -> return Water
+      5 -> return Wine
+      6 -> return Whisky