storable-endian (empty) → 0.1.0
raw patch · 5 files changed
+390/−0 lines, 5 filesdep +basedep +haskell98dep +template-haskellsetup-changed
Dependencies added: base, haskell98, template-haskell
Files
- Data/Storable/Endian.hs +289/−0
- Data/Storable/EndianTemplate.hs +39/−0
- LICENSE +31/−0
- Setup.hs +2/−0
- storable-endian.cabal +29/−0
+ Data/Storable/Endian.hs view
@@ -0,0 +1,289 @@+-----------------------------------------------------------------------------+-- |+-- Module : Data.Storable.Endian+-- Copyright : (c) Eugene Kirpichov 2010+-- License : New BSD+--+-- Maintainer : Eugene Kirpichov <ekirpichov@gmail.com>+-- Stability : experimental+-- Portability : portable+--+-- Storable instances with endianness, in the obvious way: for example, Int64LE +-- is peeked and poked in little-endian order.+--++module Data.Storable.Endian + (+ Int16LE(..), Int16BE(..),+ Int32LE(..), Int32BE(..),+ Int64LE(..), Int64BE(..),+ Word16LE(..), Word16BE(..),+ Word32LE(..), Word32BE(..),+ Word64LE(..), Word64BE(..),+ FloatLE(..), FloatBE(..),+ DoubleLE(..), DoubleBE(..)+ ) + where++import Data.Storable.EndianTemplate++import Foreign.Storable+import Foreign.Ptr+import System.IO.Unsafe+import Unsafe.Coerce++import Data.Word+import Data.Bits+import Data.Char++import Language.Haskell.TH++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+import GHC.Base+import GHC.Word+import GHC.Int+#endif++-- The code below has been adapted from the 'binary' library+-- http://hackage.haskell.org/package/binary++------------------------------------------------------------------------++--+-- We rely on the fromIntegral to do the right masking for us.+-- The inlining here is critical, and can be worth 4x performance+--++-- | Write a Word16 in big endian format+putWord16be :: Word16 -> Ptr Word8 -> IO ()+putWord16be w p = do+ poke p (fromIntegral (shiftr_w16 w 8) :: Word8)+ poke (p `plusPtr` 1) (fromIntegral (w) :: Word8)+{-# INLINE putWord16be #-}++-- | Write a Word16 in little endian format+putWord16le :: Word16 -> Ptr Word8 -> IO ()+putWord16le w p = do+ poke p (fromIntegral (w) :: Word8)+ poke (p `plusPtr` 1) (fromIntegral (shiftr_w16 w 8) :: Word8)+{-# INLINE putWord16le #-}++-- putWord16le w16 = writeN 2 (\p -> poke (castPtr p) w16)++-- | Write a Word32 in big endian format+putWord32be :: Word32 -> Ptr Word8 -> IO ()+putWord32be w p = do+ poke p (fromIntegral (shiftr_w32 w 24) :: Word8)+ poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8)+ poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 8) :: Word8)+ poke (p `plusPtr` 3) (fromIntegral (w) :: Word8)+{-# INLINE putWord32be #-}++-- | Write a Word32 in little endian format+putWord32le :: Word32 -> Ptr Word8 -> IO ()+putWord32le w p = do+ poke p (fromIntegral (w) :: Word8)+ poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 8) :: Word8)+ poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 16) :: Word8)+ poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 w 24) :: Word8)+{-# INLINE putWord32le #-}++-- on a little endian machine:+-- putWord32le w32 = writeN 4 (\p -> poke (castPtr p) w32)++-- | Write a Word64 in big endian format+putWord64be :: Word64 -> Ptr Word8 -> IO ()+#if WORD_SIZE_IN_BITS < 64+--+-- To avoid expensive 64 bit shifts on 32 bit machines, we cast to+-- Word32, and write that+--+putWord64be w p = do+ let a = fromIntegral (shiftr_w64 w 32) :: Word32+ b = fromIntegral w :: Word32+ poke p (fromIntegral (shiftr_w32 a 24) :: Word8)+ poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 16) :: Word8)+ poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 8) :: Word8)+ poke (p `plusPtr` 3) (fromIntegral (a) :: Word8)+ poke (p `plusPtr` 4) (fromIntegral (shiftr_w32 b 24) :: Word8)+ poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 16) :: Word8)+ poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 8) :: Word8)+ poke (p `plusPtr` 7) (fromIntegral (b) :: Word8)+#else+putWord64be w p = do+ poke p (fromIntegral (shiftr_w64 w 56) :: Word8)+ poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 48) :: Word8)+ poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 40) :: Word8)+ poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 32) :: Word8)+ poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 24) :: Word8)+ poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 16) :: Word8)+ poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 8) :: Word8)+ poke (p `plusPtr` 7) (fromIntegral (w) :: Word8)+#endif+{-# INLINE putWord64be #-}++-- | Write a Word64 in little endian format+putWord64le :: Word64 -> Ptr Word8 -> IO ()++#if WORD_SIZE_IN_BITS < 64+putWord64le w p = do+ let b = fromIntegral (shiftr_w64 w 32) :: Word32+ a = fromIntegral w :: Word32+ poke (p) (fromIntegral (a) :: Word8)+ poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 8) :: Word8)+ poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 16) :: Word8)+ poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 a 24) :: Word8)+ poke (p `plusPtr` 4) (fromIntegral (b) :: Word8)+ poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 8) :: Word8)+ poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 16) :: Word8)+ poke (p `plusPtr` 7) (fromIntegral (shiftr_w32 b 24) :: Word8)+#else+putWord64le w p = do+ poke p (fromIntegral (w) :: Word8)+ poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 8) :: Word8)+ poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 16) :: Word8)+ poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 24) :: Word8)+ poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 32) :: Word8)+ poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 40) :: Word8)+ poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 48) :: Word8)+ poke (p `plusPtr` 7) (fromIntegral (shiftr_w64 w 56) :: Word8)+#endif+{-# INLINE putWord64le #-}++unsafePeekOff :: Ptr Word8 -> Int -> Word8+unsafePeekOff p off = unsafePerformIO (p `peekElemOff` off)++-- on a little endian machine:+-- putWord64le w64 = writeN 8 (\p -> poke (castPtr p) w64)+-- | Read a Word16 in big endian format+getWord16be :: Ptr Word8 -> IO Word16+getWord16be p = do+ return $! (fromIntegral (p `unsafePeekOff` 0) `shiftl_w16` 8) .|.+ (fromIntegral (p `unsafePeekOff` 1))+{-# INLINE getWord16be #-}++-- | Read a Word16 in little endian format+getWord16le :: Ptr Word8 -> IO Word16+getWord16le p = do+ return $! (fromIntegral (p `unsafePeekOff` 1) `shiftl_w16` 8) .|.+ (fromIntegral (p `unsafePeekOff` 0) )+{-# INLINE getWord16le #-}++-- | Read a Word32 in big endian format+getWord32be :: Ptr Word8 -> IO Word32+getWord32be p = do+ return $! (fromIntegral (p `unsafePeekOff` 0) `shiftl_w32` 24) .|.+ (fromIntegral (p `unsafePeekOff` 1) `shiftl_w32` 16) .|.+ (fromIntegral (p `unsafePeekOff` 2) `shiftl_w32` 8) .|.+ (fromIntegral (p `unsafePeekOff` 3) )+{-# INLINE getWord32be #-}++-- | Read a Word32 in little endian format+getWord32le :: Ptr Word8 -> IO Word32+getWord32le p = do+ return $! (fromIntegral (p `unsafePeekOff` 3) `shiftl_w32` 24) .|.+ (fromIntegral (p `unsafePeekOff` 2) `shiftl_w32` 16) .|.+ (fromIntegral (p `unsafePeekOff` 1) `shiftl_w32` 8) .|.+ (fromIntegral (p `unsafePeekOff` 0) )+{-# INLINE getWord32le #-}++-- | Read a Word64 in big endian format+getWord64be :: Ptr Word8 -> IO Word64+getWord64be p = do+ return $! (fromIntegral (p `unsafePeekOff` 0) `shiftl_w64` 56) .|.+ (fromIntegral (p `unsafePeekOff` 1) `shiftl_w64` 48) .|.+ (fromIntegral (p `unsafePeekOff` 2) `shiftl_w64` 40) .|.+ (fromIntegral (p `unsafePeekOff` 3) `shiftl_w64` 32) .|.+ (fromIntegral (p `unsafePeekOff` 4) `shiftl_w64` 24) .|.+ (fromIntegral (p `unsafePeekOff` 5) `shiftl_w64` 16) .|.+ (fromIntegral (p `unsafePeekOff` 6) `shiftl_w64` 8) .|.+ (fromIntegral (p `unsafePeekOff` 7) )+{-# INLINE getWord64be #-}++-- | Read a Word64 in little endian format+getWord64le :: Ptr Word8 -> IO Word64+getWord64le p = do+ return $! (fromIntegral (p `unsafePeekOff` 7) `shiftl_w64` 56) .|.+ (fromIntegral (p `unsafePeekOff` 6) `shiftl_w64` 48) .|.+ (fromIntegral (p `unsafePeekOff` 5) `shiftl_w64` 40) .|.+ (fromIntegral (p `unsafePeekOff` 4) `shiftl_w64` 32) .|.+ (fromIntegral (p `unsafePeekOff` 3) `shiftl_w64` 24) .|.+ (fromIntegral (p `unsafePeekOff` 2) `shiftl_w64` 16) .|.+ (fromIntegral (p `unsafePeekOff` 1) `shiftl_w64` 8) .|.+ (fromIntegral (p `unsafePeekOff` 0) )+{-# INLINE getWord64le #-}++------------------------------------------------------------------------+-- Unchecked shifts++{-# INLINE shiftr_w16 #-}+shiftr_w16 :: Word16 -> Int -> Word16+{-# INLINE shiftr_w32 #-}+shiftr_w32 :: Word32 -> Int -> Word32+{-# INLINE shiftr_w64 #-}+shiftr_w64 :: Word64 -> Int -> Word64++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i)+shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i)++#if WORD_SIZE_IN_BITS < 64+shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)++#if __GLASGOW_HASKELL__ <= 606+-- Exported by GHC.Word in GHC 6.8 and higher+foreign import ccall unsafe "stg_uncheckedShiftRL64"+ uncheckedShiftRL64# :: Word64# -> Int# -> Word64#+#endif++#else+shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)+#endif++#else+shiftr_w16 = shiftR+shiftr_w32 = shiftR+shiftr_w64 = shiftR+#endif++------------------------------------------------------------------------+-- Unchecked shifts++shiftl_w16 :: Word16 -> Int -> Word16+shiftl_w32 :: Word32 -> Int -> Word32+shiftl_w64 :: Word64 -> Int -> Word64++#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__)+shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i)+shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i)++#if WORD_SIZE_IN_BITS < 64+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i)++#if __GLASGOW_HASKELL__ <= 606+-- Exported by GHC.Word in GHC 6.8 and higher+foreign import ccall unsafe "stg_uncheckedShiftL64"+ uncheckedShiftL64# :: Word64# -> Int# -> Word64#+#endif++#else+shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i)+#endif++#else+shiftl_w16 = shiftL+shiftl_w32 = shiftL+shiftl_w64 = shiftL+#endif++$(deriveEndian "Int16" 2 16)+$(deriveEndian "Int32" 4 32)+$(deriveEndian "Int64" 8 64)++$(deriveEndian "Word16" 2 16)+$(deriveEndian "Word32" 4 32)+$(deriveEndian "Word64" 8 64)++$(deriveEndian "Float" 4 32)+$(deriveEndian "Double" 8 64)+
+ Data/Storable/EndianTemplate.hs view
@@ -0,0 +1,39 @@+module Data.Storable.EndianTemplate where++import Data.Char++import Unsafe.Coerce+import Foreign.Ptr++import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Control.Monad++concatM :: (Monad m) => [m [a]] -> m [a]+concatM [] = return []+concatM (m:ms) = liftM2 (++) m (concatM ms)++deriveEndian :: String -> Int -> Int -> Q [Dec]+deriveEndian baseName bytes bits = concatM [mapM declareNewtype ["le", "be"], mapM deriveEndian' ["le", "be"]]+ where+ declareNewtype end = do+ baseType <- conT (mkName baseName)+ let typeName = baseName ++ map toUpper end+ newtypeD (cxt []) (mkName typeName) [] (return $ NormalC (mkName typeName) [(NotStrict, baseType)]) []+ deriveEndian' end = do+ let typeName = mkName $ baseName ++ map toUpper end+ let getter = mkName $ "getWord" ++ show bits ++ end+ let putter = mkName $ "putWord" ++ show bits ++ end+ let vp = mkName "p"+ let vx = mkName "x"+ pokeBody <- [| $(varE putter) (unsafeCoerce $(varE vx)) (castPtr $(varE vp))|]+ members <- concatM [+ [d| sizeOf _ = $(lift bytes) |]+ ,[d| alignment _ = $(lift bytes) |]+ ,[d| peek p = ($(conE typeName) . unsafeCoerce) `fmap` $(varE getter) (castPtr p) |]+ ,return [FunD (mkName "poke") [Clause + [VarP (mkName "p"), ConP typeName [VarP (mkName "x")]] + (NormalB pokeBody)+ []]]+ ]+ instanceD (cxt []) (appT (conT (mkName "Storable")) (conT typeName)) (map return members)
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright (c) 2010, Eugene Kirpichov++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * The names of contributors may not be used to endorse or promote+ products derived from this software without specific prior+ written permission. ++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ storable-endian.cabal view
@@ -0,0 +1,29 @@+Name: storable-endian+Version: 0.1.0+License: BSD3+License-file: LICENSE+Copyright: Eugene Kirpichov, 2010+Author: Eugene Kirpichov <ekirpichov@gmail.com>+Maintainer: Eugene Kirpichov <ekirpichov@gmail.com>+Synopsis: Storable instances with endianness+Description: Storable instances with endianness+Category: Data+Cabal-Version: >= 1.6+Build-Type: Simple+Source-repository head+ type: git+ location: git://github.com/jkff/storable-endian++flag splitbase+ description: Choose the new smaller, split-up base package.++library + if flag(splitbase)+ Build-Depends: base >= 3 && < 5+ else+ Build-Depends: base < 3++ Build-Depends: haskell98, template-haskell+ Exposed-Modules: Data.Storable.Endian+ Other-Modules: Data.Storable.EndianTemplate+ Extensions: MagicHash, TemplateHaskell, CPP