diff --git a/src/IPS/Apply.hs b/src/IPS/Apply.hs index 6124ccd..c8a4b26 100644 --- a/src/IPS/Apply.hs +++ b/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 - let size = outSize p - (buf', realloc) <- - 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' +applyM patch buf = do + (buf', realloc) <- maybeNewBuf buf $ outSize patch + unsafeApplyM patch 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 - let size = outSize p `max` Vector.length inp - buf <- MVector.new size - let dst = MVector.slice 0 (Vector.length inp) buf - Vector.copy dst inp - unsafeApplyM p buf +apply patch input = runST do + buf <- MVector.new $ outSize patch `max` Vector.length input + Vector.copy (MVector.slice 0 (Vector.length input) buf) input + unsafeApplyM patch 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 + diff --git a/src/IPS/Parse.hs b/src/IPS/Parse.hs index 4088bb3..7f6ec03 100644 --- a/src/IPS/Parse.hs +++ b/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 qualified Data.Vector.Generic as Vector +import Data.Vector (Vector) +import qualified Data.Vector as Vector import Control.Applicative -read :: FilePath -> IO (Either String Patch) -read f = Parse.parseOnly parser <$> ByteString.readFile f +parseFile :: FilePath -> IO (Either String Patch) +parseFile f = Parse.parseOnly parser <$> ByteString.readFile f parser :: Parser Patch -parser = Parse.string "PATCH" *> parseBody +parser = Parse.string "PATCH" *> parseRest + + +parseRest :: Parser Patch +parseRest = make <$> go where + go = eof <|> chunk + eof = Rest 0 [] <$ Parse.string "EOF" + chunk = cons <$> parseChunk <*> go + +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 -parseBody :: Parser Patch -parseBody = uncurry Vector.fromListN <$> go where - go = eof <|> chunk - eof = Parse.string "EOF" $> (0, []) - chunk = liftA2 cons parseChunk go - where cons c (!n, cs) = (n + 1, c : cs) parseChunk :: Parser Chunk parseChunk = do offset <- parseWord24 size <- parseWord16 - body <- - if size == 0 then - liftA2 RLE parseWord16 Parse.anyWord8 - else - Normal . makeBytes <$> Parse.take (fromIntegral size) + body <- parseBody 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 diff --git a/src/IPS/Word24.hs b/src/IPS/Word24.hs index 7c681c2..42d4bb7 100644 --- a/src/IPS/Word24.hs +++ b/src/IPS/Word24.hs @@ -38,19 +38,14 @@ 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 - fromInteger x = mkW24 $ fromInteger x + abs = id + signum (W24 x) = mkW24 $ signum x + fromInteger x = mkW24 $ fromInteger x instance Real Word24 where toRational (W24 x) = toRational x @@ -71,14 +66,21 @@ instance Bits Word24 where rotate x 0 = x rotate (W24 x) i = mkW24 $ (x `shiftL` i) .|. (x `shiftR` (24 - i)) - bitSize = finiteBitSize + bitSize = finiteBitSize bitSizeMaybe = Just . finiteBitSize - isSigned _ = False + isSigned _ = False testBit = testBitDefault - bit = bitDefault + bit = bitDefault popCount (W24 x) = popCount x 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