{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TypeFamilies #-}
module Raaz.Core.Types.Endian
(
EndianStore(..), copyFromBytes, copyToBytes
, LE, BE, littleEndian, bigEndian
, storeAt, storeAtIndex
, loadFrom, loadFromIndex
) where
import Control.Applicative
import Control.DeepSeq ( NFData)
import Control.Monad ( liftM )
import Data.Bits
import Data.Typeable
import Data.Vector.Unboxed ( MVector(..), Vector, Unbox )
import Data.Word
import Foreign.Ptr ( castPtr, Ptr )
import Foreign.Storable ( Storable, peek, poke )
import Prelude
import qualified Data.Vector.Generic as GV
import qualified Data.Vector.Generic.Mutable as GVM
import Raaz.Core.Types.Copying
import Raaz.Core.Types.Pointer
import Raaz.Core.Types.Equality
#include "MachDeps.h"
class Storable w => EndianStore w where
store :: Ptr w
-> w
-> IO ()
load :: Ptr w -> IO w
adjustEndian :: Ptr w
-> Int
-> IO ()
instance EndianStore Word8 where
store = poke
load = peek
adjustEndian _ _ = return ()
instance EndianStore w => EndianStore (BYTES w) where
store ptr (BYTES w) = store (castPtr ptr) w
load = fmap BYTES . load . castPtr
adjustEndian = adjustEndian . castToPtrW
where castToPtrW :: Ptr (BYTES w) -> Ptr w
castToPtrW = castPtr
storeAt :: ( EndianStore w
, LengthUnit offset
)
=> Ptr w
-> offset
-> w
-> IO ()
{-# INLINE storeAt #-}
storeAt ptr = store . movePtr ptr
storeAtIndex :: EndianStore w
=> Ptr w
-> Int
-> w
-> IO ()
{-# INLINE storeAtIndex #-}
storeAtIndex cptr index w = storeAt cptr offset w
where offset = toEnum index * sizeOf w
loadFromIndex :: EndianStore w
=> Ptr w
-> Int
-> IO w
{-# INLINE loadFromIndex #-}
loadFromIndex cptr index = load (shiftPtr cptr undefined)
where shiftPtr :: Storable w => Ptr w -> w -> Ptr w
shiftPtr ptr w = movePtr ptr (toEnum index * sizeOf w)
loadFrom :: ( EndianStore w
, LengthUnit offset
)
=> Ptr w
-> offset
-> IO w
{-# INLINE loadFrom #-}
loadFrom ptr = load . movePtr ptr
copyFromBytes :: EndianStore w
=> Dest (Ptr w)
-> Src Pointer
-> Int
-> IO ()
copyFromBytes dest@(Dest ptr) src n = memcpy (castPtr <$> dest) src (sz dest undefined)
>> adjustEndian ptr n
where sz :: Storable w => Dest (Ptr w) -> w -> BYTES Int
sz _ w = sizeOf w * toEnum n
copyToBytes :: EndianStore w
=> Dest Pointer
-> Src (Ptr w)
-> Int
-> IO ()
copyToBytes dest@(Dest dptr) src n = memcpy dest (castPtr <$> src) (sz src undefined)
>> adjust src (castPtr dptr)
where adjust :: EndianStore w => Src (Ptr w) -> Ptr w -> IO ()
adjust _ ptr = adjustEndian ptr n
sz :: Storable w => Src (Ptr w) -> w -> BYTES Int
sz _ w = sizeOf w * toEnum n
newtype LE w = LE { unLE :: w }
deriving ( Bounded, Enum, Read, Show
, Integral, Num, Real, Eq, Equality, Ord
, Bits, Storable, Typeable, NFData
)
instance Functor LE where
fmap f = LE . f . unLE
newtype BE w = BE { unBE :: w }
deriving ( Bounded, Enum, Read, Show
, Integral, Num, Real, Eq, Equality, Ord
, Bits, Storable, Typeable, NFData
)
instance Functor BE where
fmap f = BE . f . unBE
littleEndian :: w -> LE w
{-# INLINE littleEndian #-}
littleEndian = LE
bigEndian :: w -> BE w
{-# INLINE bigEndian #-}
bigEndian = BE
foreign import ccall unsafe "raaz/core/endian.h raazSwap32Array"
c_Swap32Array :: Ptr Word32 -> Int -> IO ()
foreign import ccall unsafe "raaz/core/endian.h raazSwap64Array"
c_Swap64Array :: Ptr Word64 -> Int -> IO ()
# if !MIN_VERSION_base(4,7,0)
foreign import ccall unsafe "raaz/core/endian.h raazSwap32"
byteSwap32 :: Word32 -> Word32
foreign import ccall unsafe "raaz/core/endian.h raazSwap64"
byteSwap64 :: Word64 -> Word64
# endif
#ifdef WORDS_BIGENDIAN
unLEPtr :: Ptr (LE w) -> Ptr w
unLEPtr = castPtr
instance EndianStore (LE Word32) where
load ptr = fmap byteSwap32 <$> peek ptr
store ptr = poke ptr . fmap byteSwap32
adjustEndian = c_Swap32Array . unLEPtr
instance EndianStore (LE Word64) where
load ptr = fmap byteSwap64 <$> peek ptr
store ptr = poke ptr . fmap byteSwap64
adjustEndian = c_Swap64Array . unLEPtr
instance EndianStore (BE Word32) where
load = peek
store = poke
adjustEndian _ _ = return ()
instance EndianStore (BE Word64) where
load = peek
store = poke
adjustEndian _ _ = return ()
# else
unBEPtr :: Ptr (BE w) -> Ptr w
unBEPtr = castPtr
instance EndianStore (BE Word32) where
load ptr = fmap byteSwap32 <$> peek ptr
store ptr = poke ptr . fmap byteSwap32
adjustEndian = c_Swap32Array . unBEPtr
instance EndianStore (BE Word64) where
load ptr = fmap byteSwap64 <$> peek ptr
store ptr = poke ptr . fmap byteSwap64
adjustEndian = c_Swap64Array . unBEPtr
instance EndianStore (LE Word32) where
load = peek
store = poke
adjustEndian _ _ = return ()
instance EndianStore (LE Word64) where
load = peek
store = poke
adjustEndian _ _ = return ()
#endif
instance Unbox w => Unbox (LE w)
instance Unbox w => Unbox (BE w)
newtype instance MVector s (LE w) = MV_LE (MVector s w)
newtype instance Vector (LE w) = V_LE (Vector w)
newtype instance MVector s (BE w) = MV_BE (MVector s w)
newtype instance Vector (BE w) = V_BE (Vector w)
instance Unbox w => GVM.MVector MVector (LE w) where
{-# INLINE basicLength #-}
{-# INLINE basicUnsafeSlice #-}
{-# INLINE basicOverlaps #-}
{-# INLINE basicUnsafeNew #-}
{-# INLINE basicUnsafeReplicate #-}
{-# INLINE basicUnsafeRead #-}
{-# INLINE basicUnsafeWrite #-}
{-# INLINE basicClear #-}
{-# INLINE basicSet #-}
{-# INLINE basicUnsafeCopy #-}
{-# INLINE basicUnsafeGrow #-}
basicLength (MV_LE v) = GVM.basicLength v
basicUnsafeSlice i n (MV_LE v) = MV_LE $ GVM.basicUnsafeSlice i n v
basicOverlaps (MV_LE v1) (MV_LE v2) = GVM.basicOverlaps v1 v2
basicUnsafeRead (MV_LE v) i = LE `liftM` GVM.basicUnsafeRead v i
basicUnsafeWrite (MV_LE v) i (LE x) = GVM.basicUnsafeWrite v i x
basicClear (MV_LE v) = GVM.basicClear v
basicSet (MV_LE v) (LE x) = GVM.basicSet v x
basicUnsafeNew n = MV_LE `liftM` GVM.basicUnsafeNew n
basicUnsafeReplicate n (LE x) = MV_LE `liftM` GVM.basicUnsafeReplicate n x
basicUnsafeCopy (MV_LE v1) (MV_LE v2) = GVM.basicUnsafeCopy v1 v2
basicUnsafeGrow (MV_LE v) n = MV_LE `liftM` GVM.basicUnsafeGrow v n
#if MIN_VERSION_vector(0,11,0)
basicInitialize (MV_LE v) = GVM.basicInitialize v
#endif
instance Unbox w => GV.Vector Vector (LE w) where
{-# INLINE basicUnsafeFreeze #-}
{-# INLINE basicUnsafeThaw #-}
{-# INLINE basicLength #-}
{-# INLINE basicUnsafeSlice #-}
{-# INLINE basicUnsafeIndexM #-}
{-# INLINE elemseq #-}
basicUnsafeFreeze (MV_LE v) = V_LE `liftM` GV.basicUnsafeFreeze v
basicUnsafeThaw (V_LE v) = MV_LE `liftM` GV.basicUnsafeThaw v
basicLength (V_LE v) = GV.basicLength v
basicUnsafeSlice i n (V_LE v) = V_LE $ GV.basicUnsafeSlice i n v
basicUnsafeIndexM (V_LE v) i = LE `liftM` GV.basicUnsafeIndexM v i
basicUnsafeCopy (MV_LE mv) (V_LE v) = GV.basicUnsafeCopy mv v
elemseq _ (LE x) = GV.elemseq (undefined :: Vector a) x
instance Unbox w => GVM.MVector MVector (BE w) where
{-# INLINE basicLength #-}
{-# INLINE basicUnsafeSlice #-}
{-# INLINE basicOverlaps #-}
{-# INLINE basicUnsafeNew #-}
{-# INLINE basicUnsafeReplicate #-}
{-# INLINE basicUnsafeRead #-}
{-# INLINE basicUnsafeWrite #-}
{-# INLINE basicClear #-}
{-# INLINE basicSet #-}
{-# INLINE basicUnsafeCopy #-}
{-# INLINE basicUnsafeGrow #-}
basicLength (MV_BE v) = GVM.basicLength v
basicUnsafeSlice i n (MV_BE v) = MV_BE $ GVM.basicUnsafeSlice i n v
basicOverlaps (MV_BE v1) (MV_BE v2) = GVM.basicOverlaps v1 v2
basicUnsafeRead (MV_BE v) i = BE `liftM` GVM.basicUnsafeRead v i
basicUnsafeWrite (MV_BE v) i (BE x) = GVM.basicUnsafeWrite v i x
basicClear (MV_BE v) = GVM.basicClear v
basicSet (MV_BE v) (BE x) = GVM.basicSet v x
basicUnsafeNew n = MV_BE `liftM` GVM.basicUnsafeNew n
basicUnsafeReplicate n (BE x) = MV_BE `liftM` GVM.basicUnsafeReplicate n x
basicUnsafeCopy (MV_BE v1) (MV_BE v2) = GVM.basicUnsafeCopy v1 v2
basicUnsafeGrow (MV_BE v) n = MV_BE `liftM` GVM.basicUnsafeGrow v n
#if MIN_VERSION_vector(0,11,0)
basicInitialize (MV_BE v) = GVM.basicInitialize v
#endif
instance Unbox w => GV.Vector Vector (BE w) where
{-# INLINE basicUnsafeFreeze #-}
{-# INLINE basicUnsafeThaw #-}
{-# INLINE basicLength #-}
{-# INLINE basicUnsafeSlice #-}
{-# INLINE basicUnsafeIndexM #-}
{-# INLINE elemseq #-}
basicUnsafeFreeze (MV_BE v) = V_BE `liftM` GV.basicUnsafeFreeze v
basicUnsafeThaw (V_BE v) = MV_BE `liftM` GV.basicUnsafeThaw v
basicLength (V_BE v) = GV.basicLength v
basicUnsafeSlice i n (V_BE v) = V_BE $ GV.basicUnsafeSlice i n v
basicUnsafeIndexM (V_BE v) i = BE `liftM` GV.basicUnsafeIndexM v i
basicUnsafeCopy (MV_BE mv) (V_BE v) = GV.basicUnsafeCopy mv v
elemseq _ (BE x) = GV.elemseq (undefined :: Vector a) x