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 hiding (putList)
import Data.Array.Unboxed
import Data.Bits
import Data.Int
import Data.Word
import Data.Typeable
import Data.Hashable ( Hashable )
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 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, Show, Hashable)
newtype I2 = I2 Int16 deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable, Storable, Ix, Show, Hashable)
newtype I4 = I4 Int32 deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable, Storable, Ix, Show, Hashable)
newtype I8 = I8 Int64 deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable, Storable, Ix, Show, Hashable)
newtype N1 = N1 { fromN1 :: Word8 } deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable, Storable, Binary, Ix, Bounded, Hashable)
newtype N2 = N2 { fromN2 :: Word16 } deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable, Storable, Binary, Bounded, Hashable)
newtype N3 = N3 { fromN3 :: Word32 } deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable, Hashable)
newtype N4 = N4 { fromN4 :: Word32 } deriving (Ord, Enum, Real, Integral, Eq, Num, Bits, Typeable, Storable, Binary, Bounded, Hashable)
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
negate 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 :: (Show a, 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 $ getByteString 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)