build fix

1 files changed, 202 insertions, 0 deletions

diff --git a/haskell/Data/VCDIFF/XDelta.hsc b/haskell/Data/VCDIFF/XDelta.hsc
new file mode 100644
index 0000000..6e32494
--- /dev/null
+++ b/haskell/Data/VCDIFF/XDelta.hsc
@@ -0,0 +1,202 @@
+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE TypeFamilies          #-}
+module Data.VCDIFF.XDelta where
+
+import Control.Monad
+import Control.Monad.Primitive
+import Data.Bits
+import qualified Data.ByteString     as B
+import Data.Coerce
+import Data.Int
+import Data.Primitive.ByteArray
+import Data.Primitive.ByteArray.Util
+import qualified Data.Text           as T
+import Data.Text.Encoding
+import Data.VCDIFF.Types
+import Data.Word
+import Foreign.C.Types
+import Foreign.C.String
+import Foreign.Ptr
+
+#ifndef SIZEOF_SIZE_T
+#define SIZEOF_SIZE_T __SIZEOF_SIZE_T__
+#define SIZEOF_UNSIGNED_INT __SIZEOF_INT__
+#define SIZEOF_UNSIGNED_LONG __SIZEOF_LONG__
+#define SIZEOF_UNSIGNED_LONG_LONG __SIZEOF_LONG_LONG__
+#define static_assert(...)
+#endif
+#include <xdelta3.h>
+
+#include "offset.h"
+
+type instance SizeOf Usize_t              = #const sizeof(usize_t)
+type instance SizeOf (FunPtr a)           = #const sizeof(void(*)())
+type instance SizeOf (Ptr a)              = #const sizeof(void*)
+type instance SizeOf #{type int}          = #const sizeof(int)
+type instance SizeOf #{type unsigned int} = #const sizeof(unsigned int)
+
+
+data Xd3Source
+
+newtype Source m = Source (MutableByteArray (PrimState m))
+
+newSource :: PrimMonad m =>
+                    String  -- ^ name for debug/print purposes.
+                    -> Usize_t -- ^ block size
+                    -> Xoff_t  -- ^ maximum visible buffer (Suggested: set same as block size).
+                               -- Rounds up to approx 16k.
+                    -> m (Source m)
+newSource nm blksz maxwinsz = do
+    let bsname = encodeUtf8 $ T.pack nm
+    src <- newPinnedByteArray $ 1 + B.length bsname + #{const sizeof(xd3_source)}
+    nptr <- writeStringAt src #{const sizeof(xd3_source)} bsname
+    writeAtByte src (#{off xd3_source, blksize    }) blksz
+    writeAtByte src (#{off xd3_source, name       }) nptr
+    writeAtByte src (#{off xd3_source, max_winsize}) maxwinsz
+    writeAtByte src (#{off xd3_source, curblkno   }) (maxBound :: Xoff_t)
+    return $ Source src
+
+sourcePtr :: Source m -> Ptr Xd3Source
+sourcePtr (Source src) = ptr (mutableByteArrayContents src)
+
+sourceRequestedBlocknumber :: PrimMonad m => Source m -> m Xoff_t
+sourceRequestedBlocknumber (Source src) = readAtByte src (#{off xd3_source, getblkno})
+
+data CurrentBlock = CurrentBlock
+    { blkno   :: !Xoff_t      -- ^ current block number
+    , blkSize :: !Usize_t     -- ^ number of bytes on current block: must be >= 0 and <= 'srcBlockSize'
+    , blkPtr  :: !(Ptr Word8) -- ^ current block array
+    }
+
+sourceWriteCurrentBlock :: PrimMonad m => Source m -> CurrentBlock -> m ()
+sourceWriteCurrentBlock (Source src) (CurrentBlock no sz ptr) = do
+    writeAtByte src (#{off xd3_source, curblkno}) no
+    writeAtByte src (#{off xd3_source, onblk})    sz
+    writeAtByte src (#{off xd3_source, curblk})   ptr
+
+sourceWriteEOFKnown :: PrimMonad m => Source m -> Bool -> m ()
+sourceWriteEOFKnown (Source src) False = writeAtByte src (#{off xd3_source, eof_known}) (0 :: #{type int})
+sourceWriteEOFKnown (Source src) True  = writeAtByte src (#{off xd3_source, eof_known}) (1 :: #{type int})
+
+newtype StreamArray m = StreamArray (MutableByteArray (PrimState m))
+
+newStreamArray :: PrimMonad m =>
+                        Maybe String -> m (StreamArray m, CString)
+newStreamArray mmatcher = do
+    let (len,n) = case mmatcher of
+            Just m  -> let n = encodeUtf8 $ T.pack m
+                       in ( #{const sizeof(xd3_stream)} + B.length n + 1
+                          , n )
+            Nothing -> ( #{const sizeof(xd3_stream)}, B.empty )
+    s <- newPinnedByteArray len
+    fillByteArray s 0 #{const sizeof(xd3_stream)} 0
+    nptr <- case mmatcher of
+        Nothing -> writeStringAt s #{const sizeof(xd3_stream)} n
+        Just _  -> return nullPtr
+    return (StreamArray s,nptr)
+
+streamArrayPtr :: StreamArray m -> Ptr Xd3Stream
+streamArrayPtr (StreamArray s) = ptr (mutableByteArrayContents s)
+
+setFlag :: PrimMonad m => Flags -> StreamArray m -> Bool -> m ()
+setFlag b (StreamArray s) wantFlush = do
+    f <- readAtByte s (#{off xd3_stream, flags})
+    writeAtByte s (#{off xd3_stream, flags})
+        . (coerce :: Flags -> Word32)
+        $ if wantFlush then Flags f .|. b
+                       else Flags f .&. complement b
+
+setFlush :: PrimMonad m => StreamArray m -> Bool -> m ()
+setFlush = setFlag XD3_FLUSH
+
+setSkipWindow :: PrimMonad m => StreamArray m -> Bool -> m ()
+setSkipWindow = setFlag XD3_SKIP_WINDOW
+
+
+avail_input :: PrimMonad m => StreamArray m -> Ptr a -> Usize_t -> m ()
+avail_input (StreamArray s) p sz = do
+    writeAtByte s (#{off xd3_stream, next_in}) p
+    writeAtByte s (#{off xd3_stream, avail_in}) sz
+
+
+nextOut :: PrimMonad m => StreamArray m -> ((Ptr Word8, Usize_t) -> m a) -> m a
+nextOut (StreamArray s) action = do
+    buf <- (,)
+        <$> readAtByte s (#{off xd3_stream, next_out})
+        <*> readAtByte s (#{off xd3_stream, avail_out})
+    a <- action buf
+    -- unsafeIOToPrim $ xd3_consume_output (ptr $ mutableByteArrayContents $ streamArray stream)
+    writeAtByte s #{off xd3_stream, avail_out} (0 :: Usize_t)
+    return a
+
+
+-- | Gives some extra information about the latest library error, if any
+-- is known.
+errorString :: PrimMonad m => StreamArray m -> m String
+errorString (StreamArray s) = do
+    cstring <- readAtByte s (#{off xd3_stream, msg})
+    if cstring /= nullPtr
+        then unsafeIOToPrim $ peekCString cstring -- TODO: avoid unsafeIOToPrim
+        else return ""
+
+writeCompressorConfig :: (PrimMonad m, _) => MutableByteArray (PrimState m) -> Offset j -> CompressorConfig -> m ()
+writeCompressorConfig c o sec = do
+    writeAtByte c (o +. #{off xd3_sec_cfg,ngroups}) (ngroups sec)
+    writeAtByte c (o +. #{off xd3_sec_cfg,sector_size}) (sector_size sec)
+    writeAtByte c (o +. #{off xd3_sec_cfg,inefficient}) (inefficient sec)
+
+writeMatcher :: (PrimMonad m, _) => MutableByteArray (PrimState m) -> Offset j -> StringMatcher -> m ()
+writeMatcher c o sm = do
+    -- handled elsewhere: const char *name; <- smName :: String
+    writeAtByte c (o +. #{off xd3_smatcher, string_match }) (smStringMatch sm)
+    writeAtByte c (o +. #{off xd3_smatcher, large_look   }) (smLargeLook sm)
+    writeAtByte c (o +. #{off xd3_smatcher, large_step   }) (smLargeStep sm)
+    writeAtByte c (o +. #{off xd3_smatcher, small_look   }) (smSmallLook sm)
+    writeAtByte c (o +. #{off xd3_smatcher, small_chain  }) (smSmallChain sm)
+    writeAtByte c (o +. #{off xd3_smatcher, small_lchain }) (smSmallLchain sm)
+    writeAtByte c (o +. #{off xd3_smatcher, max_lazy     }) (smMaxLazy sm)
+    writeAtByte c (o +. #{off xd3_smatcher, long_enough  }) (smLongEnough sm)
+
+packConfig :: PrimMonad m => CString -- ^ Name of software matcher or nullPtr.
+                          -> Config
+                          -> m ByteArray
+packConfig nptr cfg = do
+    c <- newPinnedByteArray #const sizeof(xd3_config)
+    fillByteArray c 0 #{const sizeof(xd3_config)} 0
+    writeAtByte c #{off xd3_config, winsize} (winsize cfg)
+    writeAtByte c #{off xd3_config, sprevsz} (sprevsz cfg)
+    writeAtByte c #{off xd3_config, iopt_size} (iopt_size cfg)
+    writeAtByte c #{off xd3_config, flags} (coerce (flags cfg) :: Word32)
+    writeCompressorConfig c #{off xd3_config, sec_data} (sec_data cfg)
+    writeCompressorConfig c #{off xd3_config, sec_inst} (sec_inst cfg)
+    writeCompressorConfig c #{off xd3_config, sec_addr} (sec_addr cfg)
+    let msel :: #type xd3_smatch_cfg
+        msel = either (const #{const XD3_SMATCH_SOFT})
+                      (fromIntegral . fromEnum)
+                      (smatch_cfg cfg)
+    writeAtByte c (#{off xd3_config, smatch_cfg}) msel
+    let mmatcher = either Just (const Nothing) $ smatch_cfg cfg
+    forM_ mmatcher $ \matcher -> do
+            let o = #off xd3_config,smatcher_soft
+            writeAtByte c (o +. (#{off xd3_smatcher, name})) nptr
+            writeMatcher c o matcher
+    unsafeFreezeByteArray c
+
+foreign import ccall "xdelta3.h xd3_config_stream" xd3_config_stream :: Ptr Xd3Stream -> Ptr Config -> IO ErrorCode
+
+foreign import ccall "xdelta3.h xd3_free_stream" xd3_free_stream :: Ptr Xd3Stream -> IO ()
+
+foreign import ccall "xdelta3.h xd3_abort_stream" xd3_abort_stream :: Ptr Xd3Stream -> IO ()
+
+foreign import ccall "xdelta3.h xd3_close_stream" xd3_close_stream :: Ptr Xd3Stream -> IO ErrorCode
+
+
+foreign import ccall "xdelta3.h xd3_decode_input" xd3_decode_input  :: Ptr Xd3Stream -> IO ErrorCode
+foreign import ccall "xdelta3.h xd3_encode_input" xd3_encode_input  :: Ptr Xd3Stream -> IO ErrorCode
+
+
+foreign import ccall "xdelta3.h xd3_set_source" xd3_set_source :: Ptr Xd3Stream -> Ptr Xd3Source -> IO ErrorCode
+
+