formatting tweaks

This commit is contained in:
rhiannon morris 2021-12-28 10:26:23 +01:00
parent bb1a9386eb
commit bc87a61233
3 changed files with 72 additions and 62 deletions

View File

@ -11,22 +11,6 @@ import Data.Foldable
type BytesM m = MVector (PrimState m) Word8 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 -- size of patch output
-- (patches can write past the end of the input file) -- (patches can write past the end of the input file)
outSize :: Patch -> Int outSize :: Patch -> Int
@ -36,27 +20,41 @@ outSize = foldl' (\m c -> max m (end c)) 0 where
RLE {size} -> offset' + fromIntegral size RLE {size} -> offset' + fromIntegral size
where offset' = fromIntegral offset where offset' = fromIntegral offset
-- applies in place if it fits, otherwise allocates a new buffer for it -- 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 :: 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 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 -- copies an immutable vector (resizing if needed) and patches it
apply :: Patch -> Bytes -> Bytes 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 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

View File

@ -1,41 +1,51 @@
module IPS.Parse (parser, read) where module IPS.Parse (parser, parseFile) where
import Prelude hiding (read)
import IPS.Types import IPS.Types
import Data.Attoparsec.ByteString (Parser) import Data.Attoparsec.ByteString (Parser)
import qualified Data.Attoparsec.ByteString as Parse import qualified Data.Attoparsec.ByteString as Parse
import Data.Bits import Data.Bits
import qualified Data.ByteString as ByteString 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 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 :: 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 :: Parser Chunk
parseChunk = do parseChunk = do
offset <- parseWord24 offset <- parseWord24
size <- parseWord16 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} 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 :: Parser Word16
parseWord16 = parseWordBE 2 parseWord16 = parseWordBE 2

View File

@ -38,19 +38,14 @@ instance Enum Word24 where
fromEnum (W24 x) = fromEnum x 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 instance Num Word24 where
(+) = clamp2 (+) (+) = clamp2 (+)
(*) = clamp2 (*) (*) = clamp2 (*)
(-) = clamp2 (-) (-) = clamp2 (-)
abs = id abs = id
signum x = if x == 0 then 0 else 1 signum (W24 x) = mkW24 $ signum x
fromInteger x = mkW24 $ fromInteger x fromInteger x = mkW24 $ fromInteger x
instance Real Word24 where instance Real Word24 where
toRational (W24 x) = toRational x toRational (W24 x) = toRational x
@ -71,14 +66,21 @@ instance Bits Word24 where
rotate x 0 = x rotate x 0 = x
rotate (W24 x) i = mkW24 $ (x `shiftL` i) .|. (x `shiftR` (24 - i)) rotate (W24 x) i = mkW24 $ (x `shiftL` i) .|. (x `shiftR` (24 - i))
bitSize = finiteBitSize bitSize = finiteBitSize
bitSizeMaybe = Just . finiteBitSize bitSizeMaybe = Just . finiteBitSize
isSigned _ = False isSigned _ = False
testBit = testBitDefault testBit = testBitDefault
bit = bitDefault bit = bitDefault
popCount (W24 x) = popCount x popCount (W24 x) = popCount x
instance FiniteBits Word24 where instance FiniteBits Word24 where
finiteBitSize _ = 24 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