More PrimMonad work.

1 files changed, 71 insertions, 18 deletions

diff --git a/haskell/Data/XDelta.hsc b/haskell/Data/XDelta.hsc
index 09f5523..113959b 100644
--- a/haskell/Data/XDelta.hsc
+++ b/haskell/Data/XDelta.hsc
@@ -2,8 +2,9 @@
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase                 #-}
-{-# LANGUAGE PatternSynonyms            #-}
 {-# LANGUAGE NondecreasingIndentation   #-}
+{-# LANGUAGE PatternSynonyms            #-}
+{-# LANGUAGE RankNTypes                 #-}
 module Data.XDelta where
 
 import Control.Monad
@@ -15,6 +16,7 @@ import qualified Data.ByteString as B
 import qualified Data.ByteString.Unsafe as B
 import qualified Data.ByteString.Internal as B
 import Data.Coerce
+import Data.Monoid
 import Data.Primitive.Addr
 import Data.Primitive.ByteArray
 import Data.Primitive.MutVar
@@ -23,9 +25,11 @@ import qualified Data.Text as T
 import Data.Text.Encoding
 import Data.Word
 import Foreign.C.Types
+import Foreign.C.String
 import Foreign.ForeignPtr (withForeignPtr)
 import Foreign.Ptr
 import Foreign.Concurrent
+import Foreign.Storable
 import Foreign.ForeignPtr (ForeignPtr)
 import GHC.Exts
 
@@ -164,12 +168,13 @@ set_source stream nm blksz maxwinsz = do
     unsafeIOToPrim (xd3_set_source strm srcptr)
     writeMutVar (streamSource stream) (Just src)
 
-data XDeltaMethods m = XDeltaMethods
+data XDeltaMethods m u = XDeltaMethods
     { xConfig    :: Config
     , xGetSource :: Xoff_t -> B.ByteString
-    , xOutput    :: Ptr Word8 -> Int -> IO m
-    , xOnError   :: ErrorCode -> String -> IO m
+    , xOutput    :: Ptr Word8 -> Int -> m u
+    , xOnError   :: ErrorCode -> String -> m u
     , xBlockSize :: Usize_t
+    , xInterleave :: forall a. m a -> m a
     }
 
 -- | Checks for legal flag changes.
@@ -181,35 +186,84 @@ setFlush stream wantFlush = return () -- todo
 setSkipWindow :: PrimMonad m => Stream m -> Bool -> m ()
 setSkipWindow stream wantSkipWin = return () -- todo
 
-{-
-xdelta :: Monoid m => XDeltaMethods m -> (Stream s -> IO ErrorCode) -> [B.ByteString] -> ST s m
+foreign import ccall "xdelta3.h xd3_avail_input" xd3_avail_input :: Ptr Xd3Stream -> Ptr a -> Usize_t -> IO ()
+
+avail_input stream p sz =
+    -- withForeignPtr fp (\stream -> xd3_avail_input stream p sz)
+    -- TODO
+    return ()
+
+-- | This acknowledges receipt of output data, must be called after any
+-- XD3_OUTPUT return.
+foreign import ccall "xdelta3.h xd3_consume_output" xd3_consume_output :: Ptr Xd3Stream -> IO ()
+
+nextOut :: PrimMonad m => Stream m -> ((Ptr Word8, Int) -> m a) -> m a
+nextOut stream action = do
+    buf <- (,)
+        <$> readAtByte (streamArray stream) #{offset xd3_stream, next_out}
+        <*> readAtByte (streamArray stream) #{offset xd3_stream, avail_out}
+    a <- action buf
+    unsafeIOToPrim $ xd3_consume_output (ptr $ mutableByteArrayContents $ streamArray stream)
+    return a
+
+
+requestedBlockNumber :: PrimMonad m => Stream m -> m (Maybe Xoff_t)
+requestedBlockNumber stream = do
+    msrc <- readMutVar $ streamSource stream
+    forM msrc $ \src -> readAtByte src #offset xd3_source, getblkno
+
+data CurrentBlock = CurrentBlock
+    { blkno   :: !Xoff_t      -- ^ current block number
+    , blkSize :: !Usize_t     -- ^ number of bytes on current block: must be >= 0 and <= 'srcBlockSize'
+    , blkPtr  :: !(Ptr Word8) -- ^ current block array
+    }
+
+foreign import ccall "xdelta3.h xd3_errstring" xd3_errstring :: Ptr Xd3Stream -> IO CString
+
+-- | Gives some extra information about the latest library error, if any
+-- is known.
+errorString stream = unsafeIOToPrim $ withForeignPtr (streamPtr stream) $ \stream -> do
+    cstring <- xd3_errstring stream
+    peekCString cstring
+
+pokeCurrentBlock :: PrimMonad m => Stream m -> CurrentBlock -> m ()
+pokeCurrentBlock stream (CurrentBlock no sz ptr) = do
+    msrc <- readMutVar $ streamSource stream
+    forM_ msrc $ \src -> do
+        writeAtByte src #{offset xd3_source, curblkno} no
+        writeAtByte src #{offset xd3_source, onblk}    sz
+        writeAtByte src #{offset xd3_source, curblk}   ptr
+
+
+xdelta :: (PrimBase m, Monoid u) => XDeltaMethods m u -> (Stream m -> IO ErrorCode) -> [B.ByteString]
+    -> m (Either ErrorCode u)
 xdelta x xxcode_input ds = do
     mstream <- config_stream (xConfig x)
-    forM_ mstream $ \stream -> do
+    forM mstream $ \stream -> do
     set_source stream "xdelta" (xBlockSize x) (xBlockSize x)
     let go withBlk (d:ds) = do
             let (fp,off,len) = B.toForeignPtr d
-            withForeignPtr fp $ \indata0 -> do
+                eof = null ds
+            when eof $ setFlush stream True
+            unsafeIOToPrim $ withForeignPtr fp $ \indata0 -> do
                 let indata = indata0 `plusPtr` off
-                    eof = null ds
-                when eof $ xd3_set_flags (ptr $ mutableByteArrayContents $ streamArray stream) XD3_FLUSH
                 avail_input stream indata (fromIntegral len)
-                go2 withBlk eof ds
+                unsafePrimToIO $ go2 withBlk eof ds
         go2 withBlk eof ds = do
-            ret <- withBlk $ xxcode_input stream
+            ret <- withBlk $ unsafeIOToPrim $ xxcode_input stream
             case ret of
                 XD3_INPUT -> if (not eof) then go withBlk ds else return mempty
                 XD3_OUTPUT -> do
                     m' <- nextOut stream (uncurry $ xOutput x)
-                    ms <- unsafeInterleaveIO $ go2 withBlk eof ds
+                    ms <- xInterleave x $ go2 withBlk eof ds
                     return $ m' <> ms
                 XD3_GETSRCBLK -> do
-                    n <- requestedBlockNumber stream
+                    Just n <- requestedBlockNumber stream
                     let blk = xGetSource x n
                         withBlk' act = let (fp,off,len) = B.toForeignPtr blk
-                                       in withForeignPtr fp $ \p -> do
-                                           pokeCurrentBlock stream $ CurrentBlock n (fromIntegral len) (plusPtr p off)
-                                           act
+                                       in unsafeIOToPrim $ withForeignPtr fp $ \p -> unsafePrimToIO $ do
+                                        pokeCurrentBlock stream $ CurrentBlock n (fromIntegral len) (plusPtr p off)
+                                        act
                     go2 withBlk' eof ds
                 XD3_GOTHEADER -> go2 withBlk eof ds -- No
                 XD3_WINSTART  -> go2 withBlk eof ds --  action
@@ -222,4 +276,3 @@ xdelta x xxcode_input ds = do
                     s <- errorString stream
                     xOnError x e s
     go id ds
--}