diff options
author | Joe Crayne <joe@jerkface.net> | 2018-10-24 18:15:24 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2018-10-24 18:15:24 -0400 |
commit | 604ab9ded08cf1f2f7ed0f3109d0cc11984f55ea (patch) | |
tree | 859a712b66fe95ec906a8e3d42ba4c71982cbb11 | |
parent | 32e5ed671ff84186c69a066ddab4d57ec3bd73d4 (diff) |
Removed foreign imports of "static" functions.
-rw-r--r-- | examples/testdiff.hs | 23 | ||||
-rw-r--r-- | haskell/Data/XDelta.hsc | 97 | ||||
-rw-r--r-- | haskell/Text/XXD.hs | 48 | ||||
-rw-r--r-- | haskell/XDelta/Types.hsc | 1 | ||||
-rw-r--r-- | xdelta3.cabal | 6 |
5 files changed, 147 insertions, 28 deletions
diff --git a/examples/testdiff.hs b/examples/testdiff.hs new file mode 100644 index 0000000..4ed7dd4 --- /dev/null +++ b/examples/testdiff.hs | |||
@@ -0,0 +1,23 @@ | |||
1 | {-# LANGUAGE OverloadedStrings #-} | ||
2 | |||
3 | import qualified Data.ByteString.Lazy as L | ||
4 | import Data.XDelta | ||
5 | import Text.XXD | ||
6 | |||
7 | source :: L.ByteString | ||
8 | source = "It could be said that Joe was here. I don't know what to do about it." | ||
9 | |||
10 | patched :: L.ByteString | ||
11 | patched = "It could be said that Joe, the magnificent, was here. I don't know what to do about it." | ||
12 | |||
13 | delta :: XDeltaFailable XDelta | ||
14 | delta = computeDiff defaultConfig source patched | ||
15 | |||
16 | main = do | ||
17 | mapM_ putStrLn $ xxd2 0 (L.toStrict source) | ||
18 | putStrLn "" | ||
19 | mapM_ putStrLn $ xxd2 0 (L.toStrict patched) | ||
20 | putStrLn "" | ||
21 | case delta of | ||
22 | XSuccess (XDelta d) -> mapM_ putStrLn $ xxd2 0 (L.toChunks d !! 0) | ||
23 | _ -> print delta | ||
diff --git a/haskell/Data/XDelta.hsc b/haskell/Data/XDelta.hsc index 4d9ffe2..4ebdd51 100644 --- a/haskell/Data/XDelta.hsc +++ b/haskell/Data/XDelta.hsc | |||
@@ -5,6 +5,8 @@ | |||
5 | {-# LANGUAGE NondecreasingIndentation #-} | 5 | {-# LANGUAGE NondecreasingIndentation #-} |
6 | {-# LANGUAGE PatternSynonyms #-} | 6 | {-# LANGUAGE PatternSynonyms #-} |
7 | {-# LANGUAGE RankNTypes #-} | 7 | {-# LANGUAGE RankNTypes #-} |
8 | {-# LANGUAGE FlexibleInstances #-} | ||
9 | {-# LANGUAGE DeriveFunctor #-} | ||
8 | module Data.XDelta where | 10 | module Data.XDelta where |
9 | 11 | ||
10 | import Control.Monad | 12 | import Control.Monad |
@@ -18,6 +20,7 @@ import qualified Data.ByteString.Unsafe as B | |||
18 | import qualified Data.ByteString.Internal as B | 20 | import qualified Data.ByteString.Internal as B |
19 | import qualified Data.ByteString.Lazy as L | 21 | import qualified Data.ByteString.Lazy as L |
20 | import Data.Coerce | 22 | import Data.Coerce |
23 | import Data.Int | ||
21 | import qualified Data.IntMap as IntMap | 24 | import qualified Data.IntMap as IntMap |
22 | import Data.Monoid | 25 | import Data.Monoid |
23 | import Data.Primitive.Addr | 26 | import Data.Primitive.Addr |
@@ -27,6 +30,7 @@ import Data.STRef | |||
27 | import qualified Data.Text as T | 30 | import qualified Data.Text as T |
28 | import Data.Text.Encoding | 31 | import Data.Text.Encoding |
29 | import Data.Word | 32 | import Data.Word |
33 | import Debug.Trace | ||
30 | import Foreign.C.Types | 34 | import Foreign.C.Types |
31 | import Foreign.C.String | 35 | import Foreign.C.String |
32 | import Foreign.ForeignPtr (withForeignPtr) | 36 | import Foreign.ForeignPtr (withForeignPtr) |
@@ -205,23 +209,27 @@ setFlush = setFlag XD3_FLUSH | |||
205 | setSkipWindow :: PrimMonad m => Stream m -> Bool -> m () | 209 | setSkipWindow :: PrimMonad m => Stream m -> Bool -> m () |
206 | setSkipWindow = setFlag XD3_SKIP_WINDOW | 210 | setSkipWindow = setFlag XD3_SKIP_WINDOW |
207 | 211 | ||
208 | foreign import ccall "xdelta3.h xd3_avail_input" xd3_avail_input :: Ptr Xd3Stream -> Ptr a -> Usize_t -> IO () | 212 | -- -- declared static |
213 | -- foreign import ccall "xdelta3.h xd3_avail_input" xd3_avail_input :: Ptr Xd3Stream -> Ptr a -> Usize_t -> IO () | ||
209 | 214 | ||
210 | avail_input :: PrimMonad m => Stream m -> Ptr a -> Usize_t -> m () | 215 | avail_input :: PrimMonad m => Stream m -> Ptr a -> Usize_t -> m () |
211 | avail_input stream p sz = | 216 | avail_input stream p sz = do |
212 | unsafeIOToPrim $ xd3_avail_input (ptr $ mutableByteArrayContents $ streamArray stream) p sz | 217 | writeAtByte (streamArray stream) #{offset xd3_stream, next_in} p |
218 | writeAtByte (streamArray stream) #{offset xd3_stream, avail_in} sz | ||
213 | 219 | ||
214 | -- | This acknowledges receipt of output data, must be called after any | 220 | -- | This acknowledges receipt of output data, must be called after any |
215 | -- XD3_OUTPUT return. | 221 | -- XD3_OUTPUT return. |
216 | foreign import ccall "xdelta3.h xd3_consume_output" xd3_consume_output :: Ptr Xd3Stream -> IO () | 222 | -- -- declared static |
223 | -- foreign import ccall "xdelta3.h xd3_consume_output" xd3_consume_output :: Ptr Xd3Stream -> IO () | ||
217 | 224 | ||
218 | nextOut :: PrimMonad m => Stream m -> ((Ptr Word8, Int) -> m a) -> m a | 225 | nextOut :: PrimMonad m => Stream m -> ((Ptr Word8, Usize_t) -> m a) -> m a |
219 | nextOut stream action = do | 226 | nextOut stream action = do |
220 | buf <- (,) | 227 | buf <- (,) |
221 | <$> readAtByte (streamArray stream) #{offset xd3_stream, next_out} | 228 | <$> readAtByte (streamArray stream) #{offset xd3_stream, next_out} |
222 | <*> readAtByte (streamArray stream) #{offset xd3_stream, avail_out} | 229 | <*> readAtByte (streamArray stream) #{offset xd3_stream, avail_out} |
223 | a <- action buf | 230 | a <- action buf |
224 | unsafeIOToPrim $ xd3_consume_output (ptr $ mutableByteArrayContents $ streamArray stream) | 231 | -- unsafeIOToPrim $ xd3_consume_output (ptr $ mutableByteArrayContents $ streamArray stream) |
232 | writeAtByte (streamArray stream) #{offset xd3_stream, avail_out} (0 :: Usize_t) | ||
225 | return a | 233 | return a |
226 | 234 | ||
227 | 235 | ||
@@ -236,14 +244,17 @@ data CurrentBlock = CurrentBlock | |||
236 | , blkPtr :: !(Ptr Word8) -- ^ current block array | 244 | , blkPtr :: !(Ptr Word8) -- ^ current block array |
237 | } | 245 | } |
238 | 246 | ||
239 | foreign import ccall "xdelta3.h xd3_errstring" xd3_errstring :: Ptr Xd3Stream -> IO CString | 247 | -- -- declared static |
248 | -- foreign import ccall "xdelta3.h xd3_errstring" xd3_errstring :: Ptr Xd3Stream -> IO CString | ||
240 | 249 | ||
241 | -- | Gives some extra information about the latest library error, if any | 250 | -- | Gives some extra information about the latest library error, if any |
242 | -- is known. | 251 | -- is known. |
243 | errorString :: PrimMonad m => Stream m -> m String | 252 | errorString :: PrimMonad m => Stream m -> m String |
244 | errorString stream = unsafeIOToPrim $ do | 253 | errorString stream = do |
245 | cstring <- xd3_errstring (ptr $ mutableByteArrayContents $ streamArray stream) | 254 | cstring <- readAtByte (streamArray stream) #offset xd3_stream, msg |
246 | peekCString cstring | 255 | if cstring /= nullPtr |
256 | then unsafeIOToPrim $ peekCString cstring -- TODO: avoid unsafeIOToPrim | ||
257 | else return "" | ||
247 | 258 | ||
248 | pokeCurrentBlock :: PrimMonad m => Stream m -> CurrentBlock -> m () | 259 | pokeCurrentBlock :: PrimMonad m => Stream m -> CurrentBlock -> m () |
249 | pokeCurrentBlock stream (CurrentBlock no sz ptr) = do | 260 | pokeCurrentBlock stream (CurrentBlock no sz ptr) = do |
@@ -279,14 +290,18 @@ xdelta x xxcode_input ds = do | |||
279 | case ret of | 290 | case ret of |
280 | XD3_INPUT -> if (not eof) then go withBlk ds else return mempty | 291 | XD3_INPUT -> if (not eof) then go withBlk ds else return mempty |
281 | XD3_OUTPUT -> do | 292 | XD3_OUTPUT -> do |
282 | m' <- nextOut stream (uncurry $ xOutput x) | 293 | m' <- nextOut stream (\(p,len) -> xOutput x p (fromIntegral len)) |
283 | ms <- xInterleave x $ go2 withBlk eof ds | 294 | ms <- xInterleave x $ undefined -- go2 withBlk eof ds |
284 | return $ m' <> ms | 295 | return $ trace "chunk" m' <> ms |
296 | -- XXX: This output is to test for laziness. | ||
285 | XD3_GETSRCBLK -> do | 297 | XD3_GETSRCBLK -> do |
286 | Just n <- requestedBlockNumber stream | 298 | Just n <- requestedBlockNumber stream |
287 | let blk = xGetSource x n | 299 | let blk = xGetSource x n |
288 | withBlk' act = withByteString blk $ \p len -> do | 300 | withBlk' act = withByteString blk $ \p len -> do |
289 | pokeCurrentBlock stream $ CurrentBlock n len p | 301 | pokeCurrentBlock stream $ CurrentBlock n len p |
302 | when (len < xBlockSize x) $ do | ||
303 | Just src <- readMutVar $ streamSource stream | ||
304 | writeAtByte src #{offset xd3_source, eof_known} (1 :: #{type int}) | ||
290 | act | 305 | act |
291 | go2 withBlk' eof ds | 306 | go2 withBlk' eof ds |
292 | XD3_GOTHEADER -> go2 withBlk eof ds -- No | 307 | XD3_GOTHEADER -> go2 withBlk eof ds -- No |
@@ -314,29 +329,55 @@ encode_input stream = | |||
314 | unsafeIOToPrim $ xd3_encode_input (ptr $ mutableByteArrayContents $ streamArray stream) | 329 | unsafeIOToPrim $ xd3_encode_input (ptr $ mutableByteArrayContents $ streamArray stream) |
315 | 330 | ||
316 | newtype XDelta = XDelta L.ByteString | 331 | newtype XDelta = XDelta L.ByteString |
332 | deriving Show | ||
317 | 333 | ||
318 | chunksOf :: Usize_t -> L.ByteString -> [B.ByteString] | 334 | chunksOf :: Usize_t -> L.ByteString -> [B.ByteString] |
319 | chunksOf len bs | L.null bs = [] | 335 | chunksOf len bs | L.null bs = [] |
320 | | otherwise = let (b,bs') = L.splitAt (fromIntegral len) bs | 336 | | otherwise = let (b,bs') = L.splitAt (fromIntegral len) bs |
321 | in L.toStrict b : chunksOf len bs' | 337 | in L.toStrict b : chunksOf len bs' |
322 | 338 | ||
323 | computeDiff :: Config -> L.ByteString -> L.ByteString -> XDelta | 339 | computeDiff :: Config -> L.ByteString -> L.ByteString -> XDeltaFailable XDelta |
324 | computeDiff cfg source patched = XDelta $ xdeltaPure cfg source patched | 340 | computeDiff cfg source patched = fmap XDelta $ xdeltaPure encode_input cfg source patched |
325 | 341 | ||
326 | applyPatch :: Config -> L.ByteString -> XDelta -> L.ByteString | 342 | applyPatch :: Config -> L.ByteString -> XDelta -> XDeltaFailable L.ByteString |
327 | applyPatch cfg source (XDelta delta) = xdeltaPure cfg source delta | 343 | applyPatch cfg source (XDelta delta) = xdeltaPure decode_input cfg source delta |
328 | 344 | ||
329 | xdeltaPure :: Config -> L.ByteString -> L.ByteString -> L.ByteString | 345 | data XDeltaFailable x = XError ErrorCode String |
330 | xdeltaPure cfg source delta = | 346 | | XSuccess x |
331 | let smap = IntMap.fromList $ zip [0..] (chunksOf 4096 source) | 347 | deriving (Show,Functor) |
332 | x :: XDeltaMethods (ST s) L.ByteString | 348 | |
349 | instance Monoid x => Monoid (XDeltaFailable x) where | ||
350 | mempty = XSuccess mempty | ||
351 | mappend (XSuccess x) (XSuccess y) = XSuccess $ mappend x y | ||
352 | mappend x@XError{} _ = x | ||
353 | mappend _ y@XError{} = y | ||
354 | |||
355 | xdeltaPure :: (forall s. Stream (ST s) -> ST s ErrorCode) -> Config -> L.ByteString -> L.ByteString -> XDeltaFailable L.ByteString | ||
356 | xdeltaPure codec cfg source delta = | ||
357 | let smap = IntMap.fromList $ zip [0..] (chunksOf 16 source) | ||
358 | x :: XDeltaMethods (ST s) (XDeltaFailable L.ByteString) | ||
333 | x = XDeltaMethods | 359 | x = XDeltaMethods |
334 | { xConfig = cfg | 360 | { xConfig = cfg |
335 | , xGetSource = (smap IntMap.!) . fromIntegral -- :: Xoff_t -> B.ByteString | 361 | , xGetSource = \i -> case IntMap.lookup (fromIntegral i) smap of |
336 | , xOutput = \ptr len -> unsafeIOToST $ L.fromStrict <$> B.packCStringLen (castPtr ptr,len) | 362 | Nothing -> B.empty |
337 | , xOnError = \e s -> return L.empty -- :: ErrorCode -> String -> m u | 363 | Just bs -> bs |
338 | , xBlockSize = 4096 -- :: Usize_t | 364 | , xOutput = \ptr len -> unsafeIOToST $ XSuccess . L.fromStrict <$> B.packCStringLen (castPtr ptr,len) |
339 | , xInterleave = id -- :: forall a. m a -> m a | 365 | , xOnError = \e s -> return (XError e s) -- :: ErrorCode -> String -> m u |
366 | , xBlockSize = 16 -- 4096 -- :: Usize_t | ||
367 | , xInterleave = unsafeInterleaveST -- :: forall a. m a -> m a | ||
368 | -- XXX: Why isn't unsafeInterleaveST making it lazy? | ||
340 | } | 369 | } |
341 | ds = L.toChunks delta | 370 | ds = chunksOf 16 delta -- L.toChunks delta |
342 | in runST $ xdelta x decode_input ds | 371 | in runST $ xdelta x codec ds |
372 | |||
373 | defaultConfig :: Config | ||
374 | defaultConfig = Config | ||
375 | { winsize = 4096 | ||
376 | , sprevsz = 0 | ||
377 | , iopt_size = 0 | ||
378 | , flags = mempty | ||
379 | , sec_data = CompressorConfig 0 0 0 | ||
380 | , sec_inst = CompressorConfig 0 0 0 | ||
381 | , sec_addr = CompressorConfig 0 0 0 | ||
382 | , smatch_cfg = Right SMATCH_DEFAULT | ||
383 | } | ||
diff --git a/haskell/Text/XXD.hs b/haskell/Text/XXD.hs new file mode 100644 index 0000000..77606bf --- /dev/null +++ b/haskell/Text/XXD.hs | |||
@@ -0,0 +1,48 @@ | |||
1 | {-# LANGUAGE RankNTypes #-} | ||
2 | {-# LANGUAGE ScopedTypeVariables #-} | ||
3 | module Text.XXD (xxd, xxd2) where | ||
4 | |||
5 | import Data.ByteArray (ByteArrayAccess) | ||
6 | import qualified Data.ByteArray as BA | ||
7 | import Data.Word | ||
8 | import Data.Bits | ||
9 | import Data.Char | ||
10 | import Text.Printf | ||
11 | |||
12 | nibble :: Word8 -> Char | ||
13 | nibble b = intToDigit (fromIntegral (b .&. 0x0F)) | ||
14 | |||
15 | nibbles :: ByteArrayAccess ba => ba -> String | ||
16 | nibbles xs = unwords $ map (\byte -> [nibble (byte `shiftR` 4), nibble byte]) | ||
17 | $ BA.unpack xs | ||
18 | |||
19 | xxd0 :: (ByteArrayAccess ba) => (forall b. ByteArrayAccess b => b -> String) -> Int -> ba -> [String] | ||
20 | xxd0 tr offset bs | BA.null bs = [] | ||
21 | xxd0 tr offset bs = printf "%03x: %s%s" offset (nibbles xs) (tr xs) | ||
22 | : xxd0 tr (offset + BA.length xs) bs' | ||
23 | where | ||
24 | (xs,bs') = splitAtView 16 bs | ||
25 | |||
26 | splitAtView :: (ByteArrayAccess ba) => Int -> ba -> (BA.View ba, BA.View ba) | ||
27 | splitAtView n bs = (BA.takeView bs n, BA.dropView bs n) | ||
28 | |||
29 | xxd :: ByteArrayAccess a => Int -> a -> [String] | ||
30 | xxd = xxd0 (const "") | ||
31 | |||
32 | -- | like xxd, but also shows ascii | ||
33 | xxd2 :: ByteArrayAccess a => Int -> a -> [String] | ||
34 | xxd2 = xxd0 withAscii | ||
35 | |||
36 | withAscii :: ByteArrayAccess a => a -> [Char] | ||
37 | withAscii row = replicate (50 - 3 * BA.length row) ' ' ++ myunpack row | ||
38 | where | ||
39 | myunpack s = map word8tochar (BA.unpack s) | ||
40 | where word8tochar w | (w .&. 0x80 /= 0) = '.' | ||
41 | word8tochar w = let c = chr (fromIntegral w) | ||
42 | in if isPrint c then c else '.' | ||
43 | |||
44 | {- | ||
45 | main = do | ||
46 | bs <- B.getContents | ||
47 | mapM_ putStrLn $ xxd2 0 bs | ||
48 | -} | ||
diff --git a/haskell/XDelta/Types.hsc b/haskell/XDelta/Types.hsc index 7bb648a..f1d98ce 100644 --- a/haskell/XDelta/Types.hsc +++ b/haskell/XDelta/Types.hsc | |||
@@ -115,6 +115,7 @@ data Config = Config | |||
115 | , smatch_cfg :: Either StringMatcher SMatchSelect -- ^ See enum: use fields below for soft config | 115 | , smatch_cfg :: Either StringMatcher SMatchSelect -- ^ See enum: use fields below for soft config |
116 | } | 116 | } |
117 | 117 | ||
118 | |||
118 | newtype Flags = Flags Word32 | 119 | newtype Flags = Flags Word32 |
119 | deriving (Storable,Eq,Bits,FiniteBits) | 120 | deriving (Storable,Eq,Bits,FiniteBits) |
120 | 121 | ||
diff --git a/xdelta3.cabal b/xdelta3.cabal index 5cc3a30..e773d6e 100644 --- a/xdelta3.cabal +++ b/xdelta3.cabal | |||
@@ -37,3 +37,9 @@ library | |||
37 | build-depends: base >=4.10, bytestring, text, primitive, containers | 37 | build-depends: base >=4.10, bytestring, text, primitive, containers |
38 | default-language: Haskell2010 | 38 | default-language: Haskell2010 |
39 | ghc-options: -Wmissing-signatures | 39 | ghc-options: -Wmissing-signatures |
40 | |||
41 | executable testdiff | ||
42 | main-is: examples/testdiff.hs | ||
43 | other-modules: Text.XXD | ||
44 | hs-source-dirs: haskell examples . | ||
45 | build-depends: base, bytestring, memory, xdelta | ||