it works

4 files changed, 41 insertions, 26 deletions

diff --git a/examples/testdiff.hs b/examples/testdiff.hs
index 4ed7dd4..9360545 100644
--- a/examples/testdiff.hs
+++ b/examples/testdiff.hs
@@ -19,5 +19,11 @@ main = do
     mapM_ putStrLn $ xxd2 0 (L.toStrict patched)
     putStrLn ""
     case delta of
-        XSuccess (XDelta d) -> mapM_ putStrLn $ xxd2 0 (L.toChunks d !! 0)
-        _                   -> print delta
+        XResult δ@(XDelta d) me -> do
+            -- mapM_ (mapM_ putStrLn . xxd2 0) (chunksOf 16 d)
+            mapM_ putStrLn $ xxd2 0 (L.toStrict d)
+            print me
+            putStrLn ""
+            let XResult patched' pe = applyPatch defaultConfig source δ
+            mapM_ putStrLn $ xxd2 0 (L.toStrict patched') -- $ L.take 48 patched')
+            print pe
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
diff --git a/haskell/XDelta/Types.hsc b/haskell/XDelta/Types.hsc
index f1d98ce..a0f2cfa 100644
--- a/haskell/XDelta/Types.hsc
+++ b/haskell/XDelta/Types.hsc
@@ -115,6 +115,9 @@ data Config = Config
   , smatch_cfg :: Either StringMatcher SMatchSelect -- ^  See enum: use fields below  for soft config
   }
 
+pattern XD3_DEFAULT_WINSIZE = #const XD3_DEFAULT_WINSIZE
+pattern XD3_DEFAULT_SPREVSZ = #const XD3_DEFAULT_SPREVSZ
+pattern XD3_DEFAULT_IOPT_SIZE = #const XD3_DEFAULT_IOPT_SIZE
 
 newtype Flags = Flags Word32
     deriving (Storable,Eq,Bits,FiniteBits)
diff --git a/xdelta3.cabal b/xdelta3.cabal
index e773d6e..bc8a81b 100644
--- a/xdelta3.cabal
+++ b/xdelta3.cabal
@@ -25,7 +25,7 @@ library
   -- extra-lib-dirs: xdelta3_lib
   include-dirs: haskell .
   -- cc-options:  -std=c++14 -Wno-literal-suffix
-  cxx-options: -Wno-literal-suffix
+  cxx-options: -Wno-literal-suffix -g
   cpp-options: -DNOT_MAIN=1 -DREGRESSION_TEST=1 -DSECONDARY_DJW=1 -DSECONDARY_FGK=1 -DXD3_MAIN=1 -DXD3_DEBUG=0 -DHAVE_CONFIG
   --  cpp-options: -DHAVE_CONFIG_H -DSIZEOF_SIZE_T=__SIZEOF_SIZE_T__ -DSIZEOF_UNSIGNED_INT=__SIZEOF_INT__ -DSIZEOF_UNSIGNED_LONG=__SIZEOF_LONG__
   -- cpp-options: -DSIZEOF_UNSIGNED_LONG_LONG=__SIZEOF_LONG_LONG__
@@ -34,7 +34,7 @@ library
   cxx-sources: haskell/xdelta3.cc
 
   hs-source-dirs:      haskell
-  build-depends:       base >=4.10, bytestring, text, primitive, containers
+  build-depends:       base >=4.9, bytestring, text, primitive >=0.6.2, containers
   default-language:    Haskell2010
   ghc-options: -Wmissing-signatures
 
@@ -43,3 +43,9 @@ executable testdiff
   other-modules: Text.XXD
   hs-source-dirs: haskell examples .
   build-depends: base, bytestring, memory, xdelta
+
+executable lazy
+  main-is: lazy.hs
+  other-modules: Text.XXD
+  hs-source-dirs: haskell examples .
+  build-depends: base, bytestring, memory, xdelta