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
-- 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

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 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

View File

@ -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