What to do to make this to be used as a library?

Bin.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}

module Bin where

import Control.Applicative (Applicative(..), (<$>))
import Control.Monad (ap)
import qualified Data.Array.MArray as M
import Data.Array.Storable hiding (getBounds)
import qualified Data.Array.Unsafe as U
import qualified Data.ByteString as S
import qualified Data.ByteString.Internal as S
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Internal as L
import Data.Word
import Foreign
import GHC.Base
import GHC.Word
import System.IO.MMap
import System.IO.Unsafe

class Binary t where
    -- | Encode a value in the Put method
    put :: t -> Bin ()
    -- | Decode a value in the Bin method
    get :: t -> Bin t

data S = S !(StorableArray Int Word8) -- data store
           !Int                       -- current index

newtype Bin r = Bin { unBin :: S -> IO (r, S) }

instance Functor Bin where
    fmap f m = Bin $ \s -> unBin m s >>= \(r, s') -> return (f r, s')

instance Applicative Bin where
    pure = return
    (<*>) = ap

instance Monad Bin where
    return r = Bin $ \s -> return (r, s)

    m >>= k = Bin $ \s -> unBin m s >>= \(r, s') -> unBin (k r) s'

    fail err = Bin $ \_ -> error err

runBin :: Bin r -> StorableArray Int Word8 -> IO r
runBin b sarr = do
    (l,_) <- M.getBounds sarr
    (r,_) <- unBin b (S sarr l)
    return r

runBinWithFile :: Bin r -> FilePath -> IO r
runBinWithFile b p = do
    (ptr,offset,size) <- mmapFileForeignPtr p ReadOnly Nothing
    sarr <- U.unsafeForeignPtrToStorableArray ptr (offset,size)
    runBin b sarr

-- | Bin the current position.
getPosition :: Bin Int
getPosition = Bin $ \s@(S _ n) -> return (n, s)

getBounds :: Bin (Int,Int)
getBounds = Bin $ \s@(S sarr _) -> do
    b <- M.getBounds sarr
    return (b,s)

normalize :: Int -> Int -> StorableArray Int Word8 -> IO Int
normalize p n sarr
  | n < 0     = return 0 
  | otherwise = do
      (_,h) <- M.getBounds sarr
      let next = p + n
      let n' = if next <= h + 1 then n else (next - h + 1)
      return n'

getByteString :: Int -> Bin S.ByteString
getByteString n = Bin $ \(S sarr p) -> do
    n' <- normalize p n sarr
    bs <- withStorableArray sarr $ \sp ->
              S.create n' $ \bp -> S.memcpy bp (sp `plusPtr` p) n'
    return (bs,(S sarr (p + n')))

getLazyByteString :: Int -> Bin L.ByteString
getLazyByteString n = Bin $ \(S sarr p) -> do
    n' <- normalize p n sarr
    bs <- copy p n' sarr
    return (bs,S sarr (p + n'))
  where
    copy :: Int -> Int -> StorableArray Int Word8 -> IO L.ByteString
    copy _ 0  _   = return L.empty
    copy p m sarr
      | n <= L.defaultChunkSize = do
          bs <- withStorableArray sarr $ \sp ->
                    S.create n $ \bp -> S.memcpy bp (sp `plusPtr` p) m
          return $ L.Chunk bs L.empty
      | otherwise = do
          let p' = p + fromIntegral L.defaultChunkSize
          let m' = m - L.defaultChunkSize
          bs <- withStorableArray sarr $ \sp ->
                    S.create L.defaultChunkSize $ \bp ->
                        S.memcpy bp (sp `plusPtr` p) L.defaultChunkSize
          L.Chunk bs <$> (unsafeInterleaveIO (copy p' m' sarr))

checkBounds :: Int -> Bin a -> Bin a
checkBounds n b = do
    (l,h) <- getBounds
    p <- getPosition
    let p' = p + n
    if l <= p' && p' <= h then
        b
    else
        fail $ "out of bounds: distance_to_move=" ++ show n
            ++ ", bounds=" ++ show (l,h) 
            ++ ", current_position=" ++ show p

skip :: Int -> Bin () 
skip n = checkBounds n $ Bin $ \(S sarr p) ->
    return ((), S sarr (p + n))

peekPtr :: Storable a => Int -> Bin a
peekPtr n = checkBounds n $ Bin $ \(S sarr p) -> do
    a <- withStorableArray sarr $ \sp -> peekByteOff sp p
    return (a,S sarr (p + n))

getWord8 :: Bin Word8
getWord8 = peekPtr (sizeOf (undefined :: Word8)) 

getWord16be :: Bin Word16
getWord16be = checkBounds 2 $ Bin $ \(S sarr p) -> do
    a <- withStorableArray sarr $ \sp -> do
        a0 <- peekByteOff sp (p + 0) :: IO Word8
        a1 <- peekByteOff sp (p + 1) :: IO Word8
        return $! (fromIntegral a0 `shiftl_w16` 8)
              .|. (fromIntegral a1)
    return (a,S sarr (p + 2))

getWord16le :: Bin Word16
getWord16le = checkBounds 2 $ Bin $ \(S sarr p) -> do
    a <- withStorableArray sarr $ \sp -> do
        a0 <- peekByteOff sp (p + 0) :: IO Word8
        a1 <- peekByteOff sp (p + 1) :: IO Word8
        return $! (fromIntegral a1 `shiftl_w16` 8)
              .|. (fromIntegral a0)
    return (a,S sarr (p + 2))

getWord32be :: Bin Word32
getWord32be = checkBounds 4 $ Bin $ \(S sarr p) -> do
    a <- withStorableArray sarr $ \sp -> do
        a0 <- peekByteOff sp (p + 0) :: IO Word8
        a1 <- peekByteOff sp (p + 1) :: IO Word8
        a2 <- peekByteOff sp (p + 2) :: IO Word8
        a3 <- peekByteOff sp (p + 3) :: IO Word8
        return $! (fromIntegral a0 `shiftl_w32` 24)
              .|. (fromIntegral a1 `shiftl_w32` 16)
              .|. (fromIntegral a2 `shiftl_w32`  8)
              .|. (fromIntegral a3)
    return (a,S sarr (p + 4))

getWord32le :: Bin Word32
getWord32le = checkBounds 4 $ Bin $ \(S sarr p) -> do
    a <- withStorableArray sarr $ \sp -> do
        a0 <- peekByteOff sp (p + 0) :: IO Word8
        a1 <- peekByteOff sp (p + 1) :: IO Word8
        a2 <- peekByteOff sp (p + 2) :: IO Word8
        a3 <- peekByteOff sp (p + 3) :: IO Word8
        return $! (fromIntegral a3 `shiftl_w32` 24)
              .|. (fromIntegral a2 `shiftl_w32` 16)
              .|. (fromIntegral a1 `shiftl_w32`  8)
              .|. (fromIntegral a0)
    return (a,S sarr (p + 4))

getWord64be :: Bin Word64
getWord64be = checkBounds 8 $ Bin $ \(S sarr p) -> do
    a <- withStorableArray sarr $ \sp -> do
        a0 <- peekByteOff sp (p + 0) :: IO Word8
        a1 <- peekByteOff sp (p + 1) :: IO Word8
        a2 <- peekByteOff sp (p + 2) :: IO Word8
        a3 <- peekByteOff sp (p + 3) :: IO Word8
        a4 <- peekByteOff sp (p + 4) :: IO Word8
        a5 <- peekByteOff sp (p + 5) :: IO Word8
        a6 <- peekByteOff sp (p + 6) :: IO Word8
        a7 <- peekByteOff sp (p + 7) :: IO Word8
        return $! (fromIntegral a0 `shiftl_w64` 56)
              .|. (fromIntegral a1 `shiftl_w64` 48)
              .|. (fromIntegral a2 `shiftl_w64` 40)
              .|. (fromIntegral a3 `shiftl_w64` 32)
              .|. (fromIntegral a4 `shiftl_w64` 24)
              .|. (fromIntegral a5 `shiftl_w64` 16)
              .|. (fromIntegral a6 `shiftl_w64`  8)
              .|. (fromIntegral a7)
    return (a,S sarr (p + 8))

getWord64le :: Bin Word64
getWord64le = checkBounds 8 $ Bin $ \(S sarr p) -> do
    a <- withStorableArray sarr $ \sp -> do
        a0 <- peekByteOff sp (p + 0) :: IO Word8
        a1 <- peekByteOff sp (p + 1) :: IO Word8
        a2 <- peekByteOff sp (p + 2) :: IO Word8
        a3 <- peekByteOff sp (p + 3) :: IO Word8
        a4 <- peekByteOff sp (p + 4) :: IO Word8
        a5 <- peekByteOff sp (p + 5) :: IO Word8
        a6 <- peekByteOff sp (p + 6) :: IO Word8
        a7 <- peekByteOff sp (p + 7) :: IO Word8
        return $! (fromIntegral a7 `shiftl_w64` 56)
              .|. (fromIntegral a6 `shiftl_w64` 48)
              .|. (fromIntegral a5 `shiftl_w64` 40)
              .|. (fromIntegral a4 `shiftl_w64` 32)
              .|. (fromIntegral a3 `shiftl_w64` 24)
              .|. (fromIntegral a2 `shiftl_w64` 16)
              .|. (fromIntegral a1 `shiftl_w64`  8)
              .|. (fromIntegral a0)
    return (a,S sarr (p + 8))

getWordhost :: Bin Word
getWordhost = peekPtr (sizeOf (undefined :: Word))

getWord16host :: Bin Word16
getWord16host = peekPtr (sizeOf (undefined :: Word16))

getWord32host :: Bin Word32
getWord32host = peekPtr (sizeOf (undefined :: Word32))

getWord64host :: Bin Word64
getWord64host = peekPtr (sizeOf (undefined :: Word64))

writeByteString :: S.ByteString -> Bin ()
writeByteString bs = Bin $ \(S sarr p) -> do
    withStorableArray sarr $ \sp -> case S.toForeignPtr bs of
        (fbp,offset,_) -> withForeignPtr fbp $ \bp ->
            S.memcpy (sp `plusPtr` p) (bp `plusPtr` offset) n
    return ((),S sarr (p + n))
  where
    n = S.length bs

putByteString :: S.ByteString -> Bin ()
putByteString bs
  | S.null bs = Bin $ \s -> return ((),s)
  | otherwise = checkBounds (S.length bs) (writeByteString bs)

putLazyByteString :: L.ByteString -> Bin ()
putLazyByteString bss = do
    loop bss 0 (putByteString S.empty)
  where
    loop :: L.ByteString -> Int -> Bin () -> Bin ()
    loop L.Empty           _  f = f
    loop (L.Chunk bs bss') !a f = checkBounds n $ loop bss' n (putByteString bs >> f)
      where
        n = a + S.length bs

putWord8 :: Word8 -> Bin ()
putWord8 w = checkBounds 1 $ Bin $ \(S sarr p) -> do
    withStorableArray sarr $ \sp ->
        pokeByteOff sp p w
    return ((),S sarr (p + 1))

putWord16be :: Word16 -> Bin ()
putWord16be w = checkBounds 2 $ Bin $ \(S sarr p) -> do
    withStorableArray sarr $ \sp -> do
        pokeByteOff sp 0 (fromIntegral w                 :: Word8)
        pokeByteOff sp 1 (fromIntegral (shiftr_w16 w  8) :: Word8)
    return ((),S sarr (p + 2))

putWord16le :: Word16 -> Bin ()
putWord16le w = checkBounds 2 $ Bin $ \(S sarr p) -> do
    withStorableArray sarr $ \sp -> do
        pokeByteOff sp 0 (fromIntegral (shiftr_w16 w  8) :: Word8)
        pokeByteOff sp 1 (fromIntegral w                 :: Word8)
    return ((),S sarr (p + 2))

putWord32be :: Word32 -> Bin ()
putWord32be w = checkBounds 4 $ Bin $ \(S sarr p) -> do
    withStorableArray sarr $ \sp -> do
        pokeByteOff sp 0 (fromIntegral w                 :: Word8)
        pokeByteOff sp 1 (fromIntegral (shiftr_w32 w  8) :: Word8)
        pokeByteOff sp 2 (fromIntegral (shiftr_w32 w 16) :: Word8)
        pokeByteOff sp 3 (fromIntegral (shiftr_w32 w 24) :: Word8)
    return ((),S sarr (p + 4))

putWord32le :: Word32 -> Bin ()
putWord32le w = checkBounds 4 $ Bin $ \(S sarr p) -> do
    withStorableArray sarr $ \sp -> do
        pokeByteOff sp 0 (fromIntegral (shiftr_w32 w 24) :: Word8)
        pokeByteOff sp 1 (fromIntegral (shiftr_w32 w 16) :: Word8)
        pokeByteOff sp 2 (fromIntegral (shiftr_w32 w  8) :: Word8)
        pokeByteOff sp 3 (fromIntegral w                 :: Word8)
    return ((),S sarr (p + 4))

putWord64be :: Word64 -> Bin ()
putWord64be w = checkBounds 8 $ Bin $ \(S sarr p) -> do
    withStorableArray sarr $ \sp -> do
        pokeByteOff sp 0 (fromIntegral w                 :: Word8)
        pokeByteOff sp 1 (fromIntegral (shiftr_w64 w  8) :: Word8)
        pokeByteOff sp 2 (fromIntegral (shiftr_w64 w 16) :: Word8)
        pokeByteOff sp 3 (fromIntegral (shiftr_w64 w 24) :: Word8)
        pokeByteOff sp 4 (fromIntegral (shiftr_w64 w 32) :: Word8)
        pokeByteOff sp 5 (fromIntegral (shiftr_w64 w 40) :: Word8)
        pokeByteOff sp 6 (fromIntegral (shiftr_w64 w 48) :: Word8)
        pokeByteOff sp 7 (fromIntegral (shiftr_w64 w 56) :: Word8)
    return ((),S sarr (p + 8))

putWord64le :: Word64 -> Bin ()
putWord64le w = checkBounds 8 $ Bin $ \(S sarr p) -> do
    withStorableArray sarr $ \sp -> do
        pokeByteOff sp 0 (fromIntegral (shiftr_w64 w 56) :: Word8)
        pokeByteOff sp 1 (fromIntegral (shiftr_w64 w 48) :: Word8)
        pokeByteOff sp 2 (fromIntegral (shiftr_w64 w 40) :: Word8)
        pokeByteOff sp 3 (fromIntegral (shiftr_w64 w 32) :: Word8)
        pokeByteOff sp 4 (fromIntegral (shiftr_w64 w 24) :: Word8)
        pokeByteOff sp 5 (fromIntegral (shiftr_w64 w 16) :: Word8)
        pokeByteOff sp 6 (fromIntegral (shiftr_w64 w  8) :: Word8)
        pokeByteOff sp 7 (fromIntegral w                 :: Word8)
    return ((),S sarr (p + 8))

shiftl_w16 :: Word16 -> Int -> Word16
shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i)

shiftl_w32 :: Word32 -> Int -> Word32
shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)

shiftl_w64 :: Word64 -> Int -> Word64
shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)

shiftr_w16 :: Word16 -> Int -> Word16
shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i)

shiftr_w32 :: Word32 -> Int -> Word32
shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i)

shiftr_w64 :: Word64 -> Int -> Word64
shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)