Reorganizing.

8 files changed, 147 insertions, 82 deletions

diff --git a/examples/testdiff.hs b/examples/testdiff.hs
index 2847fc3..7e20dc5 100644
--- a/examples/testdiff.hs
+++ b/examples/testdiff.hs
@@ -1,7 +1,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 import qualified Data.ByteString.Lazy as L
-import Data.XDelta
+import Data.VCDIFF
 import Text.XXD
 
 source :: L.ByteString
diff --git a/haskell/Data/BA.hs b/haskell/Data/BA.hs
deleted file mode 100644
index 60b1136..0000000
--- a/haskell/Data/BA.hs
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# LANGUAGE MagicHash           #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-module Data.BA where
-
-import GHC.Exts
-import Control.Monad.Primitive
-import Data.Primitive.Types
-import Data.Primitive.ByteArray
-
--- | WARNING: Unsafe to use this on packed C structs.
-writeAtByte :: (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> a -> m ()
-writeAtByte buf offset a = writeByteArray buf (div offset $ I# (sizeOf# a)) a
-{-# INLINE writeAtByte #-}
-
-readAtByte :: forall a m. (Prim a, PrimMonad m) => MutableByteArray (PrimState m) -> Int -> m a
-readAtByte buf offset = readByteArray buf (div offset $ I# (sizeOf# (undefined :: a)))
-{-# INLINE readAtByte #-}
diff --git a/haskell/Data/Primitive/ByteArray/Util.hs b/haskell/Data/Primitive/ByteArray/Util.hs
new file mode 100644
index 0000000..1776286
--- /dev/null
+++ b/haskell/Data/Primitive/ByteArray/Util.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE KindSignatures        #-}
+{-# LANGUAGE MagicHash             #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeOperators         #-}
+module Data.Primitive.ByteArray.Util where
+
+import GHC.TypeLits
+import Control.Monad.Primitive
+import Data.Primitive.Types
+import Data.Primitive.ByteArray
+
+newtype Offset (n :: Nat) = Offset Int
+
+offset :: KnownNat n => Offset n
+offset = let k = Offset $ fromIntegral $ natVal k in k
+
+(+.) :: Offset j -> Offset k -> Offset (j + k)
+Offset j +. Offset k = Offset (j + k)
+
+
+type family SizeOf a :: Nat
+
+class IsMultipleOf (n::Nat) (k::Nat)
+
+instance n ~ (q * k) => IsMultipleOf n k
+
+writeAtByte :: ( Prim a
+               , PrimMonad m
+               , IsMultipleOf n (SizeOf a)
+               ) => MutableByteArray (PrimState m) -> Offset n -> a -> m ()
+writeAtByte buf (Offset offset) a = writeByteArray buf (div offset $ (sizeOf a)) a
+{-# INLINE writeAtByte #-}
+
+readAtByte :: forall a m n.
+               ( Prim a
+               , PrimMonad m
+               , IsMultipleOf n (SizeOf a)
+               ) => MutableByteArray (PrimState m) -> Offset n -> m a
+readAtByte buf (Offset offset) = readByteArray buf (div offset $ (sizeOf (undefined :: a)))
+{-# INLINE readAtByte #-}
diff --git a/haskell/Data/XDelta.hsc b/haskell/Data/VCDIFF.hsc
index 8128a61..5e484e1 100644
--- a/haskell/Data/XDelta.hsc
+++ b/haskell/Data/VCDIFF.hsc
@@ -1,19 +1,24 @@
+{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
 {-# LANGUAGE BangPatterns               #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE NondecreasingIndentation   #-}
+{-# LANGUAGE PartialTypeSignatures      #-}
 {-# LANGUAGE PatternSynonyms            #-}
 {-# LANGUAGE RankNTypes                 #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE DeriveFunctor #-}
-module Data.XDelta where
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeOperators              #-}
+module Data.VCDIFF where
 
 import Control.Monad
 import Control.Monad.Primitive
 import Control.Monad.ST
 import Control.Monad.ST.Unsafe
-import Data.BA
 import Data.Bits
 import qualified Data.ByteString as B
 import qualified Data.ByteString.Unsafe as B
@@ -25,6 +30,7 @@ import qualified Data.IntMap as IntMap
 import Data.Monoid
 import Data.Primitive.Addr
 import Data.Primitive.ByteArray
+import Data.Primitive.ByteArray.Util
 import Data.Primitive.MutVar
 import Data.STRef
 import qualified Data.Text as T
@@ -38,8 +44,9 @@ import Foreign.Concurrent
 import Foreign.Storable
 import Foreign.ForeignPtr (ForeignPtr)
 import GHC.Exts
+import GHC.TypeLits
 
-import XDelta.Types
+import Data.VCDIFF.Types
 
 #ifndef SIZEOF_SIZE_T
 #define SIZEOF_SIZE_T __SIZEOF_SIZE_T__
@@ -50,6 +57,8 @@ import XDelta.Types
 #endif
 #include <xdelta3.h>
 
+#include "offset.h"
+
 data Stream m = Stream
     { streamArray  :: MutableByteArray (PrimState m)
     , streamPtr    :: ForeignPtr Xd3Stream -- ^ HACK: this is only used to attach a finalizer
@@ -67,26 +76,31 @@ foreign import ccall "xdelta3.h xd3_abort_stream" xd3_abort_stream :: Ptr Xd3Str
 
 foreign import ccall "xdelta3.h xd3_close_stream" xd3_close_stream :: Ptr Xd3Stream -> IO ErrorCode
 
+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)
+
+
 
-writeCompressorConfig :: PrimMonad m =>
-                               MutableByteArray (PrimState m) -> Int -> CompressorConfig -> m ()
+writeCompressorConfig :: (PrimMonad m, _) => MutableByteArray (PrimState m) -> Offset j -> CompressorConfig -> m ()
 writeCompressorConfig c o sec = do
-    writeAtByte c (o + #{offset xd3_sec_cfg,ngroups}) (ngroups sec)
-    writeAtByte c (o + #{offset xd3_sec_cfg,sector_size}) (sector_size sec)
-    writeAtByte c (o + #{offset xd3_sec_cfg,inefficient}) (inefficient sec)
+    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) -> Int -> StringMatcher -> m ()
+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 + #{offset xd3_smatcher, string_match }) (smStringMatch sm)
-    writeAtByte c (o + #{offset xd3_smatcher, large_look   }) (smLargeLook sm)
-    writeAtByte c (o + #{offset xd3_smatcher, large_step   }) (smLargeStep sm)
-    writeAtByte c (o + #{offset xd3_smatcher, small_look   }) (smSmallLook sm)
-    writeAtByte c (o + #{offset xd3_smatcher, small_chain  }) (smSmallChain sm)
-    writeAtByte c (o + #{offset xd3_smatcher, small_lchain }) (smSmallLchain sm)
-    writeAtByte c (o + #{offset xd3_smatcher, max_lazy     }) (smMaxLazy sm)
-    writeAtByte c (o + #{offset xd3_smatcher, long_enough  }) (smLongEnough sm)
+    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)
 
 ptr :: Addr -> Ptr a
 ptr (Addr a) = Ptr a
@@ -113,23 +127,23 @@ config_stream cfg = do
     c <- do
         c <- newPinnedByteArray #const sizeof(xd3_config)
         fillByteArray c 0 #{const sizeof(xd3_config)} 0
-        writeAtByte c #{offset xd3_config, winsize} (winsize cfg)
-        writeAtByte c #{offset xd3_config, sprevsz} (sprevsz cfg)
-        writeAtByte c #{offset xd3_config, iopt_size} (iopt_size cfg)
-        writeAtByte c #{offset xd3_config, flags} (coerce (flags cfg) :: Word32)
-        writeCompressorConfig c #{offset xd3_config, sec_data} (sec_data cfg)
-        writeCompressorConfig c #{offset xd3_config, sec_inst} (sec_inst cfg)
-        writeCompressorConfig c #{offset xd3_config, sec_addr} (sec_addr cfg)
+        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 #{offset xd3_config, smatch_cfg} msel
+        writeAtByte c (#{off xd3_config, smatch_cfg}) msel
         case smatch_cfg cfg of
             Right _      -> return ()
             Left matcher -> do
-                let o = #offset xd3_config,smatcher_soft
-                writeAtByte c (o + #{offset xd3_smatcher, name}) nptr
+                let o = offset :: Offset #offset xd3_config,smatcher_soft
+                writeAtByte c (o +. (#{off xd3_smatcher, name})) nptr
                 writeMatcher c o matcher
         unsafeFreezeByteArray c
     let cptr = ptr (byteArrayContents c) :: Ptr Config
@@ -173,10 +187,10 @@ set_source stream 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 #{offset xd3_source, blksize    } blksz
-    writeAtByte src #{offset xd3_source, name       } nptr
-    writeAtByte src #{offset xd3_source, max_winsize} maxwinsz
-    writeAtByte src #{offset xd3_source, curblkno   } (maxBound :: Xoff_t)
+    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)
     {-
     writeAtByte (streamArray stream)
                 #{offset xd3_stream, getblk}
@@ -201,8 +215,8 @@ data XDeltaMethods m u = XDeltaMethods
 
 setFlag :: PrimMonad m => Flags -> Stream m -> Bool -> m ()
 setFlag b stream wantFlush = do
-    f <- readAtByte (streamArray stream) #{offset xd3_stream, flags}
-    writeAtByte (streamArray stream) #{offset xd3_stream, flags}
+    f <- readAtByte (streamArray stream) (#{off xd3_stream, flags})
+    writeAtByte (streamArray stream) (#{off xd3_stream, flags})
         . (coerce :: Flags -> Word32)
         $ if wantFlush then Flags f .|. b
                        else Flags f .&. complement b
@@ -218,8 +232,8 @@ setSkipWindow = setFlag XD3_SKIP_WINDOW
 
 avail_input :: PrimMonad m => Stream m -> Ptr a -> Usize_t -> m ()
 avail_input stream p sz = do
-    writeAtByte (streamArray stream) #{offset xd3_stream, next_in} p
-    writeAtByte (streamArray stream) #{offset xd3_stream, avail_in} sz
+    writeAtByte (streamArray stream) (#{off xd3_stream, next_in}) p
+    writeAtByte (streamArray stream) (#{off xd3_stream, avail_in}) sz
 
 -- | This acknowledges receipt of output data, must be called after any
 -- XD3_OUTPUT return.
@@ -229,18 +243,18 @@ avail_input stream p sz = do
 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}
+        <$> readAtByte (streamArray stream) (#{off xd3_stream, next_out})
+        <*> readAtByte (streamArray stream) (#{off xd3_stream, avail_out})
     a <- action buf
     -- unsafeIOToPrim $ xd3_consume_output (ptr $ mutableByteArrayContents $ streamArray stream)
-    writeAtByte (streamArray stream) #{offset xd3_stream, avail_out} (0 :: Usize_t)
+    writeAtByte (streamArray stream) (#{off xd3_stream, avail_out}) (0 :: Usize_t)
     return a
 
 
 requestedBlockNumber :: PrimMonad m => Stream m -> m (Maybe Xoff_t)
 requestedBlockNumber stream = do
     msrc <- readMutVar $ streamSource stream
-    forM msrc $ \src -> readAtByte src #offset xd3_source, getblkno
+    forM msrc $ \src -> readAtByte src (#{off xd3_source, getblkno})
 
 data CurrentBlock = CurrentBlock
     { blkno   :: !Xoff_t      -- ^ current block number
@@ -255,7 +269,7 @@ data CurrentBlock = CurrentBlock
 -- is known.
 errorString :: PrimMonad m => Stream m -> m String
 errorString stream = do
-    cstring <- readAtByte (streamArray stream) #offset xd3_stream, msg
+    cstring <- readAtByte (streamArray stream) (#{off xd3_stream, msg})
     if cstring /= nullPtr
         then unsafeIOToPrim $ peekCString cstring -- TODO: avoid unsafeIOToPrim
         else return ""
@@ -264,9 +278,9 @@ pokeCurrentBlock :: PrimMonad m => Stream m -> CurrentBlock -> m ()
 pokeCurrentBlock stream (CurrentBlock no sz ptr) = do
     msrc <- readMutVar $ streamSource stream
     forM_ msrc $ \src -> do
-        writeAtByte src #{offset xd3_source, curblkno} no
-        writeAtByte src #{offset xd3_source, onblk}    sz
-        writeAtByte src #{offset xd3_source, curblk}   ptr
+        writeAtByte src (#{off xd3_source, curblkno}) no
+        writeAtByte src (#{off xd3_source, onblk})    sz
+        writeAtByte src (#{off xd3_source, curblk})   ptr
 
 
 withByteString :: PrimBase m => B.ByteString -> (Ptr b -> Usize_t -> m a) -> m a
@@ -305,7 +319,7 @@ xdelta x xxcode_input ds = 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})
+                                        writeAtByte src (#{off xd3_source, eof_known}) (1 :: #{type int})
                                     act
                     go2 withBlk' eof ds
                 XD3_GOTHEADER -> go2 withBlk eof ds -- No
diff --git a/haskell/XDelta/Types.hsc b/haskell/Data/VCDIFF/Types.hsc
index 8a60805..015f406 100644
--- a/haskell/XDelta/Types.hsc
+++ b/haskell/Data/VCDIFF/Types.hsc
@@ -3,7 +3,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE PatternSynonyms            #-}
-module XDelta.Types where
+module Data.VCDIFF.Types where
 
 import Control.Exception
 import Control.Monad
diff --git a/haskell/offset.h b/haskell/offset.h
new file mode 100644
index 0000000..0f344a2
--- /dev/null
+++ b/haskell/offset.h
@@ -0,0 +1,2 @@
+
+#define hsc_off(t, f) hsc_printf("(Offset (%ld) :: Offset (%ld))", (long) offsetof (t, f), (long) offsetof (t, f));
diff --git a/lazy.hs b/lazy.hs
new file mode 100644
index 0000000..5bbfa51
--- /dev/null
+++ b/lazy.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE NoMonomorphismRestriction #-}
+import Control.Monad.ST
+import Control.Monad.ST.Unsafe
+import Data.VCDIFF
+import qualified Data.ByteString as B
+
+step2 = undefined
+
+step1 = do
+    xs <- unsafeInterleaveST $ step2
+    return $ 3 : xs
+
+test f = do
+    xs <- f $ step2
+    return $ 3 : xs
+
+test2 f = withByteString B.empty $ \_ _ -> do
+    xs <- f $ step2
+    return $ 3 : xs
+
+main = do
+    let xs = runST step1
+        ys = runST (test id)
+        zs = runST (test unsafeInterleaveST)
+        vs = runST (test2 unsafeInterleaveST)
+    print $ take 1 xs
+    -- print $ take 1 ys
+    print $ take 1 zs
+    print $ take 1 vs
+
diff --git a/xdelta3.cabal b/xdelta3.cabal
index bc8a81b..6907ebc 100644
--- a/xdelta3.cabal
+++ b/xdelta3.cabal
@@ -1,36 +1,27 @@
 cabal-version:       2.2
 name:                xdelta
-version:             3.2.0
+version:             3.1.0
 synopsis:            VCDIFF encoder/decoder.
 -- description:
 homepage:            xdelta.org
 license:             Apache-2.0
 license-file:        xdelta3/LICENSE
-author:              Josh MacDonald
-maintainer:          josh.macdonald@gmail.com
--- copyright:
+author:              Joe Crayne
+maintainer:          joe@jerkface.net
 category:            Data
--- build-type:          Custom
 build-type:          Simple
 
 extra-source-files:  xdelta3/*.h xdelta3/*.c
 
 library
-  exposed-modules:  XDelta.Types
-                  , Data.XDelta
-                  , Data.BA
+  exposed-modules:  Data.VCDIFF.Types
+                  , Data.VCDIFF
+                  , Data.Primitive.ByteArray.Util
 
   build-tools: hsc2hs
-  -- include-dirs: xdelta3 xdelta3_lib
-  -- extra-lib-dirs: xdelta3_lib
   include-dirs: haskell .
-  -- cc-options:  -std=c++14 -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__
-  -- -DHAVE_CONFIG_H=1
-  -- -include xdelta3/build2/config.h -Wall -Wshadow -fno-builtin -Wextra -Wsign-compare -Wformat=2 -Wno-format-nonliteral -Wno-unused-parameter -Wno-unused-function extra-libraries: xdelta3, lzma, stdc++, m
+  cxx-options: -Wno-literal-suffix -g
   cxx-sources: haskell/xdelta3.cc
 
   hs-source-dirs:      haskell