module OpenAFP.Internals.Binary (
N0(..),
N1(..), N2(..), N3(..), N4(..),
I1(..), I2(..), I4(..), I8(..),
A1(..), A2(..), A3(..), A4(..), A6(..), A8(..), A12(..),
PStringLen, getList, putList, encodeList, decodeList, encodeListFile, decodeListFile,
module Data.Binary,
module Data.ByteString.Internal
) where
import Data.Binary
import Data.Array.Unboxed
import Data.Bits
import Data.Int
import Data.Word
import Data.Typeable
import Control.Monad ( when, liftM )
import System.IO as IO
import System.IO.Error ( mkIOError, eofErrorType )
import GHC.Exts
import GHC.Word ( Word8(..) )
import Foreign.Storable
import Data.Char
import Foreign.Ptr
import Numeric (showHex)
import System.Mem.Weak
import Foreign.C.Types
import Foreign.Marshal.Utils
import Foreign.ForeignPtr
import GHC.Base
import GHC.IOBase
import Data.Binary.Get
import Data.Binary.Put
import Data.ByteString.Internal (ByteString(..))
import qualified Data.ByteString as S
import GHC.Word (Word32(..),Word16(..),Word64(..))
import qualified Data.ByteString.Lazy as L
newtype A1 = A1 Word8 deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable, Storable, Bounded)
newtype A2 = A2 Word16 deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable, Storable, Bounded)
newtype A3 = A3 Word32 deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable)
newtype A4 = A4 Word32 deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable, Storable, Bounded)
newtype A6 = A6 Word64 deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable)
newtype A8 = A8 Word64 deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable, Storable, Bounded)
newtype A12 = A12 Integer deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable)
newtype I1 = I1 Int8 deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable, Storable, Ix, IArray UArray, Show)
newtype I2 = I2 Int16 deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable, Storable, Ix, IArray UArray, Show)
newtype I4 = I4 Int32 deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable, Storable, Ix, IArray UArray, Show)
newtype I8 = I8 Int64 deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable, Storable, Ix, IArray UArray, Show)
newtype N1 = N1 { fromN1 :: Word8 } deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable, Storable, Binary, Ix, IArray UArray, Bounded)
newtype N2 = N2 { fromN2 :: Word16 } deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable, Storable, Binary, Bounded)
newtype N3 = N3 { fromN3 :: Word32 } deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable)
newtype N4 = N4 { fromN4 :: Word32 } deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable, Storable, Binary, Bounded)
data N0 = N0 deriving (Show, Ord, Enum, Eq, Typeable, Ix, Bounded)
instance Bounded A3 where
minBound = A3 0
maxBound = A3 (2 ^ (8 * 3))
instance Bounded A6 where
minBound = A6 0
maxBound = A6 (2 ^ (8 * 6))
instance Bounded A12 where
minBound = A12 0
maxBound = A12 (2 ^ (8 * 12))
instance Bounded N3 where
minBound = N3 0
maxBound = N3 (2 ^ (8 * 3))
instance Binary N0 where
get = return N0
put _ = return ()
instance Num N0 where
x + _ = x
x * _ = x
abs x = x
signum x = x
fromInteger _ = N0
instance Show N1 where show = zeropad 1
instance Show N2 where show = zeropad 2
instance Show N3 where show = zeropad 3
instance Show N4 where show = zeropad 4
instance Show A1 where show = zeropad 1
instance Show A2 where show = zeropad 2
instance Show A3 where show = zeropad 3
instance Show A4 where show = zeropad 4
instance Show A6 where show = zeropad 6
instance Show A8 where show = zeropad 8
instance Show A12 where show = zeropad 12
zeropad :: (Integral a) => Int -> a -> String
zeropad len str = replicate len' '0' ++ str'
where str' = map toUpper $ showHex str ""
len' = 2*len length str'
instance Storable N3 where
sizeOf w = 3
alignment w = 8
instance Storable A3 where
sizeOf w = 3
alignment w = 8
instance Storable A6 where
sizeOf w = 6
alignment w = 8
instance Storable A12 where
sizeOf w = 12
alignment w = 8
instance (Storable a, Storable b) => Storable (a, b) where
alignment _ = error "alignment not defined"
sizeOf (x, y) = sizeOf x + sizeOf y
type PStringLen = S.ByteString
instance Binary A1 where
put (A1 w) = putWord8 w
get = fmap A1 getWord8
instance Binary A2 where
put (A2 w) = putWord16be w
get = fmap A2 getWord16be
instance Binary A4 where
put (A4 w) = putWord32be w
get = fmap A4 getWord32be
instance Binary A8 where
put (A8 w) = putWord64be w
get = fmap A8 getWord64be
instance Binary A3 where
put (A3 w) = do
putWord8 $ fromIntegral (shiftr_w32 w 16)
putWord16be $ fromIntegral w
get = do
s <- readN 3 id
return $! A3 ((fromIntegral (s `S.index` 0) `shiftl_w32` 16) .|.
(fromIntegral (s `S.index` 1) `shiftl_w32` 8) .|.
(fromIntegral (s `S.index` 2)))
instance Binary A6 where
put (A6 w) = do
putWord16be $ fromIntegral (shiftr_w64 w 32)
putWord32be $ fromIntegral w
get = do
s <- readN 6 id
return $! A6 ((fromIntegral (s `S.index` 0) `shiftl_w64` 40) .|.
(fromIntegral (s `S.index` 1) `shiftl_w64` 32) .|.
(fromIntegral (s `S.index` 2) `shiftl_w64` 24) .|.
(fromIntegral (s `S.index` 3) `shiftl_w64` 16) .|.
(fromIntegral (s `S.index` 4) `shiftl_w64` 8) .|.
(fromIntegral (s `S.index` 5)))
instance Binary A12 where
put (A12 w) = do
putWord32be $ fromIntegral (shiftR w 64)
putWord64be $ fromIntegral w
get = do
s <- readN 12 id
return $! A12 ((fromIntegral (s `S.index` 0) `shiftL` 88) .|.
(fromIntegral (s `S.index` 1) `shiftL` 80) .|.
(fromIntegral (s `S.index` 2) `shiftL` 72) .|.
(fromIntegral (s `S.index` 3) `shiftL` 64) .|.
(fromIntegral (s `S.index` 4) `shiftL` 56) .|.
(fromIntegral (s `S.index` 5) `shiftL` 48) .|.
(fromIntegral (s `S.index` 6) `shiftL` 40) .|.
(fromIntegral (s `S.index` 7) `shiftL` 32) .|.
(fromIntegral (s `S.index` 8) `shiftL` 24) .|.
(fromIntegral (s `S.index` 9) `shiftL` 16) .|.
(fromIntegral (s `S.index` 10) `shiftL` 8) .|.
(fromIntegral (s `S.index` 11)))
instance Binary I1 where
put (I1 w) = putWord8 $ fromIntegral w
get = fmap (I1 . fromIntegral) getWord8
instance Binary I2 where
put (I2 w) = putWord16be $ fromIntegral w
get = fmap (I2 . fromIntegral) getWord16be
instance Binary I4 where
put (I4 w) = putWord32be $ fromIntegral w
get = fmap (I4 . fromIntegral) getWord32be
instance Binary I8 where
put (I8 w) = putWord64be $ fromIntegral w
get = fmap (I8 . fromIntegral) getWord64be
instance Binary N3 where
put (N3 w) = do
putWord8 $ fromIntegral (shiftr_w32 w 16)
putWord16be $ fromIntegral w
get = do
s <- readN 3 id
return $! N3 ((fromIntegral (s `S.index` 0) `shiftl_w32` 16) .|.
(fromIntegral (s `S.index` 1) `shiftl_w32` 8) .|.
(fromIntegral (s `S.index` 2)))
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)
readN :: Int -> (S.ByteString -> a) -> Get a
readN n f = fmap f $ getBytes n
shiftl_w16 :: Word16 -> Int -> Word16
shiftl_w32 :: Word32 -> Int -> Word32
shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i)
shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)
shiftr_w64 = shiftR
shiftl_w64 = shiftL
getList :: Binary a => Get [a]
getList = do
rv <- isEmpty
if rv then return [] else do
x <- get
xs <- getList
return (x:xs)
putList :: Binary a => [a] -> Put
putList = mapM_ put
encodeList :: Binary a => [a] -> L.ByteString
encodeList = runPut . putList
decodeList :: Binary a => L.ByteString -> [a]
decodeList = runGet getList
encodeListFile :: Binary a => FilePath -> [a] -> IO ()
encodeListFile f v = L.writeFile f (encodeList v)
decodeListFile :: Binary a => FilePath -> IO [a]
decodeListFile f = liftM decodeList (L.readFile f)