{-# OPTIONS -cpp -fglasgow-exts #-}
{-# OPTIONS -#include <strings.h> #-}
{-# OPTIONS -#include "binutils.h" #-}
--
-- (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/

-- Unit tests by 
--  Paul Steckler, NGIT/FNMOC, paul.steckler.ctr@metnet.navy.mil
-- fixme: who did the GHC port?
--   AJG: I believe it was Simon Marlow
-- 
--  the Sven Panne port is known to be buggy

-- The Binary module is *not* thread save. Only one threads should
-- be actively interacting with each Handle at a time.

module Binary
  ( BinHandle,
    FixedBinHandle,
    FixedSysHandle,
    IOBinHandle,   

    BinaryHandle,  -- abstract class

    Binary(..),
    Binary.copyBytes, 
    Bin(..), 
    BinArray,
    tellBin,
    seekBin, 
    openBinIO, 
    openBinMem,
    openFixedBinMem,
    openFixedSysHandle,
    sizeBinMem, 
    sizeFixedBinMem,
    sizeFixedSysMem,
    zeroFixedBinHandle,
    zeroFixedSysHandle,
    resetBin, 
    copyMap,

    invalidateFixedBinMem,
    invalidateFixedSysMem,

  ) where

#include "ghcconfig.h"
#if 0
#include "haskell_debug.h"
#endif

import BinArray as BA
import FastMutInt
-- import GHC.IO

import Data.Array.SysArray

--import Data.Map(Map)
# if __GLASGOW_HASKELL__>=602
-- import Data.HashTable as HashTable
# endif
-- import Data.Array.IO
-- import Data.Array.Storable
import Data.Array
-- import Data.Bits
-- import Data.Int
-- import Data.Word
import Data.IORef
import Data.Char		( ord, chr )
-- import Data.Array.Base  	( unsafeRead, unsafeWrite, bounds )
import Control.Monad		( when )
import Control.Exception	( assert )
import System.IO as IO
import System.Posix.IO          (fdSeek, fdRead, fdWrite)
import System.Posix.Types       (Fd(..))
-- import System.IO.Unsafe		( unsafeInterleaveIO )
import System.IO.Error		( mkIOError, eofErrorType )
--import GHC.Real			( Ratio(..) )
import GHC.Exts
import GHC.IOBase	 	( IO(..) )
-- import GHC.Word			( Word8(..) )
-- import System.Directory         ( removeFile )
# if __GLASGOW_HASKELL__<602
-- import GHC.Handle		( hSetBinaryMode )
# endif

import Foreign
import Foreign.C

-- for debug
--import System.CPUTime           (getCPUTime)
-- import Numeric                  (showFFloat)

--import Testing

-- FIXME: we should really get SIZEOF_HSINT directly from ghc's config.h
#define SIZEOF_HSINT SIZEOF_VOID_P

-- This is a hack to prevent the profiling version from
-- being *significantly* slower than the unprofiling version.

-- 

#ifdef PROFILING
#define IOSCC(label,act) IO $ \ s ->  {-# SCC label #-} case act of { IO m -> m s }
#else
#define IOSCC(label,act) act
#endif

-- type BinArray = StorableArray Int Word8
-- newtype BinArray = BinArray IOUArray Int Word8

---------------------------------------------------------------
--		BinHandle. etc
---------------------------------------------------------------

data IOBinHandle
  = IOBinHandle {

     io_off_r :: !FastMutInt,		-- the current offset (cached)
     hdl   :: !Fd		-- the file handle (must be seekable)
   }
	-- 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 BinHandle
  = BinMem {		-- binary data stored in an unboxed array
     off_r :: !FastMutInt,		-- the current offset
     sz_r  :: !FastMutInt,		-- size of the array (cached)
                                        -- TODO: use the arr_r's size.
     arr_r :: !(IORef BinArray) 	-- the array (bounds: (0,size-1))
    }

data FixedBinHandle
  = FixedBinMem {			-- binary data stored in an unboxed array
     f_off_r :: !FastMutInt,		-- the current offset
     f_sz_r  :: !FastMutInt,		-- size of the array (cached)
                                        -- TODO: use the arr_r's size.
     f_arr_r :: !BinArray	 	-- the array (bounds: (0,size-1))
    }

data FixedSysHandle
  = FixedSysMem {			-- binary data stored in an unboxed array
     fs_off_r :: !FastMutInt,		-- the current offset
     fs_sz_r  :: !FastMutInt,		-- size of the array (cached)
                                        -- TODO: use the arr_r's size.
     fs_arr_r :: !(SysArray Word8) 	-- the array (bounds: (0,size-1))
    }

---------------------------------------------------------------
--		Bin
---------------------------------------------------------------

newtype Bin a = BinPtr Int 
  deriving (Eq, Ord, Show, Bounded)

---------------------------------------------------------------
--		class BinaryHandle
---------------------------------------------------------------

class BinaryHandle m where
    bhPut            :: m -> Word8 -> IO ()
    bhGet            :: m -> IO Word8
    tellBin          :: m -> IO (Bin a)
    seekBin	     :: m -> Bin a -> IO ()

    getAddrRef    :: m -> Int -> IO (Maybe AddrRef)
    getAddrRef _ _ = return $ Nothing

-- |reset the pointer
resetBin :: (BinaryHandle m) => m -> IO ()
resetBin bh = seekBin bh (BinPtr 0)

---------------------------------------------------------------
--		class Binary
---------------------------------------------------------------

class Binary a where
    put_   :: (BinaryHandle h) => h -> a -> IO ()
    put    :: (BinaryHandle h) => h -> a -> IO (Bin a)
    get    :: (BinaryHandle h) => h -> 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


---------------------------------------------------------------
--		BinHandle
---------------------------------------------------------------

instance BinaryHandle BinHandle where
    bhPut 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
  	        bhPut h w
  	else do arr <- readIORef arr_r
  		BA.writeWord8 arr ix w
      		writeFastMutInt ix_r (ix+1)
      		return ()

    bhGet (BinMem ix_r sz_r arr_r) = do
      ix <- readFastMutInt ix_r
      sz <- readFastMutInt sz_r
      when (ix >= sz)  $
  	ioError (mkIOError eofErrorType ("Halfs.Binary.getWord8 array: " ++ (show sz) ++" ")
                    Nothing Nothing)
      arr <- readIORef arr_r
      w <- BA.readWord8 arr ix
      writeFastMutInt ix_r (ix+1)
      return w

    tellBin (BinMem r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
    seekBin h@(BinMem ix_r sz_r a) (BinPtr p) = do
       sz <- readFastMutInt sz_r
       if (p >= sz)
        -- FIX: Below assertion is because we don't want any resizing in this app.
	-- FIX: dont use this for fixed sized buffers.
	then if (p > sz) then do expandBin h p; writeFastMutInt ix_r p
			 else -- at end of array, but that is legal, provided we do not read or write.
			      writeFastMutInt ix_r p
	else writeFastMutInt ix_r p

    getAddrRef h@(BinMem off_r sz_r arr_r_ref) count = do
	-- move the pointer forward *first*
	--  (this does bound checking or increases the size of the array),
        ix <- readFastMutInt off_r
	seekBin h (BinPtr (ix + count))
	arr_r <- readIORef arr_r_ref
	-- then move it back.
	seekBin h (BinPtr ix)
	return $ Just $ ByteArrAddrRef (getBinArrayRawBuffer arr_r)
				       ix
			  	       (seekBin h (BinPtr (ix + count)))



-- openBinHandle :: BinArray -> IO BinHandle
-- openBinHandle arr = do
--    arr_r <- newIORef arr
--    ix_r <- newFastMutInt
--    writeFastMutInt ix_r 0
--    sz_r <- newFastMutInt
--    writeFastMutInt sz_r (sizeBinArray arr)
--    return (BinMem ix_r sz_r arr_r)
 
openBinMem :: Int -> IO BinHandle
openBinMem size
 | size <= 0 = error "Halfs.Binary.openBinMem: size must be > 0"
 | otherwise = do
   arr <- BA.newBinArray size
   arr_r <- newIORef arr
   ix_r <- newFastMutInt
   writeFastMutInt ix_r 0
   sz_r <- newFastMutInt
   writeFastMutInt sz_r size
   return (BinMem ix_r sz_r arr_r)


sizeBinMem :: BinHandle -> IO Int
sizeBinMem (BinMem _ sz_r _) = readFastMutInt sz_r

-- getBinArray :: BinHandle -> IO BinArray
-- getBinArray (BinMem _ _ arr_r) = readIORef arr_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' <- newBinArray sz'
   BA.copy arr arr'
   writeFastMutInt sz_r sz'
   writeIORef arr_r arr'
#ifdef DEBUG
   hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
#endif
   return ()
--expandBin (BinIO _ _) _ = return ()
	-- no need to expand a file, we'll assume they expand by themselves.


---------------------------------------------------------------
--		FixedBinHandle
---------------------------------------------------------------

instance BinaryHandle FixedBinHandle where
    bhPut h@(FixedBinMem ix_r sz_r arr) w = do
      checkFixedBinMem h
      ix <- readFastMutInt ix_r
      sz <- readFastMutInt sz_r
      when (ix >= sz)  $
  	ioError (mkIOError eofErrorType ("Binary.bhPut FixedBinHandle: writing passed end of FixedBinHandle at " ++ (show sz) ++" ")
                    Nothing Nothing)
      BA.writeWord8 arr ix w
      writeFastMutInt ix_r (ix+1)
      checkFixedBinMem h
      return ()

    bhGet h@(FixedBinMem ix_r sz_r arr) = do
      checkFixedBinMem h
      ix <- readFastMutInt ix_r
      sz <- readFastMutInt sz_r
      when (ix >= sz)  $
  	ioError (mkIOError eofErrorType ("Binary.bhGet FixedBinHandle: reading passed end of FixedBinHandle at " ++ (show sz) ++" ")
                    Nothing Nothing)
      w <- BA.readWord8 arr ix
      writeFastMutInt ix_r (ix+1)
      checkFixedBinMem h
      return w

    tellBin h@(FixedBinMem r _ _) = do checkFixedBinMem h ; ix <- readFastMutInt r; return (BinPtr ix)
    seekBin h@(FixedBinMem ix_r sz_r a) (BinPtr p) = do
       checkFixedBinMem h
       sz <- readFastMutInt sz_r
       when (p > sz)  $
  	 ioError (mkIOError eofErrorType ("Binary.seekBin FixedBinHandle: seeking passed end of FixedBinHandle at " ++ (show sz) ++" ")
                    Nothing Nothing)
       when (p < 0)  $
  	 ioError (mkIOError eofErrorType ("Binary.seekBin FixedBinHandle: seeking passed start of FixedBinHandle at " ++ (show sz) ++" ")
                    Nothing Nothing)
       writeFastMutInt ix_r p
       checkFixedBinMem h

    getAddrRef h@(FixedBinMem off_r sz_r arr) count = do
        checkFixedBinMem h
	-- move the pointer forward *first* to check bounds
        ix <- readFastMutInt off_r
	seekBin h (BinPtr (ix + count))
	-- then move it back.
	seekBin h (BinPtr ix)
        checkFixedBinMem h
	return $ Just $ ByteArrAddrRef (getBinArrayRawBuffer arr)
				       ix
			  	       (seekBin h (BinPtr (ix + count)))

{-
openFixedBinHandle :: BinArray -> IO FixedBinHandle
openFixedBinHandle arr = do
   ix_r <- newFastMutInt
   writeFastMutInt ix_r 0
   sz_r <- newFastMutInt
   writeFastMutInt sz_r (sizeBinArray arr)
   return $ FixedBinMem ix_r sz_r arr
-}

checkFixedBinMem :: FixedBinHandle -> IO ()
checkFixedBinMem (FixedBinMem ix_r _ _) = do
  ix <- readFastMutInt ix_r  
  assert (ix /= -1) $ return ()

-- |make a handle 'dead'. uses to test reclaiming strategies.

invalidateFixedBinMem :: FixedBinHandle -> IO ()
invalidateFixedBinMem (FixedBinMem ix_r _ _) = do
  writeFastMutInt ix_r (-1)
  return ()

openFixedBinMem :: Int -> IO FixedBinHandle
openFixedBinMem size
 | size <= 0 = error "Halfs.Binary.openBinMem: size must be > 0"
 | otherwise = do
   arr <- BA.newBinArray size
   ix_r <- newFastMutInt
   writeFastMutInt ix_r 0
   sz_r <- newFastMutInt
   writeFastMutInt sz_r size
   let h = FixedBinMem ix_r sz_r arr
   checkFixedBinMem h
   return $ h

sizeFixedBinMem :: FixedBinHandle -> IO Int
sizeFixedBinMem h@(FixedBinMem _ sz_r _) = do
   checkFixedBinMem h
   readFastMutInt sz_r

zeroFixedBinHandle :: FixedBinHandle -> IO ()
zeroFixedBinHandle h@(FixedBinMem ix_r _ arr) = do
   checkFixedBinMem h
   BA.zeroBinArray arr
   writeFastMutInt ix_r 0
   checkFixedBinMem h
   return ()

---------------------------------------------------------------
--		FixedSysHandle
---------------------------------------------------------------

instance BinaryHandle FixedSysHandle where
    bhPut h@(FixedSysMem ix_r sz_r arr) w = do
      checkFixedSysMem h
      ix <- readFastMutInt ix_r
      sz <- readFastMutInt sz_r
      when (ix >= sz)  $
  	ioError (mkIOError eofErrorType ("Binary.bhPut FixedSysHandle: writing passed end of FixedSysHandle at " ++ (show sz) ++" ")
                    Nothing Nothing)
      pokeSysArrayElem arr (fromIntegral ix) w
      writeFastMutInt ix_r (ix+1)
      checkFixedSysMem h
      return ()

    bhGet h@(FixedSysMem ix_r sz_r arr) = do
      checkFixedSysMem h
      ix <- readFastMutInt ix_r
      sz <- readFastMutInt sz_r
      when (ix >= sz)  $
  	ioError (mkIOError eofErrorType ("Binary.bhGet FixedSysHandle: reading passed end of FixedSysHandle at " ++ (show sz) ++" ")
                    Nothing Nothing)
      w <- peekSysArrayElem arr (fromIntegral ix)
      writeFastMutInt ix_r (ix+1)
      checkFixedSysMem h
      return w

    tellBin h@(FixedSysMem r _ _) = do checkFixedSysMem h ; ix <- readFastMutInt r; return (BinPtr ix)
    seekBin h@(FixedSysMem ix_r sz_r a) (BinPtr p) = do
       checkFixedSysMem h
       sz <- readFastMutInt sz_r
       when (p > sz)  $
  	 ioError (mkIOError eofErrorType ("Binary.seekBin FixedSysHandle: seeking passed end of FixedSysHandle at " ++ (show sz) ++" ")
                    Nothing Nothing)
       when (p < 0)  $
  	 ioError (mkIOError eofErrorType ("Binary.seekBin FixedSysHandle: seeking passed start of FixedSysHandle at " ++ (show sz) ++" ")
                    Nothing Nothing)
       writeFastMutInt ix_r p
       checkFixedSysMem h

    getAddrRef h@(FixedSysMem off_r sz_r arr) count = do
        checkFixedSysMem h
	-- move the pointer forward *first* to check bounds
        ix <- readFastMutInt off_r
	seekBin h (BinPtr (ix + count))
	-- then move it back.
	seekBin h (BinPtr ix)
        checkFixedSysMem h
	return $ Just $ SysArrAddrRef (ptrFromSysArray arr)
				      ix
			  	      (seekBin h (BinPtr (ix + count)))


openFixedSysHandle :: SysArray Word8 -> IO FixedSysHandle
openFixedSysHandle arr = do
   ix_r <- newFastMutInt
   writeFastMutInt ix_r 0
   sz_r <- newFastMutInt
   writeFastMutInt sz_r (fromIntegral (sysArraySize arr))
   return $ FixedSysMem ix_r sz_r arr

checkFixedSysMem :: FixedSysHandle -> IO ()
checkFixedSysMem (FixedSysMem ix_r _ _) = do
  ix <- readFastMutInt ix_r  
  assert (ix /= -1) $ return ()

-- |make a handle 'dead'. uses to test reclaiming strategies.

invalidateFixedSysMem :: FixedSysHandle -> IO ()
invalidateFixedSysMem (FixedSysMem ix_r _ _) = do
  writeFastMutInt ix_r (-1)
  return ()

sizeFixedSysMem :: FixedSysHandle -> IO Int
sizeFixedSysMem h@(FixedSysMem _ sz_r _) = do
   checkFixedSysMem h
   readFastMutInt sz_r

foreign import ccall unsafe "binzero" binzero
	:: Ptr Word8 -> CSize ->  IO ()

zeroFixedSysHandle :: FixedSysHandle -> IO ()
zeroFixedSysHandle h@(FixedSysMem ix_r sz_r arr) = do
   checkFixedSysMem h
   sz <- readFastMutInt sz_r
   binzero (ptrFromSysArray arr) (fromIntegral sz)
   writeFastMutInt ix_r 0
   checkFixedSysMem h
   return ()

---------------------------------------------------------------
--		IOBinHandle
---------------------------------------------------------------

instance BinaryHandle IOBinHandle where
    bhPut (IOBinHandle ix_r h) w = do
      ix <- readFastMutInt ix_r
      fdWrite h [(chr (fromIntegral w))]	-- XXX not really correct
      writeFastMutInt ix_r (ix+1)
      return ()
    bhGet (IOBinHandle ix_r h) = do
      ix <- readFastMutInt ix_r
      ([c], count)  <- fdRead h 1
      writeFastMutInt ix_r (ix+1)
      return $! (fromIntegral (ord c))	-- XXX not really correct
    tellBin (IOBinHandle r _) = do 
      ix <- readFastMutInt r
      return (BinPtr ix)
    seekBin (IOBinHandle ix_r h) (BinPtr p) = do 
      writeFastMutInt ix_r p
--      print ("fdSeek: " , p)
      fdSeek h AbsoluteSeek (fromIntegral p)
      return ()

    getAddrRef (IOBinHandle ix_r fd) count = do
	return $ Just $ FdAddrRef 
	              { ch_fd = fd 
		      , ch_done = do ix <- readFastMutInt ix_r
				     writeFastMutInt ix_r (ix + count)
		      }


openBinIO :: Fd -> IO IOBinHandle
openBinIO h = do
  r <- newFastMutInt
  writeFastMutInt r 0
  return $ IOBinHandle r h

-- -----------------------------------------------------------------------------
-- Primitve Word writes

instance Binary Word8 where
  put_ bh a = bhPut bh a
  get  = bhGet

instance Binary Word16 where
  put_ h w = do 
    bhPut h (fromIntegral (w .&. 0xff))
    bhPut h (fromIntegral (w `shiftR` 8))
  get h = do
    w2 <- bhGet h
    w1 <- bhGet h
    return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)


instance Binary Word32 where
  put_ h w = do
    bhPut h (fromIntegral (w .&. 0xff))
    bhPut h (fromIntegral ((w `shiftR` 8)  .&. 0xff))
    bhPut h (fromIntegral ((w `shiftR` 16) .&. 0xff))
    bhPut h (fromIntegral (w `shiftR` 24))
  get h = do
    w4 <- bhGet h
    w3 <- bhGet h
    w2 <- bhGet h
    w1 <- bhGet h
    return $! ((fromIntegral w1 `shiftL` 24) .|. 
	       (fromIntegral w2 `shiftL` 16) .|. 
	       (fromIntegral w3 `shiftL`  8) .|. 
	       (fromIntegral w4))


instance Binary Word64 where
  put_ h w = do
    bhPut h (fromIntegral (w .&. 0xff))
    bhPut h (fromIntegral ((w `shiftR`  8) .&. 0xff))
    bhPut h (fromIntegral ((w `shiftR` 16) .&. 0xff))
    bhPut h (fromIntegral ((w `shiftR` 24) .&. 0xff))
    bhPut h (fromIntegral ((w `shiftR` 32) .&. 0xff))
    bhPut h (fromIntegral ((w `shiftR` 40) .&. 0xff))
    bhPut h (fromIntegral ((w `shiftR` 48) .&. 0xff))
    bhPut h (fromIntegral (w `shiftR` 56))
  get h = do
    w8 <- bhGet h
    w7 <- bhGet h
    w6 <- bhGet h
    w5 <- bhGet h
    w4 <- bhGet h
    w3 <- bhGet h
    w2 <- bhGet h
    w1 <- bhGet 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))

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)

instance Binary Bool where
    put_ bh b = bhPut bh (fromIntegral (fromEnum b))
    get  bh   = do x <- bhGet bh; return $! (toEnum (fromIntegral x))
--    getF bh p = case getBitsF bh 1 p of (x,b) -> (toEnum x,b)

instance Binary Char where
    put_  bh c = put_ bh (fromIntegral (ord c) :: Word8)
    get  bh   = do x <- get bh; return $! (chr (fromIntegral (x :: Word8)))
--    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 list = do put_ bh (length list)
                      mapM_ (put_ bh) list
    get bh = do len <- get bh
                let getMany :: Int -> IO [a]
                    getMany 0 = return []
                    getMany n = do x <- get bh
                                   xs <- getMany (n-1)
                                   return (x:xs)
                getMany len

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 (Maybe a) where
    put_ bh Nothing  = bhPut bh 0
    put_ bh (Just a) = do bhPut bh 1; put_ bh a
    get bh           = do h <- bhGet bh
                          case h of
                            0 -> return Nothing
                            _ -> do x <- get bh; return (Just x)

instance (Binary a, Binary b) => Binary (Either a b) where
    put_ bh (Left  a) = do bhPut bh 0; put_ bh a
    put_ bh (Right b) = do bhPut bh 1; put_ bh b
    get bh            = do h <- bhGet bh
                           case h of
                             0 -> do a <- get bh ; return (Left a)
                             _ -> do b <- get bh ; return (Right b)

instance (Binary a, Binary i, Ix i) => Binary (Array i a) where
  put_ bh arr = do put_ bh (Data.Array.bounds arr)
                   put_ bh (Data.Array.elems arr)
  get bh = do bounds <- get bh
              elems <- get bh
              return $ listArray bounds elems

instance Binary (Bin a) where
  put_ bh (BinPtr i) = put_ bh i
  get bh = do i <- get bh; return (BinPtr i)


---------------------------------------------------------------
--		Binary Copying
---------------------------------------------------------------

-- |Move from one BinHandle to another, with size.  Moves both of
-- their pointers.

copyBytes :: (BinaryHandle h1,BinaryHandle h2)
          => h1      -- ^ src handle
          -> h2	     -- ^ dest handle
          -> Int
          -> IO ()
copyBytes from_h to_h sz@(I# _) = {-# SCC "copyBytes" #-} do
   src <- getAddrRef from_h sz
   dst <- getAddrRef to_h sz
   case (src,dst) of
     (Just (ByteArrAddrRef s_buf s_off s_done), Just (ByteArrAddrRef d_buf d_off d_done)) -> {-# SCC "copyBytesBB" #-}
	do binmemmove_BA_BA d_buf (fromIntegral d_off) s_buf (fromIntegral s_off) (fromIntegral sz)
	   s_done
	   d_done
	   return ()
     (Just (SysArrAddrRef s_buf s_off s_done), Just (SysArrAddrRef d_buf d_off d_done)) -> {-# SCC "copyBytesSS" #-}
	do binmemmove_PTR_PTR d_buf (fromIntegral d_off) s_buf (fromIntegral s_off) (fromIntegral sz)
	   s_done
	   d_done
	   return ()
     (Just (SysArrAddrRef s_buf s_off s_done), Just (ByteArrAddrRef d_buf d_off d_done)) -> {-# SCC "copyBytesSB" #-}
	do binmemmove_BA_PTR d_buf (fromIntegral d_off) s_buf (fromIntegral s_off) (fromIntegral sz)
	   s_done
	   d_done
	   return ()
     (Just (ByteArrAddrRef s_buf s_off s_done), Just (SysArrAddrRef d_buf d_off d_done)) -> {-# SCC "copyBytesBS" #-}
	do binmemmove_PTR_BA d_buf (fromIntegral d_off) s_buf (fromIntegral s_off) (fromIntegral sz)
	   s_done
	   d_done
	   return ()

     (Just (ByteArrAddrRef s_buf s_off s_done), Just (FdAddrRef (Fd d_fd) d_done)) -> {-# SCC "copyBytesBF" #-}
        do r <- binwrite_BA d_fd s_buf (fromIntegral s_off) (fromIntegral sz)
	   s_done
	   d_done
	   return ()
     (Just (FdAddrRef (Fd s_fd) s_done), Just (ByteArrAddrRef d_buf d_off d_done)) -> {-# SCC "copyBytesFB" #-}
	do seekBin to_h (BinPtr (d_off + sz))
	   r <- binread_BA d_buf (fromIntegral d_off) s_fd (fromIntegral sz)
	   s_done
	   d_done
	   return ()
     _               -> {-# SCC "copyBytes1" #-} copyBytes1 from_h to_h sz 

foreign import ccall unsafe "binmemmove" binmemmove_BA_BA
	:: MutableByteArray# RealWorld -> CInt -> MutableByteArray# RealWorld -> CInt -> CSize ->  IO ()
foreign import ccall unsafe "binmemmove" binmemmove_BA_PTR
	:: MutableByteArray# RealWorld -> CInt -> Ptr Word8 -> CInt -> CSize ->  IO ()
foreign import ccall unsafe "binmemmove" binmemmove_PTR_PTR
	:: Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> CSize ->  IO ()
foreign import ccall unsafe "binmemmove" binmemmove_PTR_BA
	:: Ptr Word8 -> CInt -> MutableByteArray# RealWorld -> CInt -> CSize ->  IO ()
foreign import ccall unsafe "binwrite" binwrite_BA
	:: CInt -> MutableByteArray# RealWorld -> CInt -> CSize ->  IO ()
foreign import ccall unsafe "binread" binread_BA
	:: MutableByteArray# RealWorld -> CInt -> CInt -> CSize ->  IO ()

-- generic worker function.
copyBytes1 from_h to_h (I# sz) 
    | sz ==# 0# = return ()
    | otherwise = do { v <- bhGet from_h
                     ; bhPut to_h v
                     ; copyBytes1 from_h to_h (I# (sz -# 1#))
                     }


-- |Just like copy bytes, but takes a function parameter to modify
copyMap  :: (BinaryHandle bh1,BinaryHandle bh2,Binary a, Binary b)
         => bh1       -- ^input handle
         -> bh2       -- ^output handle
         -> Int       -- ^number of elements to copy
         -> (a -> b)  -- ^f is for fun
         -> IO ()
copyMap inHandle outHandle (I# sz) f = do
  let loop n
	   | n ==# sz = return ()
	   | otherwise = do
		w <- get inHandle
                put outHandle (f w)
		loop (n +# 1#)
  loop 0#
{-
copyBytesFromPtr :: (BinaryHandle h) 
          => Ptr a   -- ^ src ptr
          -> h	     -- ^ dest handle
          -> Int     -- ^ number of bytes
          -> IO ()
copyBytesFromPtr ptr h sz@(I# _) =  {-# SCC "copyBytesFromPtr" #-} do


copyBytesToPtr :: (BinaryHandle h) => 
          => h	     -- ^ src ptr
          -> Ptr a   -- ^ dest handle
          -> Int     -- ^ number of bytes
          -> IO ()
copyBytesToPtr h ptr sz@(I# _) = {-# SCC "copyBytesToPtr" #-} do
   copy 0
  where
	 copy i | i == sz = return ()	-- done
	        | otherwise = do
			v <- peekByteOff ptr i
			put h (v :: Word8)
			copy (i + 1)
-}

------------------------------------------------------------------------------
-- INTERNAL to this module.

-- get part of a Handle, for copying.

data AddrRef    = ByteArrAddrRef
		{	ch_byte_arr :: MutableByteArray# RealWorld
		,	ch_offset  :: Int 		-- offset where the copy (from/to) will start
		, 	ch_done   :: IO ()
		}		
		| FdAddrRef
		{	ch_fd	   :: Fd		-- the file descriptor
		, 	ch_done   :: IO ()
		}
		| SysArrAddrRef
		{	ch_sys_arr  :: Ptr Word8
		,	ch_offset   :: Int
		,	ch_done	    :: IO ()
		}
		
instance Show AddrRef where
  show (ByteArrAddrRef {}) = "ByteArrAddrRef"
  show (FdAddrRef fd _)    = "FdAddrRef " ++ show fd
  show (SysArrAddrRef {})  = "SysArrAddrRef"