diff options
Diffstat (limited to 'haskell/Data/VCDIFF.hs')
-rw-r--r-- | haskell/Data/VCDIFF.hs | 66 |
1 files changed, 11 insertions, 55 deletions
diff --git a/haskell/Data/VCDIFF.hs b/haskell/Data/VCDIFF.hs index f06be9c..fe4cc98 100644 --- a/haskell/Data/VCDIFF.hs +++ b/haskell/Data/VCDIFF.hs | |||
@@ -24,7 +24,6 @@ module Data.VCDIFF | |||
24 | , computeDiff | 24 | , computeDiff |
25 | , applyPatch) where | 25 | , applyPatch) where |
26 | 26 | ||
27 | -- import Debug.Trace | ||
28 | import Control.Monad | 27 | import Control.Monad |
29 | import Control.Monad.Primitive | 28 | import Control.Monad.Primitive |
30 | import Control.Monad.ST | 29 | import Control.Monad.ST |
@@ -69,6 +68,7 @@ data Stream m = Stream | |||
69 | , streamSource :: MutVar (PrimState m) (Maybe (Source m)) | 68 | , streamSource :: MutVar (PrimState m) (Maybe (Source m)) |
70 | } | 69 | } |
71 | 70 | ||
71 | keepAlive :: a1 -> a2 -> IO () | ||
72 | keepAlive srcvar s = do | 72 | keepAlive srcvar s = do |
73 | seq srcvar $ seq s $ return () -- Keep array s alive until the ffi functions finish. | 73 | seq srcvar $ seq s $ return () -- Keep array s alive until the ffi functions finish. |
74 | {-# NOINLINE keepAlive #-} | 74 | {-# NOINLINE keepAlive #-} |
@@ -89,7 +89,6 @@ config_stream cfg = do | |||
89 | xd3_abort_stream sptr | 89 | xd3_abort_stream sptr |
90 | xd3_close_stream sptr | 90 | xd3_close_stream sptr |
91 | xd3_free_stream sptr | 91 | xd3_free_stream sptr |
92 | putStrLn $ "finalized " ++ show sptr | ||
93 | keepAlive srcvar s | 92 | keepAlive srcvar s |
94 | fp <- newForeignPtr sptr finalize | 93 | fp <- newForeignPtr sptr finalize |
95 | return Stream | 94 | return Stream |
@@ -122,7 +121,7 @@ set_source stream nm blksz maxwinsz = do | |||
122 | 121 | ||
123 | data XDeltaMethods m u = XDeltaMethods | 122 | data XDeltaMethods m u = XDeltaMethods |
124 | { xConfig :: Config | 123 | { xConfig :: Config |
125 | , xGetSource :: Xoff_t -> B.ByteString | 124 | , xGetSource :: Xoff_t -> m B.ByteString |
126 | , xOutput :: Ptr Word8 -> Int -> m u | 125 | , xOutput :: Ptr Word8 -> Int -> m u |
127 | , xOnError :: ErrorCode -> String -> m u | 126 | , xOnError :: ErrorCode -> String -> m u |
128 | , xBlockSize :: Usize_t | 127 | , xBlockSize :: Usize_t |
@@ -173,12 +172,11 @@ outputChunks :: (Monoid b, Num t, PrimMonad m, Show b) => | |||
173 | outputChunks strm interleave encode output next = fix $ \loop -> do | 172 | outputChunks strm interleave encode output next = fix $ \loop -> do |
174 | encode >>= \case | 173 | encode >>= \case |
175 | XD3_OUTPUT -> do u1 <- nextOut strm $ \(p,len) -> output p (fromIntegral len) | 174 | XD3_OUTPUT -> do u1 <- nextOut strm $ \(p,len) -> output p (fromIntegral len) |
176 | trace ("u1 = " ++ show u1) $ return () | ||
177 | u <- interleave $ loop | 175 | u <- interleave $ loop |
178 | return $ u1 <> u | 176 | return $ u1 <> u |
179 | XD3_GOTHEADER -> trace "XD3_GOTHEADER" loop | 177 | XD3_GOTHEADER -> loop |
180 | XD3_WINSTART -> trace "XD3_WINSTART" loop | 178 | XD3_WINSTART -> loop |
181 | XD3_WINFINISH -> trace "XD3_WINFINISH" loop | 179 | XD3_WINFINISH -> loop |
182 | xd3 -> next xd3 | 180 | xd3 -> next xd3 |
183 | 181 | ||
184 | withBlocks :: PrimBase m => B.ByteString -> Maybe B.ByteString -> m a -> m a | 182 | withBlocks :: PrimBase m => B.ByteString -> Maybe B.ByteString -> m a -> m a |
@@ -196,7 +194,7 @@ updateBlock :: (Monoid u, PrimBase m, Show u) => | |||
196 | -> ErrorCode | 194 | -> ErrorCode |
197 | -> m u | 195 | -> m u |
198 | updateBlock stream code_input mblk x _ [] XD3_INPUT = return mempty | 196 | updateBlock stream code_input mblk x _ [] XD3_INPUT = return mempty |
199 | updateBlock stream code_input mblk x _ (d:ds) XD3_INPUT = trace "XD3_INPUT" $ do | 197 | updateBlock stream code_input mblk x _ (d:ds) XD3_INPUT = do |
200 | withByteString d $ \p len -> avail_input (streamArray stream) p len | 198 | withByteString d $ \p len -> avail_input (streamArray stream) p len |
201 | when (null ds) $ setFlush (streamArray stream) True | 199 | when (null ds) $ setFlush (streamArray stream) True |
202 | outputChunks (streamArray stream) (xInterleave x) | 200 | outputChunks (streamArray stream) (xInterleave x) |
@@ -205,10 +203,9 @@ updateBlock stream code_input mblk x _ (d:ds) XD3_INPUT = trace "XD3_INPUT" $ do | |||
205 | $ updateBlock stream code_input mblk x d ds | 203 | $ updateBlock stream code_input mblk x d ds |
206 | updateBlock stream code_input mblk x d ds XD3_GETSRCBLK = do | 204 | updateBlock stream code_input mblk x d ds XD3_GETSRCBLK = do |
207 | Just n <- requestedBlockNumber stream | 205 | Just n <- requestedBlockNumber stream |
208 | let blk = xGetSource x n | 206 | blk <- xGetSource x n |
209 | withByteString blk $ \p len -> do | 207 | withByteString blk $ \p len -> do |
210 | pokeCurrentBlock stream $ CurrentBlock n len p | 208 | pokeCurrentBlock stream $ CurrentBlock n len p |
211 | trace ("XD3_GETSRCBLK " ++ show (n,len,p,xBlockSize x)) $ return () | ||
212 | when (len < xBlockSize x) $ do | 209 | when (len < xBlockSize x) $ do |
213 | Just src <- readMutVar $ streamSource stream | 210 | Just src <- readMutVar $ streamSource stream |
214 | sourceWriteEOFKnown src True | 211 | sourceWriteEOFKnown src True |
@@ -216,59 +213,18 @@ updateBlock stream code_input mblk x d ds XD3_GETSRCBLK = do | |||
216 | (withBlocks d (Just blk) code_input) | 213 | (withBlocks d (Just blk) code_input) |
217 | (xOutput x) | 214 | (xOutput x) |
218 | $ updateBlock stream code_input mblk x d ds | 215 | $ updateBlock stream code_input mblk x d ds |
219 | updateBlock stream code_input mblk x d ds e = trace (show e) $ do | 216 | updateBlock stream code_input mblk x d ds e = do |
220 | s <- errorString (streamArray stream) | 217 | s <- errorString (streamArray stream) |
221 | xOnError x e s | 218 | xOnError x e s |
222 | 219 | ||
223 | trace _ = id | ||
224 | |||
225 | xdelta :: (Show u, PrimBase m, Monoid u) => XDeltaMethods m u -> (Stream m -> m ErrorCode) -> [B.ByteString] -> m u | 220 | xdelta :: (Show u, PrimBase m, Monoid u) => XDeltaMethods m u -> (Stream m -> m ErrorCode) -> [B.ByteString] -> m u |
226 | xdelta x xxcode_input ds = trace ("ds = "++show ds) $ do | 221 | xdelta x xxcode_input ds = do |
227 | mstream <- config_stream (xConfig x) | 222 | mstream <- config_stream (xConfig x) |
228 | either (\e _ -> xOnError x e "config_stream failed") | 223 | either (\e _ -> xOnError x e "config_stream failed") |
229 | (flip ($)) | 224 | (flip ($)) |
230 | mstream $ \stream -> do | 225 | mstream $ \stream -> do |
231 | src <- set_source stream "VCDIFF" (xBlockSize x) (xBlockSize x) | 226 | src <- set_source stream "VCDIFF" (xBlockSize x) (xBlockSize x) |
232 | updateBlock stream (xxcode_input stream) Nothing x B.empty ds XD3_INPUT | 227 | updateBlock stream (xxcode_input stream) Nothing x B.empty ds XD3_INPUT |
233 | {- | ||
234 | let go withBlk [] = return mempty | ||
235 | go withBlk (d:ds) = do | ||
236 | let (fp,off,len) = B.toForeignPtr d | ||
237 | eof = null ds || len < fromIntegral (xBlockSize x) | ||
238 | when eof $ setFlush (streamArray stream) True | ||
239 | withByteString d $ \indata len -> do | ||
240 | avail_input (streamArray stream) indata len | ||
241 | go2 withBlk eof ds | ||
242 | go2 withBlk eof ds = do | ||
243 | ret <- withBlk $ xxcode_input stream | ||
244 | case ret of | ||
245 | XD3_INPUT -> if (not eof) then go withBlk ds else return mempty | ||
246 | XD3_OUTPUT -> do | ||
247 | m' <- nextOut (streamArray stream) (\(p,len) -> xOutput x p (fromIntegral len)) | ||
248 | ms <- xInterleave x $ go2 withBlk eof ds | ||
249 | return $ m' <> ms | ||
250 | XD3_GETSRCBLK -> do | ||
251 | Just n <- requestedBlockNumber stream | ||
252 | let blk = xGetSource x n | ||
253 | withBlk' act = withByteString blk $ \p len -> do | ||
254 | pokeCurrentBlock stream $ CurrentBlock n len p | ||
255 | when (len < xBlockSize x) $ do | ||
256 | Just src <- readMutVar $ streamSource stream | ||
257 | sourceWriteEOFKnown src True | ||
258 | act | ||
259 | go2 withBlk' eof ds | ||
260 | XD3_GOTHEADER -> go2 withBlk eof ds -- No | ||
261 | XD3_WINSTART -> go2 withBlk eof ds -- action | ||
262 | XD3_WINFINISH -> go2 withBlk eof ds -- neccessary | ||
263 | -- -- These are set for each XD3_WINFINISH return. | ||
264 | -- xd3_encoder_used_source :: Ptr Stream -> IO Bool | ||
265 | -- xd3_encoder_srcbase :: Ptr Stream -> IO Xoff_t | ||
266 | -- xd3_encoder_srclen :: Ptr Stream -> IO Usize_t | ||
267 | e -> do | ||
268 | s <- errorString (streamArray stream) | ||
269 | xOnError x e s | ||
270 | xInterleave x $ go id ds | ||
271 | -} | ||
272 | 228 | ||
273 | decode_input :: PrimMonad m => Stream m -> m ErrorCode | 229 | decode_input :: PrimMonad m => Stream m -> m ErrorCode |
274 | decode_input stream = | 230 | decode_input stream = |
@@ -329,14 +285,14 @@ xdeltaPure codec cfg source input = | |||
329 | x :: XDeltaMethods (ST s) (Result L.ByteString) | 285 | x :: XDeltaMethods (ST s) (Result L.ByteString) |
330 | x = XDeltaMethods | 286 | x = XDeltaMethods |
331 | { xConfig = cfg | 287 | { xConfig = cfg |
332 | , xGetSource = \i -> case IntMap.lookup (fromIntegral i) smap of | 288 | , xGetSource = \i -> return $ case IntMap.lookup (fromIntegral i) smap of |
333 | Nothing -> B.empty | 289 | Nothing -> B.empty |
334 | Just bs -> bs | 290 | Just bs -> bs |
335 | , xOutput = \ptr len -> unsafeIOToST $ flip Result Nothing . L.fromStrict | 291 | , xOutput = \ptr len -> unsafeIOToST $ flip Result Nothing . L.fromStrict |
336 | <$> B.packCStringLen (castPtr ptr,len) | 292 | <$> B.packCStringLen (castPtr ptr,len) |
337 | , xOnError = \e s -> return (Result L.empty (Just (e,s))) | 293 | , xOnError = \e s -> return (Result L.empty (Just (e,s))) |
338 | , xBlockSize = bsize | 294 | , xBlockSize = bsize |
339 | , xInterleave = id -- unsafeInterleaveST | 295 | , xInterleave = unsafeInterleaveST |
340 | } | 296 | } |
341 | in runST $ xdelta x codec ds | 297 | in runST $ xdelta x codec ds |
342 | 298 | ||