{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}

module General.Binary(
    BinaryWith(..), module Data.Binary,
    BinList(..), BinFloat(..)
    ) where

import Control.Applicative
import Control.Monad
import Data.Binary
import Data.List
import Foreign
import System.IO.Unsafe as U


class BinaryWith ctx a where
    putWith :: ctx -> a -> Put
    getWith :: ctx -> Get a

instance (BinaryWith ctx a, BinaryWith ctx b) => BinaryWith ctx (a,b) where
    putWith ctx (a,b) = putWith ctx a >> putWith ctx b
    getWith ctx = liftA2 (,) (getWith ctx) (getWith ctx)

instance BinaryWith ctx a => BinaryWith ctx [a] where
    putWith ctx xs = put (length xs) >> mapM_ (putWith ctx) xs
    getWith ctx = do n <- get; replicateM n $ getWith ctx

instance BinaryWith ctx a => BinaryWith ctx (Maybe a) where
    putWith ctx Nothing = putWord8 0
    putWith ctx (Just x) = putWord8 1 >> putWith ctx x
    getWith ctx = do i <- getWord8; if i == 0 then return Nothing else fmap Just $ getWith ctx


newtype BinList a = BinList {fromBinList :: [a]}

instance Show a => Show (BinList a) where show = show . fromBinList

instance Binary a => Binary (BinList a) where
    put (BinList xs) = case splitAt 254 xs of
        (a, []) -> putWord8 (genericLength xs) >> mapM_ put xs
        (a, b) -> putWord8 255 >> mapM_ put a >> put (BinList b)
    get = do
        x <- getWord8
        case x of
            255 -> do xs <- replicateM 254 get; BinList ys <- get; return $ BinList $ xs ++ ys
            n -> fmap BinList $ replicateM (fromInteger $ toInteger n) get


newtype BinFloat = BinFloat {fromBinFloat :: Float}

instance Show BinFloat where show = show . fromBinFloat

instance Binary BinFloat where
    put (BinFloat x) = put (convert x :: Word32)
    get = fmap (BinFloat . convert) (get :: Get Word32)


-- Originally from data-binary-ieee754 package

convert :: (Storable a, Storable b) => a -> b
convert x = U.unsafePerformIO $ alloca $ \buf -> do
    poke (castPtr buf) x
    peek buf