Removed foreign imports of "static" functions.

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 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+import qualified Data.ByteString.Lazy as L
+import Data.XDelta
+import Text.XXD
+
+source :: L.ByteString
+source = "It could be said that Joe was here. I don't know what to do about it."
+
+patched :: L.ByteString
+patched = "It could be said that Joe, the magnificent, was here.  I don't know what to do about it."
+
+delta :: XDeltaFailable XDelta
+delta = computeDiff defaultConfig source patched
+
+main = do
+    mapM_ putStrLn $ xxd2 0 (L.toStrict source)
+    putStrLn ""
+    mapM_ putStrLn $ xxd2 0 (L.toStrict patched)
+    putStrLn ""
+    case delta of
+        XSuccess (XDelta d) -> mapM_ putStrLn $ xxd2 0 (L.toChunks d !! 0)
+        _                   -> 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 @@
 {-# LANGUAGE NondecreasingIndentation   #-}
 {-# LANGUAGE PatternSynonyms            #-}
 {-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveFunctor #-}
 module Data.XDelta where
 
 import Control.Monad
@@ -18,6 +20,7 @@ import qualified Data.ByteString.Unsafe as B
 import qualified Data.ByteString.Internal as B
 import qualified Data.ByteString.Lazy as L
 import Data.Coerce
+import Data.Int
 import qualified Data.IntMap as IntMap
 import Data.Monoid
 import Data.Primitive.Addr
@@ -27,6 +30,7 @@ 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)
@@ -205,23 +209,27 @@ setFlush = setFlag XD3_FLUSH
 setSkipWindow :: PrimMonad m => Stream m -> Bool -> m ()
 setSkipWindow = setFlag XD3_SKIP_WINDOW
 
-foreign import ccall "xdelta3.h xd3_avail_input" xd3_avail_input :: Ptr Xd3Stream -> Ptr a -> Usize_t -> IO ()
+-- -- declared static
+-- foreign import ccall "xdelta3.h xd3_avail_input" xd3_avail_input :: Ptr Xd3Stream -> Ptr a -> Usize_t -> IO ()
 
 avail_input :: PrimMonad m => Stream m -> Ptr a -> Usize_t -> m ()
-avail_input stream p sz =
-    unsafeIOToPrim $ xd3_avail_input (ptr $ mutableByteArrayContents $ streamArray stream) p sz
+avail_input stream p sz = do
+    writeAtByte (streamArray stream) #{offset xd3_stream, next_in} p
+    writeAtByte (streamArray stream) #{offset xd3_stream, avail_in} sz
 
 -- | 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 ()
+-- -- declared static
+-- 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 :: PrimMonad m => Stream m -> ((Ptr Word8, Usize_t) -> 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)
+    -- unsafeIOToPrim $ xd3_consume_output (ptr $ mutableByteArrayContents $ streamArray stream)
+    writeAtByte (streamArray stream) #{offset xd3_stream, avail_out} (0 :: Usize_t)
     return a
 
 
@@ -236,14 +244,17 @@ data CurrentBlock = CurrentBlock
     , blkPtr  :: !(Ptr Word8) -- ^ current block array
     }
 
-foreign import ccall "xdelta3.h xd3_errstring" xd3_errstring :: Ptr Xd3Stream -> IO CString
+-- -- declared static
+-- 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 :: PrimMonad m => Stream m -> m String
-errorString stream = unsafeIOToPrim $ do
-    cstring <- xd3_errstring (ptr $ mutableByteArrayContents $ streamArray stream)
-    peekCString cstring
+errorString stream = do
+    cstring <- readAtByte (streamArray stream) #offset xd3_stream, msg
+    if cstring /= nullPtr
+        then unsafeIOToPrim $ peekCString cstring -- TODO: avoid unsafeIOToPrim
+        else return ""
 
 pokeCurrentBlock :: PrimMonad m => Stream m -> CurrentBlock -> m ()
 pokeCurrentBlock stream (CurrentBlock no sz ptr) = do
@@ -279,14 +290,18 @@ xdelta x xxcode_input ds = do
             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 <- xInterleave x $ go2 withBlk eof ds
-                    return $ m' <> ms
+                    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.
                 XD3_GETSRCBLK -> do
                     Just n <- requestedBlockNumber stream
                     let blk = xGetSource x n
                         withBlk' act = withByteString blk $ \p len -> do
                                     pokeCurrentBlock stream $ CurrentBlock n len p
+                                    when (len < xBlockSize x) $ do
+                                        Just src <- readMutVar $ streamSource stream
+                                        writeAtByte src #{offset xd3_source, eof_known} (1 :: #{type int})
                                     act
                     go2 withBlk' eof ds
                 XD3_GOTHEADER -> go2 withBlk eof ds -- No
@@ -314,29 +329,55 @@ encode_input stream =
     unsafeIOToPrim $ xd3_encode_input (ptr $ mutableByteArrayContents $ streamArray stream)
 
 newtype XDelta = XDelta L.ByteString
+ deriving Show
 
 chunksOf :: Usize_t -> L.ByteString -> [B.ByteString]
 chunksOf len bs | L.null bs = []
                 | otherwise = let (b,bs') = L.splitAt (fromIntegral len) bs
                               in L.toStrict b : chunksOf len bs'
 
-computeDiff :: Config -> L.ByteString -> L.ByteString -> XDelta
-computeDiff cfg source patched = XDelta $ xdeltaPure cfg source patched
+computeDiff :: Config -> L.ByteString -> L.ByteString -> XDeltaFailable XDelta
+computeDiff cfg source patched = fmap XDelta $ xdeltaPure encode_input cfg source patched
 
-applyPatch :: Config -> L.ByteString -> XDelta -> L.ByteString
-applyPatch cfg source (XDelta delta) = xdeltaPure cfg source delta
+applyPatch :: Config -> L.ByteString -> XDelta -> XDeltaFailable L.ByteString
+applyPatch cfg source (XDelta delta) = xdeltaPure decode_input cfg source delta
 
-xdeltaPure :: Config -> L.ByteString -> L.ByteString -> L.ByteString
-xdeltaPure cfg source delta =
-    let smap = IntMap.fromList $ zip [0..] (chunksOf 4096 source)
-        x :: XDeltaMethods (ST s) L.ByteString
+data XDeltaFailable x = XError ErrorCode String
+                      | XSuccess x
+    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
+
+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)
+        x :: XDeltaMethods (ST s) (XDeltaFailable L.ByteString)
         x = XDeltaMethods
                 { xConfig    = cfg
-                , xGetSource = (smap IntMap.!) . fromIntegral -- :: Xoff_t -> B.ByteString
-                , xOutput    = \ptr len -> unsafeIOToST $ L.fromStrict <$> B.packCStringLen (castPtr ptr,len)
-                , xOnError   = \e s -> return L.empty -- :: ErrorCode -> String -> m u
-                , xBlockSize = 4096 -- :: Usize_t
-                , xInterleave = id -- :: forall a. m a -> m a
+                , 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
+                , xInterleave = unsafeInterleaveST -- :: forall a. m a -> m a
+                -- XXX: Why isn't unsafeInterleaveST making it lazy?
                 }
-        ds = L.toChunks delta
-    in runST $ xdelta x decode_input ds
+        ds = chunksOf 16 delta -- L.toChunks delta
+    in runST $ xdelta x codec ds
+
+defaultConfig :: Config
+defaultConfig = Config
+  { winsize   = 4096
+  , sprevsz   = 0
+  , iopt_size = 0
+  , flags     = mempty
+  , sec_data  = CompressorConfig 0 0 0
+  , sec_inst  = CompressorConfig 0 0 0
+  , sec_addr  = CompressorConfig 0 0 0
+  , smatch_cfg = Right SMATCH_DEFAULT
+  }
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 @@
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Text.XXD (xxd, xxd2) where
+
+import Data.ByteArray (ByteArrayAccess)
+import qualified Data.ByteArray as BA
+import Data.Word
+import Data.Bits
+import Data.Char
+import Text.Printf
+
+nibble :: Word8 -> Char
+nibble b = intToDigit (fromIntegral (b .&. 0x0F))
+
+nibbles :: ByteArrayAccess ba => ba -> String
+nibbles xs = unwords $ map (\byte -> [nibble (byte `shiftR` 4), nibble byte])
+                     $ BA.unpack xs
+
+xxd0 :: (ByteArrayAccess ba) => (forall b. ByteArrayAccess b => b -> String) -> Int -> ba -> [String]
+xxd0 tr offset bs | BA.null bs = []
+xxd0 tr offset bs              = printf "%03x: %s%s" offset (nibbles xs) (tr xs)
+                                 : xxd0 tr (offset + BA.length xs) bs'
+ where
+    (xs,bs') = splitAtView 16 bs
+
+splitAtView :: (ByteArrayAccess ba) => Int -> ba -> (BA.View ba, BA.View ba)
+splitAtView n bs = (BA.takeView bs n, BA.dropView bs n)
+
+xxd :: ByteArrayAccess a => Int -> a -> [String]
+xxd = xxd0 (const "")
+
+-- | like xxd, but also shows ascii
+xxd2 :: ByteArrayAccess a => Int -> a -> [String]
+xxd2 = xxd0 withAscii
+
+withAscii :: ByteArrayAccess a => a -> [Char]
+withAscii row = replicate (50 - 3 * BA.length row) ' ' ++ myunpack row
+    where
+        myunpack s = map word8tochar (BA.unpack s)
+            where word8tochar w | (w .&. 0x80 /= 0) = '.'
+                  word8tochar w = let c = chr (fromIntegral w)
+                                      in if isPrint c then c else '.'
+
+{-
+main = do
+    bs <- B.getContents
+    mapM_ putStrLn $ xxd2 0 bs
+    -}
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
   , smatch_cfg :: Either StringMatcher SMatchSelect -- ^  See enum: use fields below  for soft config
   }
 
+
 newtype Flags = Flags Word32
     deriving (Storable,Eq,Bits,FiniteBits)
 
diff --git a/xdelta3.cabal b/xdelta3.cabal
index 5cc3a30..e773d6e 100644
--- a/xdelta3.cabal
+++ b/xdelta3.cabal
@@ -37,3 +37,9 @@ library
   build-depends:       base >=4.10, bytestring, text, primitive, containers
   default-language:    Haskell2010
   ghc-options: -Wmissing-signatures
+
+executable testdiff
+  main-is: examples/testdiff.hs
+  other-modules: Text.XXD
+  hs-source-dirs: haskell examples .
+  build-depends: base, bytestring, memory, xdelta