1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
|
{-# 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
|
