formatting tweaks

src/IPS/Apply.hs

@@ -11,22 +11,6 @@ import Data.Foldable
 
 type BytesM m = MVector (PrimState m) Word8
 
--- explodes if the patch tries to write outside the existing space
-unsafeApplyM :: PrimMonad m => Patch -> BytesM m -> m ()
-unsafeApplyM p buf =
-  for_ p \Chunk {offset, body} ->
-    case body of
-      Normal bs -> do
-        let offset' = fromIntegral offset
-        let sz = Vector.length bs
-        let dst = MVector.slice offset' sz buf
-        Vector.copy dst bs
-      RLE {size, value} -> do
-        let offset' = fromIntegral offset
-        let sz = fromIntegral size
-        let dst = MVector.slice offset' sz buf
-        MVector.set dst value
-
 -- size of patch output
 -- (patches can write past the end of the input file)
 outSize :: Patch -> Int
@@ -36,27 +20,41 @@ outSize = foldl' (\m c -> max m (end c)) 0 where
     RLE {size} -> offset' + fromIntegral size
     where offset' = fromIntegral offset
 
+
 -- applies in place if it fits, otherwise allocates a new buffer for it
+-- returns 'Nothing' if the contents are in the original buffer
 applyM :: PrimMonad m => Patch -> BytesM m -> m (Maybe (BytesM m))
-applyM p buf = do
+applyM patch buf = do
-  let size = outSize p
+  (buf', realloc) <- maybeNewBuf buf $ outSize patch
-  (buf', realloc) <-
+  unsafeApplyM patch buf'
-    if MVector.length buf >= size then
-      pure (buf, False)
-    else do
-      newBuf <- MVector.new size
-      let dst = MVector.slice 0 (MVector.length buf) newBuf
-      MVector.copy dst buf
-      pure (newBuf, True)
-  unsafeApplyM p buf'
   pure $ if realloc then Just buf' else Nothing
 
+-- if the buffer is smaller than the given size, then allocate a new one
+-- of that size and copy the contents to the beginning of it
+maybeNewBuf :: PrimMonad m => BytesM m -> Int -> m (BytesM m, Bool)
+maybeNewBuf buf size
+  | MVector.length buf >= size = pure (buf, False)
+  | otherwise = do
+      newBuf <- MVector.new size
+      MVector.copy (MVector.slice 0 (MVector.length buf) newBuf) buf
+      pure (newBuf, True)
+
+
 -- copies an immutable vector (resizing if needed) and patches it
 apply :: Patch -> Bytes -> Bytes
-apply p inp = runST do
+apply patch input = runST do
-  let size = outSize p `max` Vector.length inp
+  buf <- MVector.new $ outSize patch `max` Vector.length input
-  buf <- MVector.new size
+  Vector.copy (MVector.slice 0 (Vector.length input) buf) input
-  let dst = MVector.slice 0 (Vector.length inp) buf
+  unsafeApplyM patch buf
-  Vector.copy dst inp
-  unsafeApplyM p buf
   Vector.unsafeFreeze buf
+
+
+-- explodes if the patch tries to write outside the existing space
+unsafeApplyM :: PrimMonad m => Patch -> BytesM m -> m ()
+unsafeApplyM patch buf =
+  for_ patch \Chunk {offset, body} ->
+    let makeSlice size = MVector.slice (fromIntegral offset) size buf in
+    case body of
+      Normal bs         -> Vector.copy (makeSlice $ Vector.length bs) bs
+      RLE {size, value} -> MVector.set (makeSlice $ fromIntegral size) value
+

src/IPS/Parse.hs

@@ -1,41 +1,51 @@
-module IPS.Parse (parser, read) where
+module IPS.Parse (parser, parseFile) where
 
-import Prelude hiding (read)
 import IPS.Types
 import Data.Attoparsec.ByteString (Parser)
 import qualified Data.Attoparsec.ByteString as Parse
 import Data.Bits
 import qualified Data.ByteString as ByteString
-import Data.Functor
+import Data.Vector (Vector)
-import qualified Data.Vector.Generic as Vector
+import qualified Data.Vector as Vector
 import Control.Applicative
 
 
-read :: FilePath -> IO (Either String Patch)
+parseFile :: FilePath -> IO (Either String Patch)
-read f = Parse.parseOnly parser <$> ByteString.readFile f
+parseFile f = Parse.parseOnly parser <$> ByteString.readFile f
 
 
 parser :: Parser Patch
-parser = Parse.string "PATCH" *> parseBody
+parser = Parse.string "PATCH" *> parseRest
 
-parseBody :: Parser Patch
+
-parseBody = uncurry Vector.fromListN <$> go where
+parseRest :: Parser Patch
+parseRest = make <$> go where
   go    = eof <|> chunk
-  eof = Parse.string "EOF" $> (0, [])
+  eof   = Rest 0 [] <$ Parse.string "EOF"
-  chunk = liftA2 cons parseChunk go
+  chunk = cons <$> parseChunk <*> go
-    where cons c (!n, cs) = (n + 1, c : cs)
+
+data Rest = Rest {len :: {-# UNPACK #-} !Int, chunks :: [Chunk]}
+
+cons :: Chunk -> Rest -> Rest
+cons c (Rest {len, chunks}) = Rest {len = succ len, chunks = c : chunks}
+
+make :: Rest -> Vector Chunk
+make (Rest n cs) = Vector.fromListN n cs
+
 
 parseChunk :: Parser Chunk
 parseChunk = do
   offset <- parseWord24
   size   <- parseWord16
-  body   <-
+  body   <- parseBody size
-    if size == 0 then
-      liftA2 RLE parseWord16 Parse.anyWord8
-    else
-      Normal . makeBytes <$> Parse.take (fromIntegral size)
   pure $ Chunk {offset, body}
 
+
+parseBody :: Word16 -> Parser ChunkBody
+parseBody 0 = RLE <$> parseWord16 <*> Parse.anyWord8
+parseBody n = Normal . makeBytes <$> Parse.take (fromIntegral n)
+
+
 parseWord16 :: Parser Word16
 parseWord16 = parseWordBE 2
 

src/IPS/Word24.hs

@@ -38,18 +38,13 @@ instance Enum Word24 where
 
   fromEnum (W24 x) = fromEnum x
 
-clamp1 :: (Word32 -> Word32) -> (Word24 -> Word24)
-clamp1 f (W24 x) = mkW24 $ f x
-clamp2 :: (Word32 -> Word32 -> Word32) -> (Word24 -> Word24 -> Word24)
-clamp2 (·) (W24 x) (W24 y) = mkW24 $ x · y
-
 instance Num Word24 where
   (+) = clamp2 (+)
   (*) = clamp2 (*)
   (-) = clamp2 (-)
 
   abs            = id
-  signum x = if x == 0 then 0 else 1
+  signum (W24 x) = mkW24 $ signum x
   fromInteger x  = mkW24 $ fromInteger x
 
 instance Real Word24 where
@@ -82,3 +77,10 @@ instance Bits Word24 where
 
 instance FiniteBits Word24 where
   finiteBitSize _ = 24
+
+
+clamp1 :: (Word32 -> Word32) -> (Word24 -> Word24)
+clamp1 f (W24 x) = mkW24 $ f x
+
+clamp2 :: (Word32 -> Word32 -> Word32) -> (Word24 -> Word24 -> Word24)
+clamp2 (·) (W24 x) (W24 y) = mkW24 $ x · y