From f8bb9011375e39b71fe1764159e034a97ea70f2e Mon Sep 17 00:00:00 2001
From: Joe Crayne <joe@jerkface.net>
Date: Thu, 25 Oct 2018 19:24:54 -0400
Subject: it works

---
 haskell/Data/XDelta.hsc | 44 ++++++++++++++++++++++----------------------
 1 file changed, 22 insertions(+), 22 deletions(-)

(limited to 'haskell/Data/XDelta.hsc')

diff --git a/haskell/Data/XDelta.hsc b/haskell/Data/XDelta.hsc
index 4ebdd51..bb08cb6 100644
--- a/haskell/Data/XDelta.hsc
+++ b/haskell/Data/XDelta.hsc
@@ -30,7 +30,6 @@ import Data.STRef
 import qualified Data.Text as T
 import Data.Text.Encoding
 import Data.Word
-import Debug.Trace
 import Foreign.C.Types
 import Foreign.C.String
 import Foreign.ForeignPtr (withForeignPtr)
@@ -53,7 +52,10 @@ import XDelta.Types
 
 data Stream m = Stream
     { streamArray  :: MutableByteArray (PrimState m)
-    , streamPtr    :: ForeignPtr Xd3Stream
+    , streamPtr    :: ForeignPtr Xd3Stream -- ^ HACK: this is only used to attach a finalizer
+                                           -- to 'streamArray'.  Don't use this pointer.
+                                           -- This would be unnecessary if I could create a
+                                           -- MutableByteArray with a finalizer attached.
     , streamSource :: MutVar (PrimState m) (Maybe (MutableByteArray (PrimState m)))
     }
 
@@ -138,6 +140,7 @@ config_stream cfg = do
                 xd3_abort_stream sptr
                 xd3_close_stream sptr
                 xd3_free_stream sptr
+                seq s $ return () -- Keep array s alive until the ffi functions finish.
         fp <- newForeignPtr sptr finalize
         return Stream
             { streamArray  = s
@@ -278,7 +281,8 @@ xdelta x xxcode_input ds = do
            (flip ($))
            mstream $ \stream -> do
     set_source stream "xdelta" (xBlockSize x) (xBlockSize x)
-    let go withBlk (d:ds) = do
+    let go withBlk [] = return mempty
+        go withBlk (d:ds) = do
             let (fp,off,len) = B.toForeignPtr d
                 eof = null ds
             when eof $ setFlush stream True
@@ -291,9 +295,8 @@ xdelta x xxcode_input ds = do
                 XD3_INPUT -> if (not eof) then go withBlk ds else return mempty
                 XD3_OUTPUT -> do
                     m' <- nextOut stream (\(p,len) -> xOutput x p (fromIntegral len))
-                    ms <- xInterleave x $ undefined -- go2 withBlk eof ds
-                    return $ trace "chunk" m' <> ms
-                             -- XXX: This output is to test for laziness.
+                    ms <- xInterleave x $ go2 withBlk eof ds
+                    return $ m' <> ms
                 XD3_GETSRCBLK -> do
                     Just n <- requestedBlockNumber stream
                     let blk = xGetSource x n
@@ -314,7 +317,7 @@ xdelta x xxcode_input ds = do
                 e -> do
                     s <- errorString stream
                     xOnError x e s
-    go id ds
+    xInterleave x $ go id ds
 
 
 foreign import ccall "xdelta3.h xd3_decode_input" xd3_decode_input  :: Ptr Xd3Stream -> IO ErrorCode
@@ -342,39 +345,36 @@ computeDiff cfg source patched = fmap XDelta $ xdeltaPure encode_input cfg sourc
 applyPatch :: Config -> L.ByteString -> XDelta -> XDeltaFailable L.ByteString
 applyPatch cfg source (XDelta delta) = xdeltaPure decode_input cfg source delta
 
-data XDeltaFailable x = XError ErrorCode String
-                      | XSuccess x
+data XDeltaFailable x = XResult { xresult :: x, xerror :: (Maybe (ErrorCode,String)) }
     deriving (Show,Functor)
 
 instance Monoid x => Monoid (XDeltaFailable x) where
-    mempty = XSuccess mempty
-    mappend (XSuccess x) (XSuccess y) = XSuccess $ mappend x y
-    mappend x@XError{} _ = x
-    mappend _ y@XError{} = y
+    mempty = XResult mempty Nothing
+    mappend (XResult x xe) y = XResult (mappend x $ xresult y) (maybe (xerror y) Just xe)
 
 xdeltaPure :: (forall s. Stream (ST s) -> ST s ErrorCode) -> Config -> L.ByteString -> L.ByteString -> XDeltaFailable L.ByteString
 xdeltaPure codec cfg source delta =
-    let smap = IntMap.fromList $ zip [0..] (chunksOf 16 source)
+    let smap = IntMap.fromList $ zip [0..] (chunksOf bsize source)
+        bsize = 4096
         x :: XDeltaMethods (ST s) (XDeltaFailable L.ByteString)
         x = XDeltaMethods
                 { xConfig    = cfg
                 , xGetSource = \i -> case IntMap.lookup (fromIntegral i) smap of
                                     Nothing -> B.empty
                                     Just bs -> bs
-                , xOutput    = \ptr len -> unsafeIOToST $ XSuccess . L.fromStrict <$> B.packCStringLen (castPtr ptr,len)
-                , xOnError   = \e s -> return (XError e s) -- :: ErrorCode -> String -> m u
-                , xBlockSize = 16 -- 4096 -- :: Usize_t
+                , xOutput    = \ptr len -> unsafeIOToST $ flip XResult Nothing . L.fromStrict <$> B.packCStringLen (castPtr ptr,len)
+                , xOnError   = \e s -> return (XResult L.empty (Just (e,s))) -- :: ErrorCode -> String -> m u
+                , xBlockSize = bsize -- :: Usize_t
                 , xInterleave = unsafeInterleaveST -- :: forall a. m a -> m a
-                -- XXX: Why isn't unsafeInterleaveST making it lazy?
                 }
-        ds = chunksOf 16 delta -- L.toChunks delta
+        ds = chunksOf bsize delta -- L.toChunks delta
     in runST $ xdelta x codec ds
 
 defaultConfig :: Config
 defaultConfig = Config
-  { winsize   = 4096
-  , sprevsz   = 0
-  , iopt_size = 0
+  { winsize   = XD3_DEFAULT_WINSIZE
+  , sprevsz   = XD3_DEFAULT_SPREVSZ
+  , iopt_size = XD3_DEFAULT_IOPT_SIZE
   , flags     = mempty
   , sec_data  = CompressorConfig 0 0 0
   , sec_inst  = CompressorConfig 0 0 0
-- 
cgit v1.2.3