repa-convert 4.2.0.1 → 4.2.1.1

raw patch · 25 files changed

+2088/−911 lines, 25 filesdep +textPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: text

API changes (from Hackage documentation)

Files

• Data/Repa/Convert.hs +143/−78
• Data/Repa/Convert/Format.hs +7/−5
• Data/Repa/Convert/Format/App.hs +34/−17
• Data/Repa/Convert/Format/Ascii.hs +5/−22
• Data/Repa/Convert/Format/Base.hs +0/−206
• Data/Repa/Convert/Format/Binary.hs +139/−89
• Data/Repa/Convert/Format/Bytes.hs +101/−0
• Data/Repa/Convert/Format/Date32.hs +48/−29
• Data/Repa/Convert/Format/Fields.hs +18/−9
• Data/Repa/Convert/Format/Lists.hs +0/−218
• Data/Repa/Convert/Format/Maybe.hs +206/−0
• Data/Repa/Convert/Format/Numeric.hs +116/−55
• Data/Repa/Convert/Format/Object.hs +295/−0
• Data/Repa/Convert/Format/Sep.hs +159/−66
• Data/Repa/Convert/Format/String.hs +304/−0
• Data/Repa/Convert/Format/Text.hs +120/−0
• Data/Repa/Convert/Format/Tup.hs +0/−97
• Data/Repa/Convert/Format/Unit.hs +48/−0
• Data/Repa/Convert/Formats.hs +45/−16
• Data/Repa/Convert/Internal/Format.hs +47/−0
• Data/Repa/Convert/Internal/Packable.hs +61/−0
• Data/Repa/Convert/Internal/Packer.hs +60/−0
• Data/Repa/Convert/Internal/Unpacker.hs +100/−0
• include/repa-convert.h +12/−0
• repa-convert.cabal +20/−4

@@ -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 #-}

@@ -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

@@ -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 #-}+ 

@@ -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 #-}  

@@ -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.--

@@ -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 #-} 

@@ -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 #-}

@@ -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 #-}  

@@ -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 #-} 

@@ -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  #-}-

@@ -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 #-}

@@ -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 #-} 

@@ -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 #-}

@@ -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 #-} 

@@ -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 #-}+

@@ -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 #-}+

@@ -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 #-}-

@@ -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 #-}

@@ -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 

@@ -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

@@ -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 ()

@@ -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 #-}

@@ -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 #-}++

@@ -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

@@ -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