diff --git a/Data/Repa/Convert.hs b/Data/Repa/Convert.hs --- a/Data/Repa/Convert.hs +++ b/Data/Repa/Convert.hs @@ -19,7 +19,7 @@ -- @ -- > import Data.Repa.Convert -- --- > let format = Sep '|' (VarAsc :*: IntAsc :*: DoubleAsc :*: ()) +-- > let format = mkSep '|' (VarChars :*: IntAsc :*: DoubleAsc :*: ()) -- > let Just str = packToString format ("foo" :*: 66 :*: 93.42 :*: ()) -- > str -- "foo|66|93.42" @@ -50,115 +50,180 @@ , forFormat , listFormat - -- * Packing data - , Packable (..) - - -- ** Packer monoid - , Packer (..) - , unsafeRunPacker + -- * High-level interface + -- ** for ByteStrings + , packToByteString + , unpackFromByteString - -- ** Unpacker monad - , Unpacker (..) - , unsafeRunUnpacker + -- ** for Lists of Word8 + , packToList8 + , unpackFromList8 - -- * Interfaces - -- ** Default Ascii - , packToAscii + -- ** for Strings + , packToString + , unpackFromString - -- ** List Interface - , packToList8, unpackFromList8 + -- * Low-level interface + -- * Packing data + , Packable (..) + , Packer (..) + , unsafeRunPacker - -- ** String Interface - , packToString, unpackFromString) + -- * Unpacking data + , Unpackable (..) + , Unpacker (..) + , unsafeRunUnpacker) where import Data.Repa.Convert.Format import Data.Repa.Convert.Formats -import Data.Char import Data.Word -import Control.Monad import System.IO.Unsafe -import qualified Foreign.Storable as S -import qualified Foreign.Marshal.Alloc as S -import qualified GHC.Ptr as S +import Data.IORef +import Data.ByteString (ByteString) +import qualified Data.ByteString.Internal as BS +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Foreign.ForeignPtr as F +import qualified Foreign.Marshal.Alloc as F +import qualified Foreign.Marshal.Utils as F +import qualified GHC.Ptr as F +#include "repa-convert.h" --------------------------------------------------------------------------------------------------- --- | Pack a value to a list of `Word8` using the default Ascii format. -packToAscii - :: ( FormatAscii a - , Value (FormatAscii' a) ~ a - , Packable (FormatAscii' a)) - => a -> Maybe String -packToAscii a - = packToString (formatAscii a) a +-- | Constrain the type of a value to match the given format. +-- +-- The value itself is not used. +-- +forFormat :: format -> Value format -> Value format +forFormat _ v = v +{-# INLINE forFormat #-} +-- | Constrain the type of some values to match the given format. +-- +-- The value itself is not used. +-- +listFormat :: format -> [Value format] -> [Value format] +listFormat _ v = v +{-# INLINE listFormat #-} + + --------------------------------------------------------------------------------------------------- +-- | Pack a value to a freshly allocated `ByteString`. +packToByteString + :: Packable format + => format -> Value format -> Maybe ByteString + +packToByteString format value + + -- The size returned by `packedSize` is an over-approximation. + -- As we don't want to waste space in the returned value, + -- we pack the value to a stack allocated buffer, + -- then copy it into a newly allocated ByteString when we know + -- how much space we actually need. + | Just lenMax <- packedSize format value + = unsafePerformIO + $ F.allocaBytes lenMax $ \buf + -> do + -- Pack the value into the on-stack buffer. + let !(F.Ptr addr) = buf + !ref <- newIORef Nothing + packer format value addr + (return ()) + (\buf' -> writeIORef ref (Just (F.Ptr buf'))) + mEnd <- readIORef ref + + -- See if the packer worked. + case mEnd of + Just end + -> do -- Now work out how much space we actually used. + let !lenPacked = F.minusPtr end buf + + -- Allocate a new buffer of the right size, + -- and copy the data into it. + F.mallocForeignPtrBytes lenPacked >>= \fptr + -> F.withForeignPtr fptr $ \ptr + -> do F.copyBytes ptr buf lenPacked + return $ Just $ BS.PS fptr 0 lenPacked + + Nothing + -> return Nothing + + | otherwise + = Nothing +{-# INLINE packToByteString #-} + + +-- | Unpack a value from a `ByteString`. +unpackFromByteString + :: Unpackable format + => format -> ByteString -> Maybe (Value format) + +unpackFromByteString format (BS.PS fptr offset len) + -- If the bytestring is too short to hold a value of the minimum + -- size then we're going to have a bad time. + | len < minSize format + = Nothing + + -- Open up the bytestring and try to unpack its contents. + | otherwise + = unsafePerformIO + $ F.withForeignPtr fptr $ \ptr_ + -> do + let !(F.Ptr start) = F.plusPtr ptr_ offset + let !(F.Ptr end) = F.plusPtr (F.Ptr start) len + + !ref <- newIORef Nothing + unpacker format start end + (const False) + (return ()) + (\done' value -> writeIORef ref $ Just (F.Ptr done', value)) + mResult <- readIORef ref + + return $ case mResult of + Nothing -> Nothing + Just (done, value) + | done /= F.Ptr end -> Nothing + | otherwise -> Just value +{-# INLINE unpackFromByteString #-} + + +--------------------------------------------------------------------------------------------------- -- | Pack a value to a list of `Word8`. packToList8 :: Packable format => format -> Value format -> Maybe [Word8] -packToList8 f x - | Just lenMax <- packedSize f x - = unsafePerformIO - $ do buf <- S.mallocBytes lenMax - mResult <- unsafeRunPacker (pack f x) buf - case mResult of - Nothing -> return Nothing - Just buf' - -> do let lenUsed = S.minusPtr buf' buf - xs <- mapM (S.peekByteOff buf) [0 .. lenUsed - 1] - S.free buf - return $ Just xs - - | otherwise = Nothing +packToList8 format value + = fmap BS.unpack $ packToByteString format value +{-# INLINE packToList8 #-} -- | Unpack a value from a list of `Word8`. unpackFromList8 - :: Packable format + :: Unpackable format => format -> [Word8] -> Maybe (Value format) -unpackFromList8 format xs - = unsafePerformIO - $ do let len = length xs - buf <- S.mallocBytes len - mapM_ (\(o, x) -> S.pokeByteOff buf o x) - $ zip [0 .. len - 1] xs - r <- unsafeRunUnpacker (unpack format) buf len (const False) - return $ fmap fst r +unpackFromList8 format ws + = unpackFromByteString format $ BS.pack ws +{-# INLINE unpackFromList8 #-} --- | Pack a value to a String. +--------------------------------------------------------------------------------------------------- +-- | Pack a value to a (hated) Haskell `String`. packToString :: Packable format => format -> Value format -> Maybe String -packToString f v - = liftM (map (chr . fromIntegral)) $ packToList8 f v +packToString format value + = fmap BS8.unpack $ packToByteString format value +{-# INLINE packToString #-} --- | Unpack a value from a String. +-- | Unpack a value from a (hated) Haskell `String`. unpackFromString - :: Packable format + :: Unpackable format => format -> String -> Maybe (Value format) -unpackFromString f s - = unpackFromList8 f $ map (fromIntegral . ord) s - - ---------------------------------------------------------------------------------------------------- --- | Constrain the type of a value to match the given format. --- --- The value itself is not used. --- -forFormat :: format -> Value format -> Value format -forFormat _ v = v -{-# INLINE forFormat #-} - +unpackFromString format ss + = unpackFromByteString format $ BS8.pack ss +{-# INLINE unpackFromString #-} --- | Constrain the type of some values to match the given format. --- --- The value itself is not used. --- -listFormat :: format -> [Value format] -> [Value format] -listFormat _ v = v -{-# INLINE listFormat #-} diff --git a/Data/Repa/Convert/Format.hs b/Data/Repa/Convert/Format.hs --- a/Data/Repa/Convert/Format.hs +++ b/Data/Repa/Convert/Format.hs @@ -7,13 +7,15 @@ -- * Packable , Packable (..) - - -- ** Packer , Packer (..) , unsafeRunPacker - -- ** Unpacker - , Unpacker (..) + -- ** Unpackable + , Unpackable (..) + , Unpacker (..) , unsafeRunUnpacker) where -import Data.Repa.Convert.Format.Base +import Data.Repa.Convert.Internal.Format +import Data.Repa.Convert.Internal.Packable +import Data.Repa.Convert.Internal.Packer +import Data.Repa.Convert.Internal.Unpacker diff --git a/Data/Repa/Convert/Format/App.hs b/Data/Repa/Convert/Format/App.hs --- a/Data/Repa/Convert/Format/App.hs +++ b/Data/Repa/Convert/Format/App.hs @@ -2,15 +2,17 @@ module Data.Repa.Convert.Format.App (App (..)) where -import Data.Repa.Convert.Format.Base +import Data.Repa.Convert.Internal.Format +import Data.Repa.Convert.Internal.Packable +import Data.Repa.Convert.Internal.Packer import Data.Repa.Scalar.Product import Data.Monoid +import Prelude hiding (fail) +#include "repa-convert.h" -- | Append fields without separators. -data App f - = App f - deriving Show +data App f = App f instance Format (App ()) where @@ -33,43 +35,58 @@ minSize (App (f1 :*: fs)) = minSize f1 + minSize (App fs) + {-# NOINLINE minSize #-} fieldCount (App (_f1 :*: fs)) = 1 + fieldCount (App fs) + {-# NOINLINE fieldCount #-} fixedSize (App (f1 :*: fs)) = do s1 <- fixedSize f1 ss <- fixedSize (App fs) return $ s1 + ss + {-# NOINLINE fixedSize #-} packedSize (App (f1 :*: fs)) (x1 :*: xs) = do s1 <- packedSize f1 x1 ss <- packedSize (App fs) xs return $ s1 + ss - {-# INLINE minSize #-} - {-# INLINE fieldCount #-} - {-# INLINE fixedSize #-} - {-# INLINE packedSize #-} + {-# NOINLINE packedSize #-} instance Packable (App ()) where - pack _fmt _val = mempty - unpack _fmt = return () - {-# INLINE pack #-} - {-# INLINE unpack #-} + packer _f _v start _fails eat + = eat start + {-# INLINE packer #-} + +instance Unpackable (App ()) where + unpacker _f start _end _stop _fails eat + = eat start () + {-# INLINE unpacker #-} + instance ( Packable f1, Packable (App fs) , Value (App fs) ~ Value fs) => Packable (App (f1 :*: fs)) where pack (App (f1 :*: fs)) (x1 :*: xs) = pack f1 x1 <> pack (App fs) xs + {-# NOINLINE pack #-} - unpack (App (f1 :*: fs)) - = do x1 <- unpack f1 - xs <- unpack (App fs) - return (x1 :*: xs) - {-# INLINE pack #-} + packer f v + = fromPacker $ pack f v + {-# INLINE packer #-} + + +instance ( Unpackable f1, Unpackable (App fs) + , Value (App fs) ~ Value fs) + => Unpackable (App (f1 :*: fs)) where + + unpacker (App (f1 :*: fs)) start end stop fail eat + = unpacker f1 start end stop fail $ \start_x1 x1 + -> unpacker (App fs) start_x1 end stop fail $ \start_xs xs + -> eat start_xs (x1 :*: xs) {-# INLINE unpack #-} + diff --git a/Data/Repa/Convert/Format/Ascii.hs b/Data/Repa/Convert/Format/Ascii.hs --- a/Data/Repa/Convert/Format/Ascii.hs +++ b/Data/Repa/Convert/Format/Ascii.hs @@ -3,11 +3,11 @@ (FormatAscii (..)) where import Data.Repa.Convert.Format.Numeric -import Data.Repa.Convert.Format.Lists +import Data.Repa.Convert.Format.String import Data.Repa.Convert.Format.Date32 -import Data.Repa.Convert.Format.Tup import Data.Repa.Scalar.Date32 (Date32) import Data.Repa.Scalar.Product +#include "repa-convert.h" -- | Class of types that can be formatted in some default human readable @@ -33,23 +33,6 @@ {-# INLINE formatAscii #-} --- | Tuples are displayed with round parens and commas to separate --- the fields. -instance ( FormatAscii t1 - , FormatAscii (Plain ts)) - => FormatAscii (t1 :*: ts) where - - type FormatAscii' (t1 :*: ts) - = Tup (FormatAscii' t1 :*: FormatAscii' (Plain ts)) - - formatAscii _ - = let -- The values of these type proxies should never be demanded. - (x1_proxy :: t1) = error "repa-convert: formatAscii proxy" - (xs_proxy :: ts) = error "repa-convert: formatAscii proxy" - in Tup (formatAscii x1_proxy :*: formatAscii (Plain xs_proxy)) - {-# INLINE formatAscii #-} - - instance FormatAscii (Plain ()) where type FormatAscii' (Plain ()) = () formatAscii (Plain _) = () @@ -66,7 +49,7 @@ (x1_proxy :: t1) = error "repa-convert: formatAscii proxy" (xs_proxy :: ts) = error "repa-convert: formatAscii proxy" in formatAscii x1_proxy :*: formatAscii (Plain xs_proxy) - {-# INLINE formatAscii #-} + {-# NOINLINE formatAscii #-} -- | Ints are formated in base-10. @@ -86,8 +69,8 @@ -- | Strings are formatted with double quotes and back-slash escaping -- of special characters. instance FormatAscii String where - type FormatAscii' String = VarString - formatAscii _ = VarString + type FormatAscii' String = VarCharString + formatAscii _ = VarCharString {-# INLINE formatAscii #-} diff --git a/Data/Repa/Convert/Format/Base.hs b/Data/Repa/Convert/Format/Base.hs deleted file mode 100644 --- a/Data/Repa/Convert/Format/Base.hs +++ /dev/null @@ -1,206 +0,0 @@ - -module Data.Repa.Convert.Format.Base - ( Format (..) - , Packable (..) - - -- * Packer - , Packer (..) - , unsafeRunPacker - - -- * Unpacker - , Unpacker (..) - , unsafeRunUnpacker) -where -import Data.Word -import Data.IORef -import qualified Foreign.Ptr as S -import Prelude hiding (fail) - ---------------------------------------------------------------------------------------------------- --- | Relates a storage format to the Haskell type of the value --- that is stored in that format. -class Format f where - - -- | Get the type of a value with this format. - type Value f - - -- | Yield the number of separate fields in this format. - fieldCount :: f -> Int - - - -- | Yield the minumum number of bytes that a value of this - -- format will take up. - -- - -- Packing a value into this format - -- is guaranteed to use at least this many bytes. - -- This is exact for fixed-size formats. - minSize :: f -> Int - - - -- | For fixed size formats, yield their size (length) in bytes. - -- - -- Yields `Nothing` if this is not a fixed size format. - -- - fixedSize :: f -> Maybe Int - - - -- | Yield the size of a value in the given format. - -- - -- Yields `Nothing` when a collection of values is to be packed into a - -- fixed length format, but the size of the collection does not match - -- the format. - -- - -- If `fixedSize` returns a size then `packedSize` returns the same size. - -- - packedSize :: f -> Value f -> Maybe Int - - ---------------------------------------------------------------------------------------------------- --- | Packer wraps a function that can write to a buffer. -data Packer - = Packer - { -- | Takes start of buffer, packs data into it, and calls the - -- continuation with a pointer to the byte just after the - -- last one that was written. - fromPacker - :: S.Ptr Word8 - -> (S.Ptr Word8 -> IO (Maybe (S.Ptr Word8))) - -> IO (Maybe (S.Ptr Word8)) - } - -instance Monoid Packer where - mempty - = Packer $ \buf k -> k buf - {-# INLINE mempty #-} - - mappend (Packer fa) (Packer fb) - = Packer $ \buf0 k -> fa buf0 (\buf1 -> fb buf1 k) - {-# INLINE mappend #-} - - --- | Pack data into the given buffer. --- --- PRECONDITION: The buffer needs to be big enough to hold the packed data, --- otherwise you'll corrupt the heap (bad). Use `packedSize` to work out --- how big it needs to be. --- -unsafeRunPacker - :: Packer -- ^ Packer to run. - -> S.Ptr Word8 -- ^ Start of buffer. - -> IO (Maybe (S.Ptr Word8)) - -- ^ Pointer to the byte after the last one written. - -unsafeRunPacker (Packer make) buf - = make buf (\buf' -> return (Just buf')) -{-# INLINE unsafeRunPacker #-} - - ---------------------------------------------------------------------------------------------------- -data Unpacker a - = Unpacker - { -- | Takes pointers to the first byte in the buffer, the first byte - -- after the buffer, and a special field terminating character. - -- The field terminating character is used by variable length - -- encodings where the length of the encoded data cannot be - -- determined from the encoding itself. - -- - -- If a value can be successfully unpacked from the buffer then - -- it is passed to the continuation, along with a pointer to the - -- byte after the last one that was read. If not, then the fail - -- action is invoked. - -- - fromUnpacker - :: forall b - . S.Ptr Word8 -- Start of buffer. - -> S.Ptr Word8 -- Pointer to first byte after end of buffer. - -> (Word8 -> Bool) -- Detect a field terminator. - -> IO b -- Signal failure. - -> (S.Ptr Word8 -> a -> IO b) -- Eat an unpacked value. - -> IO b - } - - -instance Functor Unpacker where - fmap f (Unpacker fx) - = Unpacker $ \start end stop fail eat - -> fx start end stop fail $ \start_x x - -> eat start_x (f x) - {-# INLINE fmap #-} - - -instance Applicative Unpacker where - pure x - = Unpacker $ \start _end _fail _stop eat - -> eat start x - {-# INLINE pure #-} - - (<*>) (Unpacker ff) (Unpacker fx) - = Unpacker $ \start end stop fail eat - -> ff start end stop fail $ \start_f f - -> fx start_f end stop fail $ \start_x x - -> eat start_x (f x) - {-# INLINE (<*>) #-} - - -instance Monad Unpacker where - return = pure - {-# INLINE return #-} - - (>>=) (Unpacker fa) mkfb - = Unpacker $ \start end stop fail eat - -> fa start end stop fail $ \start_x x - -> case mkfb x of - Unpacker fb - -> fb start_x end stop fail eat - {-# INLINE (>>=) #-} - - --- | Unpack data from the given buffer. --- --- PRECONDITION: The buffer must be at least the minimum size of the --- format (minSize). This allows us to avoid repeatedly checking for --- buffer overrun when unpacking fixed size format. If the buffer --- is not long enough then you'll get an indeterminate result (bad). --- -unsafeRunUnpacker - :: Unpacker a -- ^ Unpacker to run. - -> S.Ptr Word8 -- ^ Source buffer. - -> Int -- ^ Length of source buffer. - -> (Word8 -> Bool) -- ^ Detect a field terminator. - -> IO (Maybe (a, S.Ptr Word8)) - -- ^ Unpacked result, and pointer to the byte after the last - -- one read. - -unsafeRunUnpacker (Unpacker f) start len stop - = do ref <- newIORef Nothing - f start - (S.plusPtr start len) - stop - (return ()) - (\ptr x -> writeIORef ref (Just (x, ptr))) - readIORef ref -{-# INLINE unsafeRunUnpacker #-} - - ---------------------------------------------------------------------------------------------------- --- | Class of storage formats that can have values packed and unpacked --- from foreign bufferes. --- --- The methods are written using continuations to make it easier for --- GHC to optimise its core code when packing/unpacking many fields. --- -class Format format - => Packable format where - - - -- | Pack a value into a buffer using the given format. - pack :: format -- ^ Storage format. - -> Value format -- ^ Value to pack. - -> Packer -- ^ Packer that can write the value. - - - -- | Unpack a value from a buffer using the given format. - unpack :: format -- ^ Storage format. - -> Unpacker (Value format) -- ^ Unpacker for that format. - - diff --git a/Data/Repa/Convert/Format/Binary.hs b/Data/Repa/Convert/Format/Binary.hs --- a/Data/Repa/Convert/Format/Binary.hs +++ b/Data/Repa/Convert/Format/Binary.hs @@ -11,7 +11,8 @@ , Float32be (..) , Float64be (..)) where -import Data.Repa.Convert.Format.Base +import Data.Repa.Convert.Internal.Format +import Data.Repa.Convert.Internal.Packable import Data.Bits import Data.Int as V import Data.Word as V @@ -19,6 +20,9 @@ import qualified Foreign.Marshal.Alloc as S import qualified Foreign.Ptr as S import qualified Control.Monad.Primitive as Prim +import GHC.Exts +import Prelude hiding (fail) +#include "repa-convert.h" ------------------------------------------------------------------------------------------- Word8be @@ -37,16 +41,17 @@ instance Packable Word8be where - pack Word8be x - = Packer $ \buf k - -> do S.poke buf (fromIntegral x) - k (S.plusPtr buf 1) + packer _ x dst _fails k + = do S.poke (Ptr dst) (fromIntegral x :: Word8) + let !(Ptr dst') = S.plusPtr (Ptr dst) 1 + k dst' {-# INLINE pack #-} - unpack Word8be - = Unpacker $ \start _end _stop _fail eat - -> do x <- S.peek start - eat (S.plusPtr start 1) (fromIntegral x) + +instance Unpackable Word8be where + unpacker _ start _end _stop _fail eat + = do x <- S.peek (pw8 start) + eat (plusAddr# start 1#) (fromIntegral x) {-# INLINE unpack #-} @@ -71,12 +76,18 @@ instance Packable Int8be where - pack Int8be x = pack Word8be (w8 x) - unpack Int8be = fmap i8 (unpack Word8be) - {-# INLINE pack #-} - {-# INLINE unpack #-} + packer Int8be x buf k + = packer Word8be (w8 x) buf k + {-# INLINE packer #-} +instance Unpackable Int8be where + unpacker Int8be start end stop fail eat + = unpacker Word8be start end stop fail + $ \addr v -> eat addr (i8 v) + {-# INLINE unpacker #-} + + i8 :: Integral a => a -> Int8 i8 = fromIntegral {-# INLINE i8 #-} @@ -98,20 +109,21 @@ instance Packable Word16be where - pack Word16be x - = Packer $ \buf k - -> do S.poke buf (w8 ((w16 x .&. 0x0ff00) `shiftR` 8)) - S.pokeByteOff buf 1 (w8 ((w16 x .&. 0x000ff))) - k (S.plusPtr buf 2) - {-# INLINE pack #-} + packer Word16be x dst _fails k + = do S.poke (Ptr dst) (w8 ((w16 x .&. 0x0ff00) `shiftR` 8)) + S.pokeByteOff (Ptr dst) 1 (w8 ((w16 x .&. 0x000ff))) + let !(Ptr dst') = S.plusPtr (Ptr dst) 2 + k dst' + {-# INLINE packer #-} - unpack Word16be - = Unpacker $ \start _end _stop _fail eat - -> do x0 :: Word8 <- S.peek start - x1 :: Word8 <- S.peekByteOff start 1 - eat (S.plusPtr start 2) + +instance Unpackable Word16be where + unpacker Word16be start _end _stop _fail eat + = do x0 :: Word8 <- S.peek (pw8 start) + x1 :: Word8 <- S.peekByteOff (pw8 start) 1 + eat (plusAddr# start 2#) (w16 ((w16 x0 `shiftL` 8) .|. w16 x1)) - {-# INLINE unpack #-} + {-# INLINE unpacker #-} w16 :: Integral a => a -> Word16 @@ -135,12 +147,18 @@ instance Packable Int16be where - pack Int16be x = pack Word16be (w16 x) - unpack Int16be = fmap i16 (unpack Word16be) - {-# INLINE pack #-} - {-# INLINE unpack #-} + packer Int16be x buf k + = packer Word16be (w16 x) buf k + {-# INLINE packer #-} +instance Unpackable Int16be where + unpacker Int16be start end stop fail eat + = unpacker Word16be start end stop fail + $ \addr v -> eat addr (i16 v) + {-# INLINE unpacker #-} + + i16 :: Integral a => a -> Int16 i16 = fromIntegral {-# INLINE i16 #-} @@ -162,22 +180,23 @@ instance Packable Word32be where - pack Word32be x - = Packer $ \buf k - -> do S.poke buf (w8 ((w32 x .&. 0x0ff000000) `shiftR` 24)) - S.pokeByteOff buf 1 (w8 ((w32 x .&. 0x000ff0000) `shiftR` 16)) - S.pokeByteOff buf 2 (w8 ((w32 x .&. 0x00000ff00) `shiftR` 8)) - S.pokeByteOff buf 3 (w8 ((w32 x .&. 0x0000000ff))) - k (S.plusPtr buf 4) - {-# INLINE pack #-} + packer Word32be x dst _fails k + = do S.poke (Ptr dst) (w8 ((w32 x .&. 0x0ff000000) `shiftR` 24)) + S.pokeByteOff (Ptr dst) 1 (w8 ((w32 x .&. 0x000ff0000) `shiftR` 16)) + S.pokeByteOff (Ptr dst) 2 (w8 ((w32 x .&. 0x00000ff00) `shiftR` 8)) + S.pokeByteOff (Ptr dst) 3 (w8 ((w32 x .&. 0x0000000ff))) + let !(Ptr dst') = S.plusPtr (Ptr dst) 4 + k dst' + {-# INLINE packer #-} - unpack Word32be - = Unpacker $ \start _end _fail _stop eat - -> do x0 :: Word8 <- S.peek start - x1 :: Word8 <- S.peekByteOff start 1 - x2 :: Word8 <- S.peekByteOff start 2 - x3 :: Word8 <- S.peekByteOff start 3 - eat (S.plusPtr start 4) + +instance Unpackable Word32be where + unpacker Word32be start _end _fail _stop eat + = do x0 :: Word8 <- S.peek (pw8 start) + x1 :: Word8 <- S.peekByteOff (pw8 start) 1 + x2 :: Word8 <- S.peekByteOff (pw8 start) 2 + x3 :: Word8 <- S.peekByteOff (pw8 start) 3 + eat (plusAddr# start 4#) (w32 ( (w32 x0 `shiftL` 24) .|. (w32 x1 `shiftL` 16) .|. (w32 x2 `shiftL` 8) @@ -190,7 +209,6 @@ {-# INLINE w32 #-} - ------------------------------------------------------------------------------------------- Int32be -- | Big-endian 32-bit signed integer. data Int32be = Int32be deriving (Eq, Show) @@ -207,12 +225,18 @@ instance Packable Int32be where - pack Int32be x = pack Word32be (w32 x) - unpack Int32be = fmap i32 (unpack Word32be) - {-# INLINE pack #-} - {-# INLINE unpack #-} + packer Int32be x buf k + = packer Word32be (w32 x) buf k + {-# INLINE packer #-} +instance Unpackable Int32be where + unpacker Int32be start end stop fail eat + = unpacker Word32be start end stop fail + $ \addr v -> eat addr (i32 v) + {-# INLINE unpacker #-} + + i32 :: Integral a => a -> Int32 i32 = fromIntegral {-# INLINE i32 #-} @@ -234,30 +258,31 @@ instance Packable Word64be where - pack Word64be x - = Packer $ \buf k - -> do S.poke buf (w8 ((w64 x .&. 0x0ff00000000000000) `shiftR` 56)) - S.pokeByteOff buf 1 (w8 ((w64 x .&. 0x000ff000000000000) `shiftR` 48)) - S.pokeByteOff buf 2 (w8 ((w64 x .&. 0x00000ff0000000000) `shiftR` 40)) - S.pokeByteOff buf 3 (w8 ((w64 x .&. 0x0000000ff00000000) `shiftR` 32)) - S.pokeByteOff buf 4 (w8 ((w64 x .&. 0x000000000ff000000) `shiftR` 24)) - S.pokeByteOff buf 5 (w8 ((w64 x .&. 0x00000000000ff0000) `shiftR` 16)) - S.pokeByteOff buf 6 (w8 ((w64 x .&. 0x0000000000000ff00) `shiftR` 8)) - S.pokeByteOff buf 7 (w8 ((w64 x .&. 0x000000000000000ff) )) - k (S.plusPtr buf 8) - {-# INLINE pack #-} + packer Word64be x dst _fails k + = do S.poke (Ptr dst) (w8 ((w64 x .&. 0x0ff00000000000000) `shiftR` 56)) + S.pokeByteOff (Ptr dst) 1 (w8 ((w64 x .&. 0x000ff000000000000) `shiftR` 48)) + S.pokeByteOff (Ptr dst) 2 (w8 ((w64 x .&. 0x00000ff0000000000) `shiftR` 40)) + S.pokeByteOff (Ptr dst) 3 (w8 ((w64 x .&. 0x0000000ff00000000) `shiftR` 32)) + S.pokeByteOff (Ptr dst) 4 (w8 ((w64 x .&. 0x000000000ff000000) `shiftR` 24)) + S.pokeByteOff (Ptr dst) 5 (w8 ((w64 x .&. 0x00000000000ff0000) `shiftR` 16)) + S.pokeByteOff (Ptr dst) 6 (w8 ((w64 x .&. 0x0000000000000ff00) `shiftR` 8)) + S.pokeByteOff (Ptr dst) 7 (w8 ((w64 x .&. 0x000000000000000ff) )) + let !(Ptr dst') = S.plusPtr (Ptr dst) 8 + k dst' + {-# INLINE packer #-} - unpack Word64be - = Unpacker $ \start _end _fail _stop eat - -> do x0 :: Word8 <- S.peek start - x1 :: Word8 <- S.peekByteOff start 1 - x2 :: Word8 <- S.peekByteOff start 2 - x3 :: Word8 <- S.peekByteOff start 3 - x4 :: Word8 <- S.peekByteOff start 4 - x5 :: Word8 <- S.peekByteOff start 5 - x6 :: Word8 <- S.peekByteOff start 6 - x7 :: Word8 <- S.peekByteOff start 7 - eat (S.plusPtr start 8) + +instance Unpackable Word64be where + unpacker Word64be start _end _fail _stop eat + = do x0 :: Word8 <- S.peek (pw8 start) + x1 :: Word8 <- S.peekByteOff (pw8 start) 1 + x2 :: Word8 <- S.peekByteOff (pw8 start) 2 + x3 :: Word8 <- S.peekByteOff (pw8 start) 3 + x4 :: Word8 <- S.peekByteOff (pw8 start) 4 + x5 :: Word8 <- S.peekByteOff (pw8 start) 5 + x6 :: Word8 <- S.peekByteOff (pw8 start) 6 + x7 :: Word8 <- S.peekByteOff (pw8 start) 7 + eat (plusAddr# start 8#) (w64 ( (w64 x0 `shiftL` 56) .|. (w64 x1 `shiftL` 48) .|. (w64 x2 `shiftL` 40) @@ -266,7 +291,7 @@ .|. (w64 x5 `shiftL` 16) .|. (w64 x6 `shiftL` 8) .|. (w64 x7 ))) - {-# INLINE unpack #-} + {-# INLINE unpacker #-} w64 :: Integral a => a -> Word64 @@ -290,12 +315,18 @@ instance Packable Int64be where - pack Int64be x = pack Word64be (w64 x) - unpack Int64be = fmap i64 (unpack Word64be) - {-# INLINE pack #-} - {-# INLINE unpack #-} + packer Int64be x buf k + = packer Word64be (w64 x) buf k + {-# INLINE packer #-} +instance Unpackable Int64be where + unpacker Int64be start end stop fail eat + = unpacker Word64be start end stop fail + $ \addr v -> eat addr (i64 v) + {-# INLINE unpacker #-} + + i64 :: Integral a => a -> Int64 i64 = fromIntegral {-# INLINE i64 #-} @@ -317,16 +348,23 @@ instance Packable Float32be where - pack Float32be x = pack Word32be (floatToWord32 x) - unpack Float32be = fmap word32ToFloat (unpack Word32be) - {-# INLINE pack #-} - {-# INLINE unpack #-} + packer Float32be x buf k + = packer Word32be (floatToWord32 x) buf k + {-# INLINE packer #-} +instance Unpackable Float32be where + unpacker Float32be start end stop fail eat + = unpacker Word32be start end stop fail + $ \addr v -> eat addr (word32ToFloat v) + {-# INLINE unpacker #-} + + -- | Bitwise cast of `Float` to `Word32`. -- --- The resulting `Word32` contains the representation of the `Float`, --- rather than it's value. +-- The resulting `Word32` contains the binary representation of the +-- `Float`, rather than the integral part of its value. +-- floatToWord32 :: Float -> Word32 floatToWord32 d = Prim.unsafeInlineIO @@ -362,16 +400,23 @@ instance Packable Float64be where - pack Float64be x = pack Word64be (doubleToWord64 x) - unpack Float64be = fmap word64ToDouble (unpack Word64be) - {-# INLINE pack #-} - {-# INLINE unpack #-} + packer Float64be x start fails eat + = packer Word64be (doubleToWord64 x) start fails eat + {-# INLINE packer #-} +instance Unpackable Float64be where + unpacker Float64be start end stop fail eat + = unpacker Word64be start end stop fail + $ \addr v -> eat addr (word64ToDouble v) + {-# INLINE unpacker #-} + + -- | Bitwise cast of `Double` to `Word64`. -- --- The resulting `Word64` contains the representation of the `Double`, --- rather than it's value. +-- The resulting `Word64` contains the binary representation of the +-- `Double`, rather than the integral part of its value. +-- doubleToWord64 :: Double -> Word64 doubleToWord64 d = Prim.unsafeInlineIO @@ -390,4 +435,9 @@ S.peek buf {-# INLINE word64ToDouble #-} + +--------------------------------------------------------------------------------------------------- +pw8 :: Addr# -> Ptr Word8 +pw8 addr = Ptr addr +{-# INLINE pw8 #-} diff --git a/Data/Repa/Convert/Format/Bytes.hs b/Data/Repa/Convert/Format/Bytes.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Convert/Format/Bytes.hs @@ -0,0 +1,101 @@ + +-- | Conversions for "Data.ByteString" things. +module Data.Repa.Convert.Format.Bytes + (VarBytes (..)) +where +import Data.Repa.Convert.Internal.Format +import Data.Repa.Convert.Internal.Packable +import Data.Word +import GHC.Exts +import Prelude hiding (fail) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Internal as BS +import qualified Foreign.Marshal.Alloc as F +import qualified Foreign.ForeignPtr as F +import qualified Foreign.Storable as F +import qualified Foreign.Ptr as F + + +-- | Variable length sequence of bytes, represented as a `Data.ByteString`. +-- +data VarBytes = VarBytes deriving (Eq, Show) +instance Format VarBytes where + type Value VarBytes = ByteString + fieldCount _ = 1 + minSize _ = 0 + fixedSize VarBytes = Nothing + packedSize VarBytes bs = Just $ BS.length bs + {-# INLINE fieldCount #-} + {-# INLINE minSize #-} + {-# INLINE fixedSize #-} + {-# INLINE packedSize #-} + + +instance Packable VarBytes where + + packer VarBytes (BS.PS fptr start len) dst _fails k + = F.withForeignPtr fptr + $ \ptr_ + -> let + -- Pointer to active bytes. + !ptr = F.plusPtr ptr_ start + + -- Copy bytes from the bytestring to the destination buffer. + packer_VarBytes !ix + | ix >= len + = let !(Ptr dst') = F.plusPtr (Ptr dst) ix + in k dst' + + | otherwise + = do !(x :: Word8) <- F.peekByteOff ptr ix + F.pokeByteOff (Ptr dst) ix x + packer_VarBytes (ix + 1) + {-# INLINE packer_VarBytes #-} + + in packer_VarBytes 0 + + +instance Unpackable VarBytes where + + unpacker VarBytes start end stop _fail eat + = checkLen 0 + where + -- Length of the input buffer. + !lenBuf = F.minusPtr (pw8 end) (pw8 start) + + -- Scan through the input to see how long the result will be. + checkLen !ix + | ix >= lenBuf + = copy lenBuf + + | otherwise + = do !(x :: Word8) <- F.peekByteOff (pw8 start) ix + if stop x + then copy ix + else checkLen (ix + 1) + {-# INLINE checkLen #-} + + -- Copy the desired bytes into a new buffer. + copy !len + = F.mallocBytes len >>= \ptr + -> let + unpacker_VarBytes !ix + | ix >= len + = do fptr <- F.newForeignPtr F.finalizerFree ptr + let bs = BS.PS fptr 0 len + let !(Ptr start') = F.plusPtr (pw8 start) len + eat start' bs + + | otherwise + = do x :: Word8 <- F.peekByteOff (pw8 start) ix + F.pokeByteOff ptr ix x + unpacker_VarBytes (ix + 1) + in unpacker_VarBytes 0 + {-# INLINE copy #-} + {-# INLINE unpacker #-} + + +pw8 :: Addr# -> Ptr Word8 +pw8 addr = Ptr addr +{-# INLINE pw8 #-} diff --git a/Data/Repa/Convert/Format/Date32.hs b/Data/Repa/Convert/Format/Date32.hs --- a/Data/Repa/Convert/Format/Date32.hs +++ b/Data/Repa/Convert/Format/Date32.hs @@ -3,20 +3,22 @@ ( YYYYsMMsDD (..) , DDsMMsYYYY (..)) where -import Data.Repa.Convert.Format.Base +import Data.Repa.Convert.Internal.Packable +import Data.Repa.Convert.Internal.Packer import Data.Repa.Convert.Format.Numeric import Data.Repa.Convert.Format.Binary import Data.Monoid import Data.Char import Data.Word +import GHC.Exts import Data.Repa.Scalar.Date32 (Date32) import qualified Data.Repa.Scalar.Date32 as Date32 -import qualified Foreign.Ptr as F import Prelude hiding (fail) +#include "repa-convert.h" ---------------------------------------------------------------------------------------- YYYYsMMsDD --- | Date32 in ASCII YYYYsMMsDD format. +-- | Human readable ASCII date in YYYYsMMsDD format. data YYYYsMMsDD = YYYYsMMsDD Char deriving (Eq, Show) instance Format YYYYsMMsDD where type Value YYYYsMMsDD = Date32 @@ -32,31 +34,37 @@ instance Packable YYYYsMMsDD where - pack (YYYYsMMsDD s) v - | (yy', mm', dd') <- Date32.unpack v - , yy <- fromIntegral yy' - , mm <- fromIntegral mm' - , dd <- fromIntegral dd' - = pack (IntAsc0 4) yy + pack (YYYYsMMsDD s) !v + = let (yy', mm', dd') = Date32.unpack v + !yy = fromIntegral yy' + !mm = fromIntegral mm' + !dd = fromIntegral dd' + in pack (IntAsc0 4) yy <> pack Word8be (cw8 s) <> pack (IntAsc0 2) mm <> pack Word8be (cw8 s) <> pack (IntAsc0 2) dd {-# INLINE pack #-} - unpack (YYYYsMMsDD s) - = Unpacker $ \start end _stop fail eat - -> do - let !len = F.minusPtr end start - r <- Date32.loadYYYYsMMsDD (fromIntegral $ ord s) start len + packer f v + = fromPacker (pack f v) + {-# INLINE packer #-} + + + +instance Unpackable YYYYsMMsDD where + + unpacker (YYYYsMMsDD s) start end _stop fail eat + = do let len = I# (minusAddr# end start) + r <- Date32.loadYYYYsMMsDD (fromIntegral $ ord s) (pw8 start) len case r of - Just (d, o) -> eat (F.plusPtr start o) d + Just (d, I# o) -> eat (plusAddr# start o) d Nothing -> fail {-# INLINE unpack #-} ---------------------------------------------------------------------------------------- DDsMMsYYYY --- | Date32 in ASCII DDsMMsYYYY format. +-- | Human readable ASCII date in DDsMMsYYYY format. data DDsMMsYYYY = DDsMMsYYYY Char deriving (Eq, Show) instance Format DDsMMsYYYY where type Value DDsMMsYYYY = Date32 @@ -72,26 +80,33 @@ instance Packable DDsMMsYYYY where - pack (DDsMMsYYYY s) v - | (yy', mm', dd') <- Date32.unpack v - , yy <- fromIntegral yy' - , mm <- fromIntegral mm' - , dd <- fromIntegral dd' - = pack (IntAsc0 2) dd + pack (DDsMMsYYYY s) !v + = let (yy', mm', dd') = Date32.unpack v + !yy = fromIntegral yy' + !mm = fromIntegral mm' + !dd = fromIntegral dd' + in pack (IntAsc0 2) dd <> pack Word8be (cw8 s) <> pack (IntAsc0 2) mm <> pack Word8be (cw8 s) <> pack (IntAsc0 4) yy {-# INLINE pack #-} - unpack (DDsMMsYYYY s) - = Unpacker $ \start end _stop fail eat - -> do - let !len = F.minusPtr end start - r <- Date32.loadDDsMMsYYYY (fromIntegral $ ord s) start len + packer f v + = fromPacker (pack f v) + {-# INLINE packer #-} + + + +instance Unpackable DDsMMsYYYY where + + unpacker (DDsMMsYYYY s) start end _stop fail eat + = do + let len = I# (minusAddr# end start) + r <- Date32.loadDDsMMsYYYY (fromIntegral $ ord s) (pw8 start) len case r of - Just (d, o) -> eat (F.plusPtr start o) d - Nothing -> fail + Just (d, I# o) -> eat (plusAddr# start o) d + Nothing -> fail {-# INLINE unpack #-} @@ -99,5 +114,9 @@ cw8 :: Char -> Word8 cw8 c = fromIntegral $ ord c {-# INLINE cw8 #-} + +pw8 :: Addr# -> Ptr Word8 +pw8 addr = Ptr addr +{-# INLINE pw8 #-} diff --git a/Data/Repa/Convert/Format/Fields.hs b/Data/Repa/Convert/Format/Fields.hs --- a/Data/Repa/Convert/Format/Fields.hs +++ b/Data/Repa/Convert/Format/Fields.hs @@ -1,9 +1,12 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Repa.Convert.Format.Fields where -import Data.Repa.Convert.Format.Base +import Data.Repa.Convert.Internal.Format +import Data.Repa.Convert.Internal.Packable import Data.Repa.Scalar.Product +#include "repa-convert.h" +--------------------------------------------------------------------------------------------------- instance Format () where type Value () = () fieldCount _ = 0 @@ -17,12 +20,19 @@ instance Packable () where - pack _ = mempty - unpack _ = return () - {-# INLINE pack #-} + packer _f _v dst _fails k + = k dst + {-# INLINE packer #-} + + +instance Unpackable () where + + unpacker _f start _end _stop _fail eat + = eat start () {-# INLINE unpack #-} +--------------------------------------------------------------------------------------------------- -- | Formatting fields. instance (Format a, Format b) => Format (a :*: b) where @@ -32,22 +42,21 @@ fieldCount (fa :*: fb) = fieldCount fa + fieldCount fb + {-# NOINLINE fieldCount #-} minSize (fa :*: fb) = minSize fa + minSize fb + {-# NOINLINE minSize #-} fixedSize (fa :*: fb) = do sa <- fixedSize fa sb <- fixedSize fb return $ sa + sb + {-# NOINLINE fixedSize #-} packedSize (fa :*: fb) (xa :*: xb) = do sa <- packedSize fa xa sb <- packedSize fb xb return $ sa + sb - - {-# INLINE minSize #-} - {-# INLINE fieldCount #-} - {-# INLINE fixedSize #-} - {-# INLINE packedSize #-} + {-# NOINLINE packedSize #-} diff --git a/Data/Repa/Convert/Format/Lists.hs b/Data/Repa/Convert/Format/Lists.hs deleted file mode 100644 --- a/Data/Repa/Convert/Format/Lists.hs +++ /dev/null @@ -1,218 +0,0 @@ - -module Data.Repa.Convert.Format.Lists - ( -- * ASCII Strings - FixAsc (..) - , VarAsc (..) - , VarString (..)) -where -import Data.Repa.Convert.Format.Binary -import Data.Repa.Convert.Format.Base -import Data.Monoid -import Data.Word -import Data.Char -import qualified Foreign.Storable as S -import qualified Foreign.Ptr as S -import Prelude hiding (fail) - - ---------------------------------------------------------------------------------------------------- --- | Fixed length string. --- --- * When packing, the length of the provided string must match --- the field width, else packing will fail. --- --- * When unpacking, the length of the result will be as set --- by the field width. --- -data FixAsc = FixAsc Int deriving (Eq, Show) -instance Format FixAsc where - type Value (FixAsc) = String - fieldCount _ = 1 - minSize (FixAsc len) = len - fixedSize (FixAsc len) = Just len - packedSize (FixAsc len) _ = Just len - {-# INLINE minSize #-} - {-# INLINE fieldCount #-} - {-# INLINE fixedSize #-} - {-# INLINE packedSize #-} - - -instance Packable FixAsc where - - pack (FixAsc len) xs - | length xs == len - = Packer $ \buf k - -> do mapM_ (\(o, x) -> S.pokeByteOff buf o (w8 $ ord x)) - $ zip [0 .. len - 1] xs - k (S.plusPtr buf len) - - | otherwise - = Packer $ \_ _ -> return Nothing - {-# NOINLINE pack #-} - - unpack (FixAsc len) - = Unpacker $ \start end _stop fail eat - -> do - let lenBuf = S.minusPtr end start - if lenBuf < len - then fail - else - do let load_unpackChar o - = do x :: Word8 <- S.peekByteOff start o - return $ chr $ fromIntegral x - {-# INLINE load_unpackChar #-} - - xs <- mapM load_unpackChar [0 .. len - 1] - eat (S.plusPtr start len) xs - {-# NOINLINE unpack #-} - - ---------------------------------------------------------------------------------------------------- --- | Variable length raw string (with no quotes). -data VarAsc = VarAsc deriving (Eq, Show) -instance Format (VarAsc) where - type Value VarAsc = String - fieldCount _ = 1 - minSize _ = 0 - fixedSize VarAsc = Nothing - packedSize VarAsc xs = Just $ length xs - {-# INLINE minSize #-} - {-# INLINE fieldCount #-} - {-# INLINE fixedSize #-} - {-# INLINE packedSize #-} - - -instance Packable VarAsc where - - pack VarAsc xx - = case xx of - [] -> mempty - (x : xs) -> pack Word8be (w8 $ ord x) <> pack VarAsc xs - {-# NOINLINE pack #-} - - unpack VarAsc - = Unpacker $ \start end stop _fail eat - -> do (ptr, str) <- unpackAsc start end stop - eat ptr str - {-# INLINE unpack #-} - - --- | Unpack a ascii text from the given buffer. -unpackAsc - :: S.Ptr Word8 -- ^ First byte in buffer. - -> S.Ptr Word8 -- ^ First byte after buffer. - -> (Word8 -> Bool) -- ^ Detect field deliminator. - -> IO (S.Ptr Word8, [Char]) - -unpackAsc start end stop - = go start [] - where go !ptr !acc - | ptr >= end - = return (ptr, reverse acc) - - | otherwise - = do w :: Word8 <- S.peek ptr - if stop w - then do - return (ptr, reverse acc) - else do - let !ptr' = S.plusPtr ptr 1 - go ptr' ((chr $ fromIntegral w) : acc) -{-# INLINE unpackAsc #-} - - ---------------------------------------------------------------------------------------------------- --- | Variable length string in double quotes, --- and standard backslash encoding of special characters. -data VarString = VarString deriving (Eq, Show) -instance Format VarString where - type Value VarString = String - fieldCount _ = 1 - minSize _ = 2 - fixedSize _ = Nothing - packedSize VarString xs - = Just $ length $ show xs - {-# INLINE minSize #-} - {-# INLINE fieldCount #-} - {-# INLINE fixedSize #-} - {-# INLINE packedSize #-} - - -instance Packable VarString where - - -- ISSUE #43: Avoid intermediate lists when packing Ints and Strings. - pack VarString xx - = pack VarAsc (show xx) - {-# INLINE pack #-} - - unpack VarString - = Unpacker $ \start end _stop fail eat - -> do r <- unpackString start end - case r of - Nothing -> fail - Just (start', str) -> eat start' str - {-# INLINE unpack #-} - - --- | Unpack a string from the given buffer. -unpackString - :: S.Ptr Word8 -- ^ First byte in buffer. - -> S.Ptr Word8 -- ^ First byte after buffer. - -> IO (Maybe (S.Ptr Word8, [Char])) - -unpackString start end - = open start - where - -- Accept the open quotes. - open !ptr - | ptr >= end - = return $ Nothing - - | otherwise - = do w :: Word8 <- S.peek ptr - let !ptr' = S.plusPtr ptr 1 - case chr $ fromIntegral w of - '"' -> go_body ptr' [] - _ -> return Nothing - - -- Handle the next character in the string. - go_body !ptr !acc - | ptr >= end - = return $ Just (ptr, reverse acc) - - | otherwise - = do w :: Word8 <- S.peek ptr - let !ptr' = S.plusPtr ptr 1 - case chr $ fromIntegral w of - '"' -> return $ Just (ptr', reverse acc) - '\\' -> go_escape ptr' acc - c -> go_body ptr' (c : acc) - - -- Handle escaped character. - -- The previous character was a '\\' - go_escape !ptr !acc - | ptr >= end - = return Nothing - - | otherwise - = do w :: Word8 <- S.peek ptr - let ptr' = S.plusPtr ptr 1 - case chr $ fromIntegral w of - 'a' -> go_body ptr' ('\a' : acc) - 'b' -> go_body ptr' ('\b' : acc) - 'f' -> go_body ptr' ('\f' : acc) - 'n' -> go_body ptr' ('\n' : acc) - 'r' -> go_body ptr' ('\r' : acc) - 't' -> go_body ptr' ('\t' : acc) - 'v' -> go_body ptr' ('\v' : acc) - '\\' -> go_body ptr' ('\\' : acc) - '"' -> go_body ptr' ('"' : acc) - _ -> return Nothing -{-# NOINLINE unpackString #-} - - ---------------------------------------------------------------------------------------------------- -w8 :: Integral a => a -> Word8 -w8 = fromIntegral -{-# INLINE w8 #-} - diff --git a/Data/Repa/Convert/Format/Maybe.hs b/Data/Repa/Convert/Format/Maybe.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Convert/Format/Maybe.hs @@ -0,0 +1,206 @@ + +-- | Conversions for "Data.Maybe" wrapped formats. +module Data.Repa.Convert.Format.Maybe + ( MaybeChars (..) + , MaybeBytes (..)) +where +import Data.Repa.Convert.Internal.Format +import Data.Repa.Convert.Internal.Packable +import Data.Repa.Convert.Format.Bytes +import Data.Word +import GHC.Exts +import Prelude hiding (fail) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Internal as BS +import qualified Foreign.Storable as F +import qualified Foreign.ForeignPtr as F +import qualified Foreign.Ptr as F +#include "repa-convert.h" + + +---------------------------------------------------------------------------------------- MaybeChars +-- | Maybe a raw list of characters, or something else. +data MaybeChars f = MaybeChars String f deriving (Eq, Show) + +instance Format f => Format (MaybeChars f) where + type Value (MaybeChars f) + = Maybe (Value f) + + fieldCount _ + = 1 + {-# INLINE fieldCount #-} + + minSize (MaybeChars str f) + = minSize (MaybeBytes (BS.pack str) f) + + {-# INLINE minSize #-} + + fixedSize (MaybeChars str f) + = fixedSize (MaybeBytes (BS.pack str) f) + {-# INLINE fixedSize #-} + + packedSize (MaybeChars str f) + = kk + where !bs = BS.pack str + kk mv + = packedSize (MaybeBytes bs f) mv + {-# INLINE kk #-} + {-# INLINE packedSize #-} + + +instance Packable f + => Packable (MaybeChars f) where + + -- Convert the Nothing string to a ByteString which has a better runtime representation. + -- We do this before accepting the actual value, so the conversion happens only + -- once, instead of when we pack every value. + packer (MaybeChars str f) + = kk + where !bs = BS.pack str + kk x start k + = packer (MaybeBytes bs f) x start k + {-# INLINE kk #-} + {-# INLINE packer #-} + + +instance Unpackable f + => Unpackable (MaybeChars f) where + + -- As above, convert the Nothing string to a ByteString which has a better runtime + -- representation. + unpacker (MaybeChars str f) + = kk + where !bs = BS.pack str + kk start end stop fail eat + = unpacker (MaybeBytes bs f) start end stop fail eat + {-# INLINE kk #-} + {-# INLINE unpacker #-} + + +---------------------------------------------------------------------------------------- MaybeBytes +-- | Maybe a raw sequence of bytes, or something else. +data MaybeBytes f = MaybeBytes ByteString f deriving (Eq, Show) + +instance Format f => Format (MaybeBytes f) where + + type Value (MaybeBytes f) + = Maybe (Value f) + + fieldCount _ + = 1 + {-# INLINE fieldCount #-} + + minSize (MaybeBytes str f) + = let !(I# ms) = minSize f + in I# (minSize_MaybeBytes str ms) + {-# INLINE minSize #-} + + fixedSize (MaybeBytes str f) + = fixedSize_MaybeBytes str (fixedSize f) + {-# INLINE fixedSize #-} + + packedSize (MaybeBytes str f) mv + = case mv of + Nothing -> Just $ BS.length str + Just v -> packedSize f v + {-# NOINLINE packedSize #-} + -- NOINLINE to hide the case from the simplifier. + + +-- Minsize, hiding the case expression from the simplifier. +minSize_MaybeBytes :: ByteString -> Int# -> Int# +minSize_MaybeBytes s i + = case min (BS.length s) (I# i) of + I# i' -> i' +{-# NOINLINE minSize_MaybeBytes #-} + + +-- Fixedsize, hiding the case expression from the simplifier. +fixedSize_MaybeBytes :: ByteString -> Maybe Int -> Maybe Int +fixedSize_MaybeBytes s r + = case r of + Nothing -> Nothing + Just sf -> if BS.length s == sf + then Just sf + else Nothing +{-# NOINLINE fixedSize_MaybeBytes #-} +-- NOINLINE to hide the case from the simplifier. + + +instance Packable f + => Packable (MaybeBytes f) where + + packer (MaybeBytes str f) mv start k + = case mv of + Nothing -> packer VarBytes str start k + Just v -> packer f v start k + {-# NOINLINE pack #-} + -- We're NOINLINEing this so we don't duplicate the code for the continuation. + -- It would be better to use an Either format and use that to express the branch. + + +instance Unpackable f + => Unpackable (MaybeBytes f) where + + unpacker (MaybeBytes (BS.PS bsFptr bsStart bsLen) f) + start end stop fail eat + = F.withForeignPtr bsFptr + $ \bsPtr_ + -> let + -- Length of the input buffer. + !lenBuf = F.minusPtr (pw8 end) (pw8 start) + + -- Pointer to active bytes in Nothing string. + !bsPtr = F.plusPtr bsPtr_ bsStart + + -- Check for the Nothing string, + -- We do an early exit, bailing out on the first byte that doesn't match. + -- If this isn't the Nothing string then we need to unpack the inner format. + checkNothing !ix + + -- Matched the complete Nothing string. + | ix >= bsLen + = do -- Give the continuation the starting pointer for the next field. + let !(Ptr start') = F.plusPtr (pw8 start) ix + eatIt start' Nothing + + -- Hit the end of the buffer and the Nothing string itself is empty, + -- which we count as detecting the Nothing string. + | bsLen == 0 + , ix >= lenBuf + = do let !(Ptr start') = F.plusPtr (pw8 start) ix + eatIt start' Nothing + + -- Hit the end of the buffer before matching the Nothing string. + | ix >= lenBuf + = unpackInner + + -- Check if the next byte is the next byte in the Nothing string. + | otherwise + = do !x <- F.peekByteOff (pw8 start) ix + if stop x + then unpackInner + else do + !x' <- F.peekByteOff bsPtr ix + if x /= x' + then unpackInner + else checkNothing (ix + 1) + + unpackInner + = unpacker f start end stop fail + $ \addr x -> eatIt addr (Just x) + {-# NOINLINE unpackInner #-} + + eatIt addr val + = eat addr val + {-# NOINLINE eatIt #-} + -- NOINLINE so we don't duplicate the continuation. + + in checkNothing 0 + {-# INLINE unpacker #-} + + +pw8 :: Addr# -> Ptr Word8 +pw8 addr = Ptr addr +{-# INLINE pw8 #-} diff --git a/Data/Repa/Convert/Format/Numeric.hs b/Data/Repa/Convert/Format/Numeric.hs --- a/Data/Repa/Convert/Format/Numeric.hs +++ b/Data/Repa/Convert/Format/Numeric.hs @@ -1,17 +1,21 @@ module Data.Repa.Convert.Format.Numeric - ( IntAsc (..) - , IntAsc0 (..) - , DoubleAsc (..)) + ( IntAsc (..) + , IntAsc0 (..) + , DoubleAsc (..) + , DoubleFixedPack (..)) where -import Data.Repa.Convert.Format.Base -import Data.Repa.Convert.Format.Lists +import Data.Repa.Convert.Internal.Format +import Data.Repa.Convert.Internal.Packable +import GHC.Exts +import Data.Word import qualified Data.Repa.Scalar.Int as S import qualified Data.Repa.Scalar.Double as S import qualified Foreign.ForeignPtr as F import qualified Foreign.Marshal.Utils as F import qualified Foreign.Ptr as F import Prelude hiding (fail) +#include "repa-convert.h" ------------------------------------------------------------------------------------------- IntAsc @@ -19,40 +23,46 @@ data IntAsc = IntAsc deriving (Eq, Show) instance Format IntAsc where type Value IntAsc = Int + fieldCount _ = 1 + {-# INLINE minSize #-} + minSize _ = 1 + {-# INLINE fieldCount #-} + fixedSize _ = Nothing + {-# INLINE fixedSize #-} -- Max length of a pretty printed 64-bit Int is 20 bytes including sign. packedSize _ _ = Just 20 - {-# INLINE minSize #-} - {-# INLINE fieldCount #-} - {-# INLINE fixedSize #-} {-# INLINE packedSize #-} instance Packable IntAsc where - -- ISSUE #43: Avoid intermediate lists when packing Ints and Strings. - pack IntAsc v - = pack VarAsc (show v) - {-# INLINE pack #-} + packer IntAsc (I# v) dst _fails k + = do len <- S.storeInt# dst v + let !(Ptr dst') = F.plusPtr (Ptr dst) len + k dst' + {-# INLINE packer #-} - unpack IntAsc - = Unpacker $ \start end _stop fail eat - -> let !len = F.minusPtr end start in - if len > 0 - then do - r <- S.loadInt start len - case r of - Just (n, o) -> eat (F.plusPtr start o) n - Nothing -> fail - else fail - {-# INLINE unpack #-} +instance Unpackable IntAsc where + unpacker IntAsc start end _stop fail eat + = let !len = I# (minusAddr# end start) in + if len > 0 + then do + S.loadInt (pw8 start) len + fail + (\val (I# off) -> eat (plusAddr# start off) val) + else fail + {-# INLINE unpacker #-} + + ------------------------------------------------------------------------------------------- IntAsc --- | Human-readable ASCII integer, with leading zeros. +-- | Human-readable ASCII integer, +-- using leading zeros to pad the encoding out to a fixed length. data IntAsc0 = IntAsc0 Int deriving (Eq, Show) instance Format IntAsc0 where type Value IntAsc0 = Int @@ -70,26 +80,26 @@ instance Packable IntAsc0 where - -- ISSUE #43: Avoid intermediate lists when packing Ints and Strings. - pack (IntAsc0 n) v - = let s = show v - s' = replicate (n - length s) '0' ++ s - in pack VarAsc s' - {-# INLINE pack #-} + packer (IntAsc0 (I# pad)) (I# v) dst _fails k + = do len <- S.storeIntPad# dst v pad + let !(Ptr dst') = F.plusPtr (Ptr dst) len + k dst' + {-# INLINE packer #-} - unpack (IntAsc0 _) - = Unpacker $ \start end _stop fail eat - -> let !len = F.minusPtr end start in - if len > 0 - then do - r <- S.loadInt start len - case r of - Just (n, o) -> eat (F.plusPtr start o) n - Nothing -> fail - else fail - {-# INLINE unpack #-} +instance Unpackable IntAsc0 where + unpacker (IntAsc0 _) start end _stop fail eat + = let !len = I# (minusAddr# end start) in + if len > 0 + then do + S.loadInt (pw8 start) len + fail + (\val (I# off) -> eat (plusAddr# start off) val) + else fail + {-# INLINE unpacker #-} + + ----------------------------------------------------------------------------------------- DoubleAsc -- | Human-readable ASCII Double. data DoubleAsc = DoubleAsc deriving (Eq, Show) @@ -99,7 +109,7 @@ minSize _ = 1 fixedSize _ = Nothing - -- Max length of a pretty-printed 64-bit double is 64 bytes. + -- Max length of a pretty-printed 64-bit double is 24 bytes. packedSize _ _ = Just 24 {-# INLINE minSize #-} {-# INLINE fieldCount #-} @@ -109,22 +119,73 @@ instance Packable DoubleAsc where - pack DoubleAsc v - = Packer $ \buf k - -> do (fptr, len) <- S.storeDoubleShortest v + packer DoubleAsc v dst _fails k + = do (fptr, len) <- S.storeDoubleShortest v F.withForeignPtr fptr $ \ptr - -> F.copyBytes buf ptr len - k (F.plusPtr buf len) - {-# INLINE pack #-} + -> F.copyBytes (Ptr dst) ptr len + let !(Ptr dst') = F.plusPtr (Ptr dst) len + k dst' + {-# INLINE packer #-} - unpack DoubleAsc - = Unpacker $ \start end _stop fail eat - -> let !len = F.minusPtr end start in - if len > 0 + +instance Unpackable DoubleAsc where + + unpacker DoubleAsc start end _stop fail eat + = let !len = I# (minusAddr# end start) in + if len > 0 then do - (v, o) <- S.loadDouble start len - eat (F.plusPtr start o) v + (v, I# o) <- S.loadDouble (pw8 start) len + eat (plusAddr# start o) v else fail - {-# INLINE unpack #-} + {-# INLINE unpacker #-} + +-------------------------------------------------------------------------------- DoubleFixedPack +-- | Human-readable ASCII Double. +-- +-- When packing we use a fixed number of zeros after the decimal +-- point, though when unpacking we allow a greater precision. +-- +data DoubleFixedPack = DoubleFixedPack Int deriving (Eq, Show) +instance Format DoubleFixedPack where + type Value DoubleFixedPack = Double + fieldCount _ = 1 + minSize _ = 1 + fixedSize _ = Nothing + + -- Max length of a pretty-printed 64-bit double is 24 bytes. + packedSize (DoubleFixedPack prec) _ + = Just (24 + prec) + {-# INLINE minSize #-} + {-# INLINE fieldCount #-} + {-# INLINE fixedSize #-} + {-# INLINE packedSize #-} + + +instance Packable DoubleFixedPack where + + packer (DoubleFixedPack prec) v dst _fails k + = do (fptr, len) <- S.storeDoubleFixed prec v + F.withForeignPtr fptr $ \ptr + -> F.copyBytes (Ptr dst) ptr len + let !(Ptr dst') = F.plusPtr (Ptr dst) len + k dst' + {-# INLINE packer #-} + + +instance Unpackable DoubleFixedPack where + + unpacker (DoubleFixedPack _) start end _stop fail eat + = let !len = I# (minusAddr# end start) in + if len > 0 + then do + (v, I# o) <- S.loadDouble (pw8 start) len + eat (plusAddr# start o) v + else fail + {-# INLINE unpacker #-} + + +pw8 :: Addr# -> Ptr Word8 +pw8 addr = Ptr addr +{-# INLINE pw8 #-} diff --git a/Data/Repa/Convert/Format/Object.hs b/Data/Repa/Convert/Format/Object.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Convert/Format/Object.hs @@ -0,0 +1,295 @@ +{-# LANGUAGE UndecidableInstances #-} +module Data.Repa.Convert.Format.Object + ( Object (..) + , ObjectFormat + , ObjectFields + , Field (..) + , mkObject) +where +import Data.Repa.Convert.Internal.Format +import Data.Repa.Convert.Internal.Packable +import Data.Repa.Convert.Internal.Packer +import Data.Repa.Convert.Format.String +import Data.Repa.Convert.Format.Binary +import Data.Repa.Scalar.Product +import Data.Monoid +import Data.Word +import Data.Char +import GHC.Exts +import Data.Text (Text) +import qualified Data.Text as T + + +-- | Format of a simple object format with labeled fields. +data Object fields where + Object + :: ObjectFields fields + -> Object fields + + +-- | Resents the fields of a JSON object. +data ObjectFields fields where + + ObjectFieldsNil + :: ObjectFields () + + ObjectFieldsCons + :: {-# UNPACK #-} !ObjectMeta -- Meta data about this format. + -> !Text -- Name of head field + -> !f -- Format of head field. + -> Maybe (Value f -> Bool) -- Predicate to determine whether to emit value. + -> ObjectFields fs -- Spec for rest of fields. + -> ObjectFields (f :*: fs) + + +-- | Precomputed information about this format. +data ObjectMeta + = ObjectMeta + { -- | Length of this format, in fields. + omFieldCount :: !Int + + -- | Minimum length of this format, in bytes. + , omMinSize :: !Int + + -- | Fixed size of this format. + , omFixedSize :: !(Maybe Int) } + + +--------------------------------------------------------------------------------------------------- +-- | Make an object format with the given labeled fields. For example: +-- +-- @> let fmt = mkObject +-- $ Field "index" IntAsc Nothing +-- :*: Field "message" (VarCharString \'-\') Nothing +-- :*: Field "value" (MaybeChars "NULL" DoubleAsc) (Just isJust) +-- :*: () +-- @ +-- +-- Packing this produces: +-- +-- @ +-- > let Just str = packToString fmt (27 :*: "foo" :*: Nothing :*: ()) +-- > putStrLn str +-- > {"index":27,"message":"foo"} +-- @ +-- +-- Note that the encodings that this format can generate are a superset of +-- the JavaScript Object Notation (JSON). With the Repa format, the fields +-- of an object can directly encode dates and other values, wheras in JSON +-- these values must be represented by strings. +-- +mkObject :: ObjectFormat f + => f -> Object (ObjectFormat' f) + +mkObject f = Object (mkObjectFields f) + + +class ObjectFormat f where + type ObjectFormat' f + mkObjectFields :: f -> ObjectFields (ObjectFormat' f) + + +instance ObjectFormat () where + type ObjectFormat' () = () + mkObjectFields () = ObjectFieldsNil + {-# INLINE mkObjectFields #-} + + +-- | A single field in an object. +data Field f + = Field + { fieldName :: String + , fieldFormat :: f + , fieldInclude :: Maybe (Value f -> Bool) } + + +instance ( Format f1 + , ObjectFormat fs) + => ObjectFormat (Field f1 :*: fs) where + + type ObjectFormat' (Field f1 :*: fs) + = f1 :*: ObjectFormat' fs + + mkObjectFields (Field label f1 mKeep :*: fs) + = case mkObjectFields fs of + ObjectFieldsNil + -> ObjectFieldsCons + (ObjectMeta + { omFieldCount = 1 + + -- Smallest JSON object looks like: + -- {"LABEL":VALUE}, so there are 5 extra characters. + , omMinSize = 5 + length label + minSize f1 + + , omFixedSize = fmap (+ (5 + length label)) $ fixedSize f1 }) + (T.pack label) f1 mKeep ObjectFieldsNil + + cc@(ObjectFieldsCons jm _ _ _ _) + -> ObjectFieldsCons + (ObjectMeta + { omFieldCount = 1 + omFieldCount jm + + -- Adding a new field makes the object look like: + -- {"LABEL1":VALUE1,"LABEL2":VALUE2}, so there are 4 extra + -- characters for addiitonal field, 1x',' + 2x'"' + 1x':' + , omMinSize = 4 + minSize f1 + omMinSize jm + + , omFixedSize + = do s1 <- fixedSize f1 + ss <- omFixedSize jm + return $ s1 + 4 + ss }) + (T.pack label) f1 mKeep cc + {-# INLINE mkObjectFields #-} + + +--------------------------------------------------------------------------------------------------- +instance ( Format (ObjectFields fs) + , Value (ObjectFields fs) ~ Value fs) + => Format (Object fs) where + type Value (Object fs) + = Value fs + + fieldCount (Object _) + = 1 + {-# INLINE fieldCount #-} + + minSize (Object fs) + = 2 + minSize fs + {-# INLINE minSize #-} + + fixedSize (Object fs) + = do sz <- fixedSize fs + return (2 + sz) + {-# INLINE fixedSize #-} + + packedSize (Object fs) xs + = do ps <- packedSize fs xs + return $ 2 + ps + {-# INLINE packedSize #-} + + +--------------------------------------------------------------------------------------------------- +instance Format (ObjectFields ()) where + type Value (ObjectFields ()) = () + fieldCount ObjectFieldsNil = 0 + minSize ObjectFieldsNil = 0 + fixedSize ObjectFieldsNil = return 0 + packedSize ObjectFieldsNil _ = return 0 + {-# INLINE fieldCount #-} + {-# INLINE minSize #-} + {-# INLINE fixedSize #-} + {-# INLINE packedSize #-} + + +instance Packable (ObjectFields ()) where + packer _fmt _val dst _fails k + = k dst + {-# INLINE packer #-} + + +instance Unpackable (ObjectFields ()) where + unpacker _fmt start _end _stop _fail eat + = eat start () + {-# INLINE unpacker #-} + + +instance ( Format f1, Format (ObjectFields fs) + , Value (ObjectFields fs) ~ Value fs) + => Format (ObjectFields (f1 :*: fs)) where + + type Value (ObjectFields (f1 :*: fs)) + = Value f1 :*: Value fs + + fieldCount (ObjectFieldsCons jm _l1 _f1 _keep _jfs) + = omFieldCount jm + {-# INLINE fieldCount #-} + + minSize (ObjectFieldsCons jm _l1 _f1 _keep _jfs) + = omMinSize jm + {-# INLINE minSize #-} + + fixedSize (ObjectFieldsCons jm _l1 _f1 _keep _jfs) + = omFixedSize jm + {-# INLINE fixedSize #-} + + packedSize (ObjectFieldsCons _jm l1 f1 _keep jfs) (x1 :*: xs) + = do sl <- packedSize VarCharString (T.unpack l1) + s1 <- packedSize f1 x1 + ss <- packedSize jfs xs + let sSep = zeroOrOne (fieldCount jfs) + return $ sl + 1 + s1 + sSep + ss + {-# INLINE packedSize #-} + + +--------------------------------------------------------------------------------------------------- +instance ( Format (Object f) + , Value (ObjectFields f) ~ Value f + , Packable (ObjectFields f)) + => Packable (Object f) where + + pack (Object fs) xs + = pack Word8be (w8 $ ord '{') + <> pack fs xs + <> pack Word8be (w8 $ ord '}') + {-# INLINE pack #-} + + packer f v + = fromPacker $ pack f v + {-# INLINE packer #-} + + +--------------------------------------------------------------------------------------------------- +instance ( Packable f1 + , Value (ObjectFields ()) ~ Value ()) + => Packable (ObjectFields (f1 :*: ())) where + + pack (ObjectFieldsCons _jm l1 f1 _keep _jfs) (x1 :*: _) + = pack VarCharString (T.unpack l1) + <> pack Word8be (w8 $ ord ':') + <> pack f1 x1 + {-# INLINE pack #-} + + packer f v + = fromPacker $ pack f v + {-# INLINE packer #-} + + +instance ( Packable f1 + , Packable (ObjectFields (f2 :*: fs)) + , Value (ObjectFields (f2 :*: fs)) ~ Value (f2 :*: fs) + , Value (ObjectFields fs) ~ Value fs) + => Packable (ObjectFields (f1 :*: f2 :*: fs)) where + + -- Pack a field into the object, + -- only keeping it if the keep flag is true. + pack (ObjectFieldsCons _jm l1 f1 mKeep jfs) (x1 :*: xs) + = if (case mKeep of + Just keep -> keep x1 + _ -> True) + then here + else rest + where + here = pack VarCharString (T.unpack l1) + <> pack Word8be (w8 $ ord ':') + <> pack f1 x1 + <> pack Word8be (w8 $ ord ',') + <> rest + + rest = pack jfs xs + {-# INLINE pack #-} + + packer f v + = fromPacker $ pack f v + {-# INLINE packer #-} + + +--------------------------------------------------------------------------------------------------- +w8 :: Integral a => a -> Word8 +w8 = fromIntegral +{-# INLINE w8 #-} + + +-- | Branchless equality used to avoid compile-time explosion in size of core code. +zeroOrOne :: Int -> Int +zeroOrOne (I# i) = I# (1# -# (0# ==# i)) +{-# INLINE zeroOrOne #-} diff --git a/Data/Repa/Convert/Format/Sep.hs b/Data/Repa/Convert/Format/Sep.hs --- a/Data/Repa/Convert/Format/Sep.hs +++ b/Data/Repa/Convert/Format/Sep.hs @@ -1,36 +1,100 @@ module Data.Repa.Convert.Format.Sep - (Sep (..)) + ( Sep (..) + , SepFormat (..) + , SepMeta (..)) where +import Data.Repa.Convert.Internal.Format +import Data.Repa.Convert.Internal.Packable +import Data.Repa.Convert.Internal.Packer import Data.Repa.Convert.Format.Binary -import Data.Repa.Convert.Format.Base import Data.Repa.Scalar.Product import Data.Monoid import Data.Word import Data.Char -import qualified Foreign.Storable as F -import qualified Foreign.Ptr as F +import GHC.Exts import Prelude hiding (fail) +#include "repa-convert.h" -- | Separate fields with the given character. --- +-- -- * The separating character is un-escapable. -- * The format @(Sep ',')@ does NOT parse a CSV -- file according to the CSV specification: http://tools.ietf.org/html/rfc4180. -- -data Sep f - = Sep Char f - deriving Show +-- * The type is kept abstract as we cache some pre-computed values +-- we use to unpack this format. Use `mkSep` to make one. +-- +data Sep f where + SepNil :: Sep () + SepCons :: {-# UNPACK #-} !SepMeta -- Meta data about this format. + -> !f -- Format of head field. + -> Sep fs -- Spec for rest of fields. + -> Sep (f :*: fs) + +-- | Precomputed information about this format. +data SepMeta + = SepMeta + { -- | Length of this format, in fields. + smFieldCount :: !Int + + -- | Minimum length of this format, in bytes. + , smMinSize :: !Int + + -- | Fixed size of this format. + , smFixedSize :: !(Maybe Int) + + -- | Separating charater for this format. + , smSepChar :: !Char } + + --------------------------------------------------------------------------------------------------- +class SepFormat f where + mkSep :: Char -> f -> Sep f + +instance SepFormat () where + mkSep _ () = SepNil + {-# INLINE mkSep #-} + + +instance (Format f1, SepFormat fs) + => SepFormat (f1 :*: fs) where + + mkSep c (f1 :*: fs) + = case mkSep c fs of + SepNil + -> SepCons + (SepMeta { smFieldCount = 1 + , smMinSize = minSize f1 + , smFixedSize = fixedSize f1 + , smSepChar = c }) + f1 SepNil + + sep@(SepCons sm _ _) + -> SepCons + (SepMeta { smFieldCount = 1 + smFieldCount sm + , smMinSize = minSize f1 + 1 + smMinSize sm + + , smFixedSize + = do s1 <- fixedSize f1 + ss <- smFixedSize sm + return $ s1 + 1 + ss + + , smSepChar = c }) + f1 sep + {-# INLINE mkSep #-} + + +--------------------------------------------------------------------------------------------------- instance Format (Sep ()) where - type Value (Sep ()) = () - fieldCount (Sep _ _) = 0 - minSize (Sep _ _) = 0 - fixedSize (Sep _ _) = return 0 - packedSize (Sep _ _) () = return 0 + type Value (Sep ()) = () + fieldCount SepNil = 0 + minSize SepNil = 0 + fixedSize SepNil = return 0 + packedSize SepNil _ = return 0 {-# INLINE minSize #-} {-# INLINE fieldCount #-} {-# INLINE fixedSize #-} @@ -38,12 +102,17 @@ instance Packable (Sep ()) where - pack _fmt _val = mempty - unpack _fmt = return () - {-# INLINE pack #-} - {-# INLINE unpack #-} + packer _fmt _val dst _fails k + = k dst + {-# INLINE packer #-} +instance Unpackable (Sep ()) where + unpacker _fmt start _end _stop _fail eat + = eat start () + {-# INLINE unpacker #-} + + --------------------------------------------------------------------------------------------------- instance ( Format f1, Format (Sep fs) , Value (Sep fs) ~ Value fs) @@ -52,74 +121,98 @@ type Value (Sep (f1 :*: fs)) = Value f1 :*: Value fs - fieldCount (Sep c (_ :*: fs)) - = 1 + fieldCount (Sep c fs) + fieldCount (SepCons sm _f1 _sfs) + = smFieldCount sm + {-# INLINE fieldCount #-} - minSize (Sep c (f1 :*: fs)) - = let !n = fieldCount (Sep c fs) - in minSize f1 - + (if n == 0 then 0 else 1) - + minSize (Sep c fs) + minSize (SepCons sm _f1 _sfs) + = smMinSize sm + {-# INLINE minSize #-} - fixedSize (Sep c (f1 :*: fs)) - = do s1 <- fixedSize f1 - ss <- fixedSize (Sep c fs) - let sSep = if fieldCount (Sep c fs) == 0 then 0 else 1 - return $ s1 + sSep + ss + fixedSize (SepCons sm _f1 _sfs) + = smFixedSize sm + {-# INLINE fixedSize #-} - packedSize (Sep c (f1 :*: fs)) (x1 :*: xs) - = do s1 <- packedSize f1 x1 - ss <- packedSize (Sep c fs) xs - let sSep = if fieldCount (Sep c fs) == 0 then 0 else 1 + packedSize (SepCons _sm f1 sfs) (x1 :*: xs) + = do s1 <- packedSize f1 x1 + ss <- packedSize sfs xs + let sSep = zeroOrOne (fieldCount sfs) return $ s1 + sSep + ss - {-# INLINE minSize #-} - {-# INLINE fieldCount #-} - {-# INLINE fixedSize #-} {-# INLINE packedSize #-} -instance ( Packable f1, Packable (Sep fs) - , Value (Sep fs) ~ Value fs) - => Packable (Sep (f1 :*: fs)) where +--------------------------------------------------------------------------------------------------- +instance ( Packable f1 + , Value (Sep ()) ~ Value ()) + => Packable (Sep (f1 :*: ())) where - pack (Sep c (f1 :*: fs)) (x1 :*: xs) - | fieldCount (Sep c fs) >= 1 - = pack f1 x1 <> pack Word8be (w8 $ ord c) <> pack (Sep c fs) xs + packer (SepCons _ f1 _ ) (x1 :*: _) start k + = packer f1 x1 start k + {-# INLINE pack #-} - | otherwise - = pack f1 x1 + +instance ( Unpackable f1 + , Value (Sep ()) ~ Value ()) + => Unpackable (Sep (f1 :*: ())) where + + unpacker (SepCons sm f1 sfs) start end stop fail eat + = do let stop' x = w8 (ord (smSepChar sm)) == x || stop x + {-# INLINE stop' #-} + + unpacker f1 start end stop' fail $ \start_x1 x1 + -> unpacker sfs start_x1 end stop fail $ \start_xs xs + -> eat start_xs (x1 :*: xs) + {-# INLINE unpacker #-} + + +--------------------------------------------------------------------------------------------------- +instance ( Packable f1 + , Packable (Sep (f2 :*: fs)) + , Value (Sep (f2 :*: fs)) ~ Value (f2 :*: fs) + , Value (Sep fs) ~ Value fs) + => Packable (Sep (f1 :*: f2 :*: fs)) where + + pack (SepCons sm f1 sfs) (x1 :*: xs) + = pack f1 x1 + <> pack Word8be (w8 $ ord $ smSepChar sm) + <> pack sfs xs {-# INLINE pack #-} + packer f v + = fromPacker $ pack f v + {-# INLINE packer #-} - unpack (Sep c (f1 :*: fs)) - | fieldCount (Sep c fs) >= 1 - = Unpacker $ \start end stop fail eat - -> let !len = F.minusPtr end start - !s1 = minSize f1 - !ss = minSize (Sep c fs) - stop' x = w8 (ord c) == x || stop x - {-# INLINE stop' #-} +instance ( Unpackable f1 + , Unpackable (Sep (f2 :*: fs)) + , Value (Sep (f2 :*: fs)) ~ Value (f2 :*: fs) + , Value (Sep fs) ~ Value fs) + => Unpackable (Sep (f1 :*: f2 :*: fs)) where - in if (s1 + 1 + ss <= len) - then (fromUnpacker $ unpack f1) start end stop' fail $ \start_x1 x1 - -> let start_x1' = F.plusPtr start_x1 1 - in (fromUnpacker $ unpack (Sep c fs)) start_x1' end stop' fail $ \start_xs xs - -> eat start_xs (x1 :*: xs) - else fail + unpacker (SepCons sm f1 sfs) start end stop fail eat + = do -- Length of data remaining in the input buffer. + let len = I# (minusAddr# end start) - | otherwise - = Unpacker $ \start end stop fail eat - -> let stop' x = w8 (ord c) == x || stop x - {-# INLINE stop' #-} - in (fromUnpacker $ unpack f1) start end stop' fail $ \start_x x - -> (fromUnpacker $ unpack (Sep c fs)) start_x end stop' fail $ \start_xs xs - -> eat start_xs (x :*: xs) - {-# INLINE unpack #-} + let stop' x = w8 (ord (smSepChar sm)) == x || stop x + {-# INLINE stop' #-} + if not (smMinSize sm <= len) + then fail + else do + unpacker f1 start end stop' fail $ \start_x1 x1 + -> unpacker sfs (plusAddr# start_x1 1#) end stop fail $ \start_xs xs + -> eat start_xs (x1 :*: xs) + {-# INLINE unpacker #-} + --------------------------------------------------------------------------------------------------- w8 :: Integral a => a -> Word8 w8 = fromIntegral {-# INLINE w8 #-} + + +-- | Branchless equality used to avoid compile-time explosion in size of core code. +zeroOrOne :: Int -> Int +zeroOrOne (I# i) = I# (1# -# (0# ==# i)) +{-# INLINE zeroOrOne #-} diff --git a/Data/Repa/Convert/Format/String.hs b/Data/Repa/Convert/Format/String.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Convert/Format/String.hs @@ -0,0 +1,304 @@ + +module Data.Repa.Convert.Format.String + ( -- * Haskell Strings + FixChars (..) + , VarChars (..) + , VarCharString (..) + , ExactChars (..) + , unpackCharList) +where +import Data.Repa.Convert.Internal.Format +import Data.Repa.Convert.Internal.Packable +import Data.Repa.Convert.Internal.Packer +import Data.Repa.Convert.Format.Binary +import Data.Monoid +import Data.Word +import Data.Char +import GHC.Exts +import qualified Foreign.Storable as S +import qualified Foreign.Ptr as S +import Prelude hiding (fail) +#include "repa-convert.h" + + +--------------------------------------------------------------------------------------------------- +-- | Fixed length sequence of characters, represented as a (hated) Haskell `String`. +-- +-- * The runtime performance of the Haskell `String` is atrocious. +-- You really shouldn't be using them for large data sets. +-- +-- * When packing, the length of the provided string must match the width +-- of the format, else packing will fail. +-- +-- * When unpacking, the length of the result will be the width of the format. +-- +data FixChars = FixChars Int deriving (Eq, Show) +instance Format FixChars where + type Value (FixChars) = String + fieldCount _ = 1 + minSize (FixChars len) = len + fixedSize (FixChars len) = Just len + packedSize (FixChars len) _ = Just len + {-# INLINE minSize #-} + {-# INLINE fieldCount #-} + {-# INLINE fixedSize #-} + {-# INLINE packedSize #-} + + +instance Packable FixChars where + + pack (FixChars len) xs + | length xs == len + = Packer $ \dst _fails eat + -> do mapM_ (\(o, x) -> S.pokeByteOff (Ptr dst) o (w8 $ ord x)) + $ zip [0 .. len - 1] xs + let !(Ptr dst') = S.plusPtr (Ptr dst) len + eat dst' + + | otherwise + = Packer $ \_ fails _ -> fails + {-# NOINLINE pack #-} + + packer f v + = fromPacker (pack f v) + {-# INLINE packer #-} + + +instance Unpackable FixChars where + unpacker (FixChars len@(I# len')) start end _stop fail eat + = do + let lenBuf = I# (minusAddr# end start) + if lenBuf < len + then fail + else + do let load_unpackChar o + = do x :: Word8 <- S.peekByteOff (pw8 start) o + return $ chr $ fromIntegral x + {-# INLINE load_unpackChar #-} + + xs <- mapM load_unpackChar [0 .. len - 1] + eat (plusAddr# start len') xs + {-# INLINE unpacker #-} + + +--------------------------------------------------------------------------------------------------- +-- | Like `FixChars`, but with a variable length. +data VarChars = VarChars deriving (Eq, Show) +instance Format VarChars where + type Value VarChars = String + + fieldCount _ = 1 + {-# INLINE fieldCount #-} + + minSize _ = 0 + {-# INLINE minSize #-} + + fixedSize VarChars = Nothing + {-# INLINE fixedSize #-} + + packedSize VarChars xs = Just $ length xs + {-# NOINLINE packedSize #-} + + +instance Packable VarChars where + + pack VarChars xx + = case xx of + [] -> mempty + (x : xs) -> pack Word8be (w8 $ ord x) <> pack VarChars xs + {-# NOINLINE pack #-} + + packer f v + = fromPacker (pack f v) + {-# INLINE packer #-} + + +instance Unpackable VarChars where + unpacker VarChars start end stop _fail eat + = do (Ptr ptr, str) <- unpackCharList (pw8 start) (pw8 end) stop + eat ptr str + {-# INLINE unpack #-} + + +-- | Unpack a ascii text from the given buffer. +unpackCharList + :: S.Ptr Word8 -- ^ First byte in buffer. + -> S.Ptr Word8 -- ^ First byte after buffer. + -> (Word8 -> Bool) -- ^ Detect field deliminator. + -> IO (S.Ptr Word8, [Char]) + +unpackCharList start end stop + = go start [] + where go !ptr !acc + | ptr >= end + = return (ptr, reverse acc) + + | otherwise + = do w :: Word8 <- S.peek ptr + if stop w + then do + return (ptr, reverse acc) + else do + let !ptr' = S.plusPtr ptr 1 + go ptr' ((chr $ fromIntegral w) : acc) +{-# NOINLINE unpackCharList #-} + + +--------------------------------------------------------------------------------------------------- +-- | Variable length string in double quotes, +-- and standard backslash encoding of non-printable characters. +data VarCharString = VarCharString deriving (Eq, Show) +instance Format VarCharString where + type Value VarCharString = String + fieldCount _ = 1 + {-# INLINE fieldCount #-} + + minSize _ = 2 + {-# INLINE minSize #-} + + fixedSize _ = Nothing + {-# INLINE fixedSize #-} + + packedSize VarCharString xs + = Just $ length $ show xs + {-# NOINLINE packedSize #-} + + +instance Packable VarCharString where + + -- ISSUE #43: Avoid intermediate lists when packing Ints and Strings. + packer VarCharString xx start k + = packer VarChars (show xx) start k + {-# INLINE pack #-} + + +instance Unpackable VarCharString where + unpacker VarCharString start end _stop fail eat + = unpackString (pw8 start) (pw8 end) fail eat + {-# INLINE unpacker #-} + + +-- | Unpack a string from the given buffer. +--- +-- We only handle the most common special character encodings. +-- Is there a standard for which ones these are? +-- +unpackString + :: S.Ptr Word8 -- ^ First byte in buffer. + -> S.Ptr Word8 -- ^ First byte after buffer. + -> IO () -- ^ Signal failure. + -> (Addr# -> [Char] -> IO ()) -- ^ Eat an unpacked value. + -> IO () + +unpackString start end fail eat + = open start + where + -- Accept the open quotes. + open !ptr + | ptr >= end + = fail + + | otherwise + = do w :: Word8 <- S.peek ptr + let !ptr' = S.plusPtr ptr 1 + case chr $ fromIntegral w of + '"' -> go_body ptr' [] + _ -> fail + + -- Handle the next character in the string. + go_body !ptr@(Ptr addr) !acc + | ptr >= end + = eat addr (reverse acc) + + | otherwise + = do w :: Word8 <- S.peek ptr + let !ptr'@(Ptr addr') = S.plusPtr ptr 1 + case chr $ fromIntegral w of + '"' -> eat addr' (reverse acc) + '\\' -> go_escape ptr' acc + c -> go_body ptr' (c : acc) + + -- Handle escaped character. + -- The previous character was a '\\' + go_escape !ptr !acc + | ptr >= end + = fail + + | otherwise + = do w :: Word8 <- S.peek ptr + let ptr' = S.plusPtr ptr 1 + case chr $ fromIntegral w of + 'a' -> go_body ptr' ('\a' : acc) + 'b' -> go_body ptr' ('\b' : acc) + 'f' -> go_body ptr' ('\f' : acc) + 'n' -> go_body ptr' ('\n' : acc) + 'r' -> go_body ptr' ('\r' : acc) + 't' -> go_body ptr' ('\t' : acc) + 'v' -> go_body ptr' ('\v' : acc) + '\\' -> go_body ptr' ('\\' : acc) + '"' -> go_body ptr' ('"' : acc) + _ -> fail +{-# NOINLINE unpackString #-} + + +--------------------------------------------------------------------------------------------------- +-- | Match an exact sequence of characters. +data ExactChars + = ExactChars String + deriving Show + + +instance Format ExactChars where + type Value ExactChars = () + fieldCount (ExactChars _) = 0 + {-# INLINE fieldCount #-} + + minSize (ExactChars str) = length str + {-# NOINLINE minSize #-} + + fixedSize (ExactChars str) = return (length str) + {-# NOINLINE fixedSize #-} + + packedSize (ExactChars str) () = return (length str) + {-# NOINLINE packedSize #-} + + +instance Packable ExactChars where + packer (ExactChars str) _ dst _fails k + = do let !len = length str + mapM_ (\(o, x) -> S.pokeByteOff (Ptr dst) o (w8 $ ord x)) + $ zip [0 .. len - 1] str + let !(Ptr dst') = S.plusPtr (Ptr dst) len + k dst' + {-# NOINLINE pack #-} + + +instance Unpackable ExactChars where + unpacker (ExactChars str) start end _stop fails eat + = do let !len@(I# len') = length str + let !lenBuf = I# (minusAddr# end start) + if lenBuf < len + then fails + else do + let load_unpackChar o + = do x :: Word8 <- S.peekByteOff (pw8 start) o + return $ chr $ fromIntegral x + {-# INLINE load_unpackChar #-} + + xs <- mapM load_unpackChar [0 .. len - 1] + if (xs == str) + then eat (plusAddr# start len') () + else fails + {-# NOINLINE unpack #-} + + +--------------------------------------------------------------------------------------------------- +w8 :: Integral a => a -> Word8 +w8 = fromIntegral +{-# INLINE w8 #-} + + +pw8 :: Addr# -> Ptr Word8 +pw8 addr = Ptr addr +{-# INLINE pw8 #-} + diff --git a/Data/Repa/Convert/Format/Text.hs b/Data/Repa/Convert/Format/Text.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Convert/Format/Text.hs @@ -0,0 +1,120 @@ + +-- | Conversions for "Data.Text" things. +module Data.Repa.Convert.Format.Text + ( VarText (..) + , VarTextString (..)) +where +import Data.Repa.Convert.Internal.Format +import Data.Repa.Convert.Internal.Packable +import Data.Repa.Convert.Format.String +import Data.Text (Text) +import Data.Word +import GHC.Exts +import qualified Data.Text.Foreign as T +import qualified Data.Text as T +import qualified Foreign.Storable as F +import qualified Foreign.Ptr as F + + +--------------------------------------------------------------------------------------------------- +-- | Variable length unicode text, represented as a "Data.Text" thing. +-- +data VarText = VarText deriving (Eq, Show) +instance Format VarText where + type Value VarText = Text + fieldCount _ = 1 + minSize _ = 0 + fixedSize VarText = Nothing + packedSize VarText xs = Just $ T.length xs + {-# INLINE fieldCount #-} + {-# INLINE minSize #-} + {-# INLINE fixedSize #-} + {-# INLINE packedSize #-} + + +instance Packable VarText where + + packer VarText tt dst _fails eat + = T.withCStringLen tt + $ \(ptr, len) + -> let + packer_VarText !ix + | ix >= len + = let !(Ptr dst') = F.plusPtr (Ptr dst) ix + in eat dst' + + | otherwise + = do !(x :: Word8) <- F.peekByteOff ptr ix + F.pokeByteOff (Ptr dst) ix x + packer_VarText (ix + 1) + {-# INLINE packer_VarText #-} + + in packer_VarText 0 + {-# INLINE packer #-} + + +instance Unpackable VarText where + unpacker VarText start end stop _fail eat + = scanLen 0 + where + -- Length of the input buffer. + !lenBuf = F.minusPtr (pw8 end) (pw8 start) + + -- Scan through the input to see how long the field is. + scanLen !ix + | ix >= lenBuf + = copyField lenBuf + + | otherwise + = do x <- F.peekByteOff (pw8 start) ix + if stop x + then copyField ix + else scanLen (ix + 1) + {-# INLINE scanLen #-} + + -- Decode the UTF-8 bytes into a new buffer. + copyField !lenField + = do tt <- T.peekCStringLen (Ptr start, lenField) + let !(Ptr start') = F.plusPtr (Ptr start) lenField + eat start' tt + {-# INLINE copyField #-} + {-# INLINE unpacker #-} + + +--------------------------------------------------------------------------------------------------- +-- | Variable length string in double quotes, +-- and standard backslash encoding of non-printable characters. +data VarTextString = VarTextString deriving (Eq, Show) +instance Format VarTextString where + type Value VarTextString = Text + fieldCount _ = 1 + minSize _ = 2 + fixedSize VarTextString = Nothing + packedSize VarTextString xs = Just $ T.length xs + {-# INLINE fieldCount #-} + {-# INLINE minSize #-} + {-# INLINE fixedSize #-} + {-# INLINE packedSize #-} + + +instance Packable VarTextString where + + -- We go via lists here to get 'show's' expansion of special characters. + packer VarTextString tt buf k + = packer VarText (T.pack $ show $ T.unpack tt) buf k + {-# INLINE packer #-} + + +instance Unpackable VarTextString where + + unpacker VarTextString start end stop _fail eat + = unpacker VarCharString start end stop _fail + $ \start' val -> eat start' (T.pack val) + {-# INLINE unpacker #-} + + +--------------------------------------------------------------------------------------------------- +pw8 :: Addr# -> Ptr Word8 +pw8 addr = Ptr addr +{-# INLINE pw8 #-} + diff --git a/Data/Repa/Convert/Format/Tup.hs b/Data/Repa/Convert/Format/Tup.hs deleted file mode 100644 --- a/Data/Repa/Convert/Format/Tup.hs +++ /dev/null @@ -1,97 +0,0 @@ - -module Data.Repa.Convert.Format.Tup - (Tup (..)) -where -import Data.Repa.Convert.Format.Sep -import Data.Repa.Convert.Format.Binary -import Data.Repa.Convert.Format.Base -import Data.Repa.Scalar.Product -import Data.Monoid -import Data.Word -import Data.Char - - --- | Display fields as a tuple, like @(x,y,z)@. -data Tup f - = Tup f - deriving Show - - ---------------------------------------------------------------------------------------------------- -instance Format (Tup ()) where - type Value (Tup ()) = () - fieldCount (Tup _) = 0 - minSize (Tup _) = 0 - fixedSize (Tup _) = return 0 - packedSize (Tup _) () = return 0 - {-# INLINE minSize #-} - {-# INLINE fieldCount #-} - {-# INLINE fixedSize #-} - {-# INLINE packedSize #-} - - -instance Packable (Tup ()) where - pack _fmt _val = mempty - unpack _fmt = return () - {-# INLINE pack #-} - {-# INLINE unpack #-} - - ---------------------------------------------------------------------------------------------------- -instance ( Format f1 - , Format (Tup fs) - , Format (Sep fs) - , Value (Sep fs) ~ Value fs) - => Format (Tup (f1 :*: fs)) where - - type Value (Tup (f1 :*: fs)) - = Value f1 :*: Value fs - - fieldCount (Tup (_ :*: fs)) - = 1 + fieldCount (Tup fs) - - minSize (Tup (f1 :*: fs)) - = let !n = fieldCount (Tup fs) - in 2 + minSize f1 - + (if n == 0 then 0 else 1) - + minSize (Sep ',' fs) - - fixedSize (Tup (f1 :*: fs)) - = do s1 <- fixedSize f1 - ss <- fixedSize (Sep ',' fs) - let sSep = if fieldCount (Sep ',' fs) == 0 then 0 else 1 - return $ 2 + s1 + sSep + ss - - packedSize (Tup (f1 :*: fs)) (x1 :*: xs) - = do s1 <- packedSize f1 x1 - ss <- packedSize (Sep ',' fs) xs - let sSep = if fieldCount (Sep ',' fs) == 0 then 0 else 1 - return $ 2 + s1 + sSep + ss - {-# INLINE minSize #-} - {-# INLINE fieldCount #-} - {-# INLINE fixedSize #-} - {-# INLINE packedSize #-} - - -instance ( Packable f1 - , Packable (Sep fs) - , Format (Tup fs) - , Value (Sep fs) ~ Value fs) - => Packable (Tup (f1 :*: fs)) where - - pack (Tup fs) xs - = pack Word8be (cw8 '(') - <> pack (Sep ',' fs) xs - <> pack Word8be (cw8 ')') - {-# INLINE pack #-} - - -- TODO: finish tuple decoding. - unpack = error "repa-convert.row unpack finish me" - {-# INLINE unpack #-} - - ---------------------------------------------------------------------------------------------------- -cw8 :: Char -> Word8 -cw8 c = fromIntegral $ ord c -{-# INLINE cw8 #-} - diff --git a/Data/Repa/Convert/Format/Unit.hs b/Data/Repa/Convert/Format/Unit.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Convert/Format/Unit.hs @@ -0,0 +1,48 @@ + +-- | Unitary formats. +module Data.Repa.Convert.Format.Unit + ( UnitAsc (..)) +where +import Data.Repa.Convert.Internal.Format +import Data.Repa.Convert.Internal.Packable +import Data.Repa.Convert.Format.String +import GHC.Exts +import Data.Word +import Prelude hiding (fail) +#include "repa-convert.h" + + +------------------------------------------------------------------------------------------- UnitAsc +-- | A particular ASCII string. +data UnitAsc = UnitAsc String deriving (Eq, Show) +instance Format UnitAsc where + type Value UnitAsc = () + fieldCount _ = 1 + minSize (UnitAsc s) = length s + fixedSize (UnitAsc s) = Just $ length s + packedSize (UnitAsc s) () = Just $ length s + {-# INLINE fieldCount #-} + {-# INLINE minSize #-} + {-# INLINE fixedSize #-} + {-# INLINE packedSize #-} + + +instance Packable UnitAsc where + packer (UnitAsc s) () start k + = packer (FixChars (length s)) s start k + {-# INLINE pack #-} + + +instance Unpackable UnitAsc where + unpacker (UnitAsc str) start end stop fail eat + = do (Ptr ptr, str') <- unpackCharList (pw8 start) (pw8 end) stop + if str == str' + then eat ptr () + else fail + {-# NOINLINE unpack #-} + + + +pw8 :: Addr# -> Ptr Word8 +pw8 addr = Ptr addr +{-# INLINE pw8 #-} diff --git a/Data/Repa/Convert/Formats.hs b/Data/Repa/Convert/Formats.hs --- a/Data/Repa/Convert/Formats.hs +++ b/Data/Repa/Convert/Formats.hs @@ -1,32 +1,44 @@ -- | Pre-defined data formats. module Data.Repa.Convert.Formats - ( -- * Default Ascii Format + ( -- * Default FormatAscii(..) + + -- * Units + , UnitAsc (..) - -- * Field Products - , (:*:)(..) + -- * Maybes + , MaybeChars (..) + , MaybeBytes (..) - -- * Field Separators - , App (..) - , Sep (..) - , Tup (..) + -- * String Formats + -- ** for Haskell Strings + , FixChars (..) + , VarChars (..) + , VarCharString (..) + , ExactChars (..) - -- * Strings - , FixAsc (..) - , VarAsc (..) - , VarString (..) + -- ** for Data.Text + , VarText (..) + , VarTextString (..) - -- * Atomic values - -- ** ASCII numeric + -- ** for Data.ByteString + , VarBytes (..) + + -- * ASCII Atoms + -- ** ASCII integers , IntAsc (..) , IntAsc0 (..) + + -- ** ASCII doubles , DoubleAsc (..) + , DoubleFixedPack (..) -- ** ASCII dates , YYYYsMMsDD (..) , DDsMMsYYYY (..) + -- * Binary Atoms -- ** 8-bit binary , Word8be (..) , Int8be (..) @@ -43,16 +55,33 @@ -- ** 64-bit binary , Word64be (..) , Int64be (..) - , Float64be (..)) + , Float64be (..) + + -- * Compounds + -- ** Appended fields + , App (..) + + -- ** Separated fields + , Sep, SepFormat (..) + + -- ** Object with labeled fields + , Object, ObjectFormat, Field (..), mkObject + + -- * Products + , (:*:)(..)) where import Data.Repa.Convert.Format.Ascii import Data.Repa.Convert.Format.App import Data.Repa.Convert.Format.Binary +import Data.Repa.Convert.Format.Bytes import Data.Repa.Convert.Format.Date32 import Data.Repa.Convert.Format.Fields () -import Data.Repa.Convert.Format.Lists +import Data.Repa.Convert.Format.Maybe import Data.Repa.Convert.Format.Numeric -import Data.Repa.Convert.Format.Tup +import Data.Repa.Convert.Format.Object import Data.Repa.Convert.Format.Sep +import Data.Repa.Convert.Format.String +import Data.Repa.Convert.Format.Text +import Data.Repa.Convert.Format.Unit import Data.Repa.Scalar.Product diff --git a/Data/Repa/Convert/Internal/Format.hs b/Data/Repa/Convert/Internal/Format.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Convert/Internal/Format.hs @@ -0,0 +1,47 @@ + +module Data.Repa.Convert.Internal.Format + (Format (..)) +where + + +-- | Relates a storage format to the Haskell type of the value +-- that is stored in that format. +class Format f where + + -- | Get the type of a value with this format. + type Value f + + + -- | Yield the number of separate fields in this format. + fieldCount :: f -> Int + + + -- | Yield the minumum number of bytes that a value of this + -- format will take up. + -- + -- Packing a value into this format + -- is guaranteed to use at least this many bytes. + -- This is exact for fixed-size formats. + minSize :: f -> Int + + + -- | For fixed size formats, yield their size (length) in bytes. + -- + -- Yields `Nothing` if this is not a fixed size format. + -- + fixedSize :: f -> Maybe Int + + + -- | Yield the maximum packed size of the value in this format. + -- + -- If `fixedSize` returns a size then `packedSize` returns the same size. + -- + -- For variable length formats, `packedSize` is an over-approximation. + -- We allow the actual packed value to use less space, as it may not be + -- possible to determine how much space it needs without actually packing it. + -- + -- Yields `Nothing` when a collection of values is to be packed into a + -- fixed length format, but the size of the collection does not match + -- the format. + -- + packedSize :: f -> Value f -> Maybe Int diff --git a/Data/Repa/Convert/Internal/Packable.hs b/Data/Repa/Convert/Internal/Packable.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Convert/Internal/Packable.hs @@ -0,0 +1,61 @@ + +module Data.Repa.Convert.Internal.Packable + ( Packable (..) + , Unpackable (..)) +where +import Data.Repa.Convert.Internal.Format +import Data.Repa.Convert.Internal.Packer +import Data.Repa.Convert.Internal.Unpacker +import Data.Word +import GHC.Exts + + +-- | Class of storage formats that can have values packed and unpacked +-- from foreign bufferes. +-- +-- The methods are written using continuations to make it easier for +-- GHC to optimise its core code when packing/unpacking many fields. +-- +class Format format + => Packable format where + + + -- | Pack a value into a buffer using the given format. + pack :: format -- ^ Storage format. + -> Value format -- ^ Value to pack. + -> Packer -- ^ Packer that can write the value. + + pack format value + = Packer (packer format value) + {-# INLINE pack #-} + + + -- | Low level packing function for the given format. + packer :: format -- ^ Data format. + -> Value format -- ^ Value to pack. + -> Addr# -- ^ Pointer to start of buffer. + -> IO () -- ^ Signal failure. + -> (Addr# -> IO ()) -- ^ Accept the address after the packed field. + -> IO () + + +class Format format + => Unpackable format where + + -- | Unpack a value from a buffer using the given format. + unpack :: format -- ^ Storage format. + -> Unpacker (Value format) -- ^ Unpacker for that format. + + unpack format + = Unpacker (unpacker format) + {-# INLINE unpack #-} + + + -- | Low level unpacking function for the given format. + unpacker :: format -- ^ Data format. + -> Addr# -- ^ Start of buffer. + -> Addr# -- ^ Pointer to first byte after end of buffer. + -> (Word8 -> Bool) -- ^ Detect a field terminator. + -> IO () -- ^ Signal failure. + -> (Addr# -> Value format -> IO ()) -- ^ Accept an unpacked value. + -> IO () diff --git a/Data/Repa/Convert/Internal/Packer.hs b/Data/Repa/Convert/Internal/Packer.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Convert/Internal/Packer.hs @@ -0,0 +1,60 @@ + +module Data.Repa.Convert.Internal.Packer + ( Packer (..) + , unsafeRunPacker) +where +import Data.Word +import Data.IORef +import GHC.Exts +import qualified Foreign.Ptr as F + + +-- | Packer wraps a function that can write to a buffer. +data Packer + = Packer + { -- | Takes start of buffer; failure action; and a continuation. + -- + -- We try to pack data into the given buffer. + -- If packing succeeds then we call the continuation with a pointer + -- to the next byte after the packed value, + -- otherwise we call the failure action. + -- + fromPacker + :: Addr# -- Start of buffer. + -> IO () -- Signal failure. + -> (Addr# -> IO ()) -- Accept the address after the packed value. + -> IO () + } + + +instance Monoid Packer where + mempty + = Packer $ \buf _fail k -> k buf + {-# INLINE mempty #-} + + mappend (Packer fa) (Packer fb) + = Packer $ \buf0 fails k -> fa buf0 fails (\buf1 -> fb buf1 fails k) + {-# INLINE mappend #-} + + +-- | Pack data into the given buffer. +-- +-- PRECONDITION: The buffer needs to be big enough to hold the packed data, +-- otherwise you'll corrupt the heap (bad). Use `packedSize` to work out +-- how big it needs to be. +-- +unsafeRunPacker + :: Packer -- ^ Packer to run. + -> F.Ptr Word8 -- ^ Start of buffer. + -> IO (Maybe (F.Ptr Word8)) + -- ^ Pointer to the byte after the last one written. + +unsafeRunPacker (Packer make) (Ptr addr) + = do ref <- newIORef Nothing + + make addr + (return ()) + (\addr' -> writeIORef ref (Just (Ptr addr'))) + + readIORef ref +{-# INLINE unsafeRunPacker #-} diff --git a/Data/Repa/Convert/Internal/Unpacker.hs b/Data/Repa/Convert/Internal/Unpacker.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Convert/Internal/Unpacker.hs @@ -0,0 +1,100 @@ + +module Data.Repa.Convert.Internal.Unpacker + ( Unpacker (..) + , unsafeRunUnpacker) +where +import Data.IORef +import Data.Word +import GHC.Exts +import Prelude hiding (fail) +import qualified Foreign.Ptr as F + + +--------------------------------------------------------------------------------------------------- +data Unpacker a + = Unpacker + { -- | Takes pointers to the first byte in the buffer; the first byte + -- after the buffer; a predicate to detect a field terminator; + -- a failure action; and a continuation. + -- + -- The field terminator is used by variable length encodings where + -- the length of the encoded data cannot be determined from the + -- encoding itself. + -- + -- We try to unpack a value from the buffer. + -- If unpacking succeeds then call the continuation with a pointer + -- to the next byte after the unpacked value, and the value itself, + -- otherwise call the failure action. + -- + fromUnpacker + :: Addr# -- Start of buffer. + -> Addr# -- Pointer to first byte after end of buffer. + -> (Word8 -> Bool) -- Detect a field terminator. + -> IO () -- Signal failure. + -> (Addr# -> a -> IO ()) -- Accept an unpacked value. + -> IO () + } + + +instance Functor Unpacker where + fmap f (Unpacker fx) + = Unpacker $ \start end stop fail eat + -> fx start end stop fail $ \start_x x + -> eat start_x (f x) + {-# INLINE fmap #-} + + +instance Applicative Unpacker where + pure x + = Unpacker $ \start _end _fail _stop eat + -> eat start x + {-# INLINE pure #-} + + (<*>) (Unpacker ff) (Unpacker fx) + = Unpacker $ \start end stop fail eat + -> ff start end stop fail $ \start_f f + -> fx start_f end stop fail $ \start_x x + -> eat start_x (f x) + {-# INLINE (<*>) #-} + + +instance Monad Unpacker where + return = pure + {-# INLINE return #-} + + (>>=) (Unpacker fa) mkfb + = Unpacker $ \start end stop fail eat + -> fa start end stop fail $ \start_x x + -> case mkfb x of + Unpacker fb + -> fb start_x end stop fail eat + {-# INLINE (>>=) #-} + + +-- | Unpack data from the given buffer. +-- +-- PRECONDITION: The buffer must be at least the minimum size of the +-- format (minSize). This allows us to avoid repeatedly checking for +-- buffer overrun when unpacking fixed size format. If the buffer +-- is not long enough then you'll get an indeterminate result (bad). +-- +unsafeRunUnpacker + :: Unpacker a -- ^ Unpacker to run. + -> F.Ptr Word8 -- ^ Source buffer. + -> Int -- ^ Length of source buffer. + -> (Word8 -> Bool) -- ^ Detect a field terminator. + -> IO (Maybe (a, F.Ptr Word8)) + -- ^ Unpacked result, and pointer to the byte after the last + -- one read. + +unsafeRunUnpacker (Unpacker f) (Ptr start) (I# len) stop + = do ref <- newIORef Nothing + f start + (plusAddr# start len) + stop + (return ()) + (\addr' x -> writeIORef ref (Just (x, (Ptr addr')))) + readIORef ref +{-# INLINE unsafeRunUnpacker #-} + + diff --git a/include/repa-convert.h b/include/repa-convert.h new file mode 100644 --- /dev/null +++ b/include/repa-convert.h @@ -0,0 +1,12 @@ + +#define PHASE_REVEAL [4] +#define PHASE_FLOW [3] +#define PHASE_ARRAY [2] +#define PHASE_STREAM [1] +#define PHASE_INNER [0] + +#define INLINE_REVEAL INLINE PHASE_REVEAL +#define INLINE_FLOW INLINE PHASE_FLOW +#define INLINE_ARRAY INLINE PHASE_ARRAY +#define INLINE_STREAM INLINE PHASE_STREAM +#define INLINE_INNER INLINE PHASE_INNER diff --git a/repa-convert.cabal b/repa-convert.cabal --- a/repa-convert.cabal +++ b/repa-convert.cabal @@ -1,5 +1,5 @@ Name: repa-convert -Version: 4.2.0.1 +Version: 4.2.1.1 License: BSD3 License-file: LICENSE Author: The Repa Development Team @@ -23,6 +23,7 @@ primitive == 0.6.*, vector == 0.10.*, bytestring == 0.10.*, + text == 1.2.*, double-conversion == 2.0.*, repa-scalar == 4.2.0.* @@ -32,17 +33,31 @@ Data.Repa.Convert other-modules: + Data.Repa.Convert.Internal.Format + Data.Repa.Convert.Internal.Packable + Data.Repa.Convert.Internal.Packer + Data.Repa.Convert.Internal.Unpacker + Data.Repa.Convert.Format.Ascii Data.Repa.Convert.Format.App - Data.Repa.Convert.Format.Base Data.Repa.Convert.Format.Binary + Data.Repa.Convert.Format.Bytes Data.Repa.Convert.Format.Date32 Data.Repa.Convert.Format.Fields - Data.Repa.Convert.Format.Lists + Data.Repa.Convert.Format.Maybe Data.Repa.Convert.Format.Numeric + Data.Repa.Convert.Format.Object Data.Repa.Convert.Format.Sep - Data.Repa.Convert.Format.Tup + Data.Repa.Convert.Format.String + Data.Repa.Convert.Format.Text + Data.Repa.Convert.Format.Unit + include-dirs: + include + + install-includes: + repa-convert.h + ghc-options: -Wall -fno-warn-missing-signatures -O2 @@ -64,6 +79,7 @@ StandaloneDeriving ScopedTypeVariables MultiParamTypeClasses + FunctionalDependencies ForeignFunctionInterface ExistentialQuantification NoMonomorphismRestriction