bytepatch 0.3.1 → 0.4.0

raw patch · 37 files changed

+2117/−1110 lines, 37 filesdep +binrepdep +blake3dep +heystonedep ~aesondep ~basedep ~generic-opticsPVP ok

version bump matches the API change (PVP)

Dependencies added: binrep, blake3, heystone, memory, refined, singletons, singletons-base, singletons-th, text-short

Dependency ranges changed: aeson, base, generic-optics, optparse-applicative, vinyl, yaml

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• README.md +46/−32
• app/BytePatch.hs +346/−0
• app/BytePatch/CLI.hs +88/−0
• app/BytePatch/Config.hs +62/−0
• app/CLI.hs +0/−66
• app/Config.hs +0/−39
• app/Main.hs +3/−187
• app/Raehik/CLI/Stream.hs +64/−0
• bytepatch.cabal +128/−73
• src/Binrep/Type/Assembly.hs +31/−0
• src/Binrep/Type/Assembly/Assemble.hs +68/−0
• src/Binrep/Type/Assembly/Disassemble.hs +8/−0
• src/BytePatch.hs +0/−133
• src/BytePatch/HexByteString.hs +0/−68
• src/Raehik/HFunctorMap.hs +187/−0
• src/StreamPatch/Apply.hs +106/−45
• src/StreamPatch/Example.hs +19/−0
• src/StreamPatch/HFunctorList.hs +130/−0
• src/StreamPatch/Patch.hs +29/−70
• src/StreamPatch/Patch/Align.hs +37/−47
• src/StreamPatch/Patch/Binary.hs +87/−114
• src/StreamPatch/Patch/Binary/PascalText.hs +0/−48
• src/StreamPatch/Patch/Compare.hs +208/−0
• src/StreamPatch/Patch/Compile.hs +35/−0
• src/StreamPatch/Patch/Linearize.hs +0/−58
• src/StreamPatch/Patch/Linearize/Common.hs +6/−0
• src/StreamPatch/Patch/Linearize/InPlace.hs +58/−0
• src/StreamPatch/Patch/Linearize/Insert.hs +41/−0
• src/StreamPatch/Seek.hs +19/−0
• src/StreamPatch/Simple.hs +148/−0
• src/StreamPatch/Stream.hs +110/−57
• test/BytePatch/HexByteStringSpec.hs +0/−23
• test/StreamPatch/ApplySpec.hs +11/−11
• test/StreamPatch/Patch/AlignSpec.hs +11/−10
• test/StreamPatch/Patch/LinearizeSpec.hs +17/−13
• test/Util.hs +8/−16

@@ -1,3 +1,9 @@+## 0.4.0 (2022-07-08)+  * lots of refactoring, breaking, removing+  * clean up FunctorRec into standalone HFunctorList module+  * clean up HexBytestring into standalone module+  * add assembly patching (just ARMv8 Thumb LE for now)+ ## 0.3.1 (2021-12-21)   * packaging improvements (documentation, CI) 

@@ -1,34 +1,60 @@ # bytepatch-A Haskell library and CLI tool for patching data in a stream, primarily aimed at-handling byte-representable data. Write **patchscripts** (in-place edits to a-file) using a convenient YAML format, and apply them with a safe patching-algorithm. On the library side, define explicit patches over any type, apply-them to pure/impure streams, and write further patch types and streams to extend-as you desire.+A Haskell library and CLI tool for writing declarative patches over streams.+Write **patchscripts** (in-place edits to a file) using a configurable YAML+schema, and apply them with a safe patching algorithm. On the library side,+define patches of various forms over any type, apply them to pure/impure+streams, and write further patch data types and streams to extend as you like. -The executable is intended as a general tool for making simple binary editing-more manageable. The codebase is really a fun investigation into some type-level-Haskell features. Regardless of which you're interested in, I hope you might-find some use from this project!+bytepatch works with many data types: +  * read pretty binary `00 FF 1234`, parse to bytes+  * read text, re-encode, null-terminate to generate a C-style string+  * read assembly, assemble down to machine code++The schema itself is highly configurable:++  * align: add a value (set in patch file) to each patch offset+  * compare: bytepatch can check expected data against actual during patching,+    to assert that you're patching the expected file. You can select how this+    check works: compare equality (exact, or match prefix), hashes+  * seek type: what the patch offsets mean. You'll likely want absolute+    offsets - but you may also write them as linear offsets, forward from the+    previous.++You may also ask bytepatch to *compile* a patchscript, which reads it and then+outputs a YAML file with a simplified schema: pre-aligned, compare via hashes,+forward seeks.++The bytepatch executable aims to be a general tool for reverse engineers, hoping+to make simple binary & assembly editing more manageable. The Haskell library is+quite sprawling, and has personally made for a fun investigation into type-level+Haskell.+ ## What? If you're modifying binaries, you often end up needing to make edits in a hex editor. This is fun for a very short while, then you realise how easy it is to-mess up. bytepatch provides a simple, human read-writeable format for defining-such edits, and can apply them for you.+mess up. -bytepatch is intended as a developer tool for writing a *static patchscript*.-It's not a binary patch tool like IPS, BPS: these take an input and a result-file, and generate a patch file that can be applied to the input in order to-recreate the result. By itself, the patch file isn't useful, being instructions-to the tool telling how to edit the input file. bytepatch uses a human-readable-patch file format that describes in plain terms the edits to make, so developers-can read and write patches in a structured, useable format.+bytepatch is primarily intended as a developer tool for writing a+*human-friendly static patchscript*. It provides a nice schema for defining+edits to a binary file, so that developers can read and write patches in a+structured, readable format. If one wanted, they could very easily read the+patch file and use it to make the changes manually (though bytepatch wants to do+this for you). +bytepatch is not aimed at replacing binary patch tools such as IPS, BPS: these+take an input and a result file, and generate a patch file that can be applied+to the input in order to recreate the result. You need the result file in the+first place. These tools both generate the patch file and apply it; bytepatch+only applies the patch file, and leaves the writing to the user.+ ## When might I want to use this? You might find bytepatch useful if you want to define edits to be made on binary-files (especially executables) that are *static* and *in-place*.+files (especially executables) that are *static* and *in-place*. Examples are: +  * instruction patching (via assembly)+  * string patching (via text)+ ### Less relevant use cases You can't use bytepatch directly for edits which are dynamic in nature (e.g. you need to read a file header in order to know what to change). *(You could@@ -42,18 +68,6 @@ offset, or do we implicitly shift them so they still write to the "same place"? There *is* some support in the library for such edits, however, and it would be interesting to explore.--### Original rationale-I'm working on some binary files, and need to patch strings, machine code and-other data. I make some changes, I test them, they work. Then I note down the-changes I made. It's tedious and repetitive, but I really don't want to lose-track of what got changed how, and it's the clearest way to share my work-others. But if I want to test more stuff, I may have to make those changes-again. I'm gonna make a mistake eventually.--Instead, I described my patches in YAML and wrote a tool to apply them. Now my-changes and my notes (thanks YAML comments!) are the same file, which can be-checked for correctness and applied automatically.  ## License Provided under the MIT license. Please see `LICENSE` for the full license text.

@@ -0,0 +1,346 @@+{-# LANGUAGE AllowAmbiguousTypes, OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++module BytePatch where++import BytePatch.Config+import Raehik.CLI.Stream+import BytePatch.CLI qualified as CLI+import StreamPatch.Patch.Compile qualified as Compile++import GHC.Generics ( Generic )++import StreamPatch.Patch+import StreamPatch.HFunctorList ( Flap, HFunctorList )+import StreamPatch.Patch.Align qualified as Align+import StreamPatch.Patch.Linearize.InPlace qualified as Linear+import StreamPatch.Patch.Binary qualified as Bin+import StreamPatch.Patch.Compare qualified as Compare+import StreamPatch.Patch.Compare ( Via(..), SVia(..), SEqualityCheck(..), HashFunc(..), SHashFunc(..), Compare, CompareRep )+import StreamPatch.Apply qualified as Apply+import StreamPatch.Simple as Simple++import Binrep.Extra.HexByteString++import Binrep.Type.Assembly qualified as Asm+import Binrep.Type.Assembly.Assemble qualified as Asm+import Binrep.Type.Assembly.Assemble ( Assemble )+import Binrep.Type.Text qualified as BR.Text+import Binrep.Type.ByteString qualified as BR.ByteString++import Binrep+import Binrep.Type.ByteString ( AsByteString )++import Refined++import qualified System.Exit as System+import Data.Vinyl+import Data.Vinyl.TypeLevel+import Data.Functor.Const+import Data.Either.Combinators ( mapLeft )+import Control.Monad.IO.Class+import Control.Monad.Reader+import Control.Monad.Except+import Data.ByteString qualified as B+import Data.ByteString.Lazy qualified as BL+import Data.Yaml qualified as Yaml+import Data.Yaml.Pretty qualified as Yaml.Pretty+import Data.Aeson ( ToJSON, FromJSON )+import Data.Text ( Text )+import Optics+import Data.Generics.Product.Any++import Data.Singletons ( withSomeSing, Sing, SingI )++type Bytes = B.ByteString++--------------------------------------------------------------------------------++-- Errors that can occur during patchscript processing. Everything except+-- reading the patchscript, and writing out the successfully patched file.+data Error+  = ErrorYaml     Yaml.ParseException+  | ErrorAlign    String+  | ErrorLinear   String+  | Error         String+  | ErrorUnimplemented+  | ErrorProcessBinRep String -- can't do Bin.Error, has a typevar (until we put the typevar in this data, which will happen eventually)+  | ErrorProcessAssemble String+  | ErrorProcessApply String+    deriving (Generic, Show)++quit :: MonadIO m => Error -> m a+quit err = do+    liftIO $ putStrLn $ "bytepatch: error: " <> errStr+    liftIO $ System.exitWith $ System.ExitFailure errExitCode+  where+    (errExitCode, errStr) = case err of+      ErrorYaml     e -> (1, "while parsing YAML: "<>show e)+      ErrorAlign    e -> (2, "while aligning: "<>e)+      ErrorProcessBinRep e -> (3, "while converting to binary representation: "<>e)+      ErrorLinear   e -> (4, "while linearizing: "<>e)+      ErrorProcessApply e -> (5, "while applying patch: "<>e)+      ErrorProcessAssemble e -> (6, "while assembling: "<>e)+      ErrorUnimplemented -> (10, "feature not yet implemented")+      Error         e -> (20, e)++logWarn :: MonadIO m => String -> m ()+logWarn msg = liftIO $ putStrLn $ "bytepatch: warning: " <> msg++liftProcessError :: MonadIO m => ExceptT Error m a -> m a+liftProcessError action =+    runExceptT action >>= \case+      Left  e -> quit e+      Right a -> return a++liftMapProcessError :: MonadError Error m => (e -> Error) -> Either e a -> m a+liftMapProcessError f = liftEither . mapLeft f++--------------------------------------------------------------------------------++processDecode :: forall a m. (MonadError Error m, FromJSON a) => Bytes -> m a+processDecode = liftMapProcessError ErrorYaml . Yaml.decodeEither'++processAlign+    :: forall (v :: Via) a m r rs ss is+    .  ( r ~ Const (Align.Meta Int)+       , rs ~ RDelete r ss+       , RElem r ss (RIndex r ss)+       , RSubset rs ss is+       , MonadError Error m )+    => (MultiPatch Integer v a -> Patch Integer ss a)+    -> [Aligned (MultiPatch Integer v a)]+    -> m [Patch Int rs a]+processAlign f = liftMapProcessError (ErrorAlign . show) . fmap concat . traverse (wrapAlign f)++processLinearize+    :: forall a m fs+    .  ( Linear.HasLength a+       , Show a, ReifyConstraint Show (Flap a) fs, RMap fs, RecordToList fs+       , MonadError Error m )+    => [Patch Linear.Len fs a]+    -> m [Patch Linear.Len fs a]+processLinearize = liftMapProcessError (ErrorLinear . show) . Linear.linearizeInPlace++processAsm+    :: forall (arch :: Asm.Arch) s fs m+    .  (MonadError Error m, Assemble arch, Traversable (HFunctorList fs))+    => [Patch s fs (Asm.AsmInstr arch)]+    -> m [Patch s fs (Asm.MachineCode arch)]+processAsm =+      liftMapProcessError ErrorProcessAssemble+    . traverse (traverse (Asm.assemble1 @arch))++processAsms+    :: forall (arch :: Asm.Arch) s fs m+    .  (MonadError Error m, Assemble arch, Traversable (HFunctorList fs))+    => [Patch s fs [Asm.AsmInstr arch]]+    -> m [Patch s fs (Asm.MachineCode arch)]+processAsms =+      liftMapProcessError ErrorProcessAssemble+    . traverse (traverse (Asm.assemble @arch))++processBin+    :: forall a s ss is r rs m+    .  ( MonadError Error m+       , Put a, BLen a+       , r ~ Const Bin.MetaPrep+       , rs ~ RDelete r ss+       , RElem r ss (RIndex r ss)+       , RSubset rs ss is+       , Traversable (HFunctorList rs)+       , Show a+       )+    => [Patch s ss a]+    -> m [Patch s rs Bytes]+processBin = liftMapProcessError (ErrorProcessBinRep . show) . traverse Bin.binRepify++--------------------------------------------------------------------------------++main :: IO ()+main = CLI.parse >>= runReaderT run++run :: forall m. (MonadIO m, MonadReader C m) => m ()+run = readPatchscriptBs >>= liftProcessError . usePatchscriptBs+  where+    readPatchscriptBs = asks cPsPath >>= liftIO . B.readFile . unPath+    usePatchscriptBs bs = do+        cfg <- ask+        let cpf = cfg.cPsFmt+        withSomeSing cpf.cPsFmtCompare (process cfg bs)++-- using singletons simply to automatically bring type into scope+process+    :: forall (v :: Via) m+    .  ( MonadIO m, MonadReader C m )+    => C -> Bytes -> Sing v -> ExceptT Error m ()+process cfg bs = \case+      SViaEq SExact -> do+        ps <- prep @v cfg.cPsFmt bs+        case cfg.cCmd of+          CCmdPatch'   cfg'  -> cmdPatchBinCompareFwd cfg' ps+          CCmdCompile' _cfg' ->+            let ps'  = map (Compile.compilePatch @('ViaDigest 'B3)) ps+                ps'' = asPrettyYamlHexMultiPatch convertBackBin ps'+             in liftIO $ B.putStr ps''+      SViaDigest SB3 -> do+        ps <- prep @v cfg.cPsFmt bs+        case cfg.cCmd of+          CCmdPatch'   cfg'  -> cmdPatchBinCompareFwd cfg' ps+          CCmdCompile' _cfg' ->+              let ps' = asPrettyYamlHexMultiPatch convertBackBin ps+               in liftIO $ B.putStr ps'+      SViaEq SPrefixOf -> do+        ps <- prep @v cfg.cPsFmt bs+        case cfg.cCmd of+          CCmdPatch'   cfg'  -> cmdPatchBinCompareFwd cfg' ps+          CCmdCompile' _cfg' -> throwError $ ErrorUnimplemented+      _ -> throwError $ ErrorUnimplemented++patchPureBinCompareFwd+    :: forall v s m+    .  (MonadIO m, Compare v Bytes)+    => Stream 'In s+    -> [Patch Int '[Compare.Meta v, Bin.Meta] Bytes]+    -> m Bytes+patchPureBinCompareFwd si ps = do+    bsIn <- readStream si+    case Apply.runPureBinCompareFwd ps bsIn of+      Left  e     -> quit $ ErrorProcessApply $ show e+      Right bsOut -> return $ BL.toStrict bsOut++cmdPatchBinCompareFwd+    :: forall v m+    .  (MonadIO m, Compare v Bytes)+    => CCmdPatch+    -> [Patch Int '[Compare.Meta v, Bin.Meta] Bytes]+    -> m ()+cmdPatchBinCompareFwd c ps = do+    bs <- patchPureBinCompareFwd c.cCmdPatchStreamIn ps+    case c.cCmdPatchStreamOut of+      Path' (Path fp) -> liftIO $ B.writeFile fp bs+      Std      -> case c.cCmdPatchPrintBinary of+        True  -> liftIO $ B.putStr bs+        False -> liftIO $ logWarn $+                     "refusing to print binary to stdout:"+                  <> " write to a file with --out-file FILE"+                  <> " or use --print-binary flag to override"++-- TODO fix all of this, it got weird with seekrep removal+wrapAlign+    :: ( r ~ Const (Align.Meta Int)+       , rs ~ RDelete r ss+       , RElem r ss i+       , RSubset rs ss is )+    => (MultiPatch Integer v a -> Patch Integer ss a)+    -> Aligned (MultiPatch Integer v a)+    -> Either (Align.Error Int) [Patch Int rs a]+wrapAlign f = Simple.align . over (the @"alignedPatches") (map f)++readStream :: forall s m. MonadIO m => Stream 'In s -> m Bytes+readStream = liftIO . \case Std             -> B.getContents+                            Path' (Path fp) -> B.readFile fp++-- Parse and prepare/normalize a binrep-compare patchscript, polymorphic on the+-- comparison strategy. We can't handle that in here, because you need it when+-- processing the command, since different comparison strategies require+-- different handling, and some are invalid.+prep+    :: forall v m+    -- grr+     . ( MonadError Error m+       , FromJSON (CompareRep v Text)+       , FromJSON (CompareRep v HexByteString)+       , FromJSON (CompareRep v (Asm.AsmInstr 'Asm.ArmV8ThumbLE))+       , FromJSON (CompareRep v [Asm.AsmInstr 'Asm.ArmV8ThumbLE])+       , Show     (CompareRep v Bytes)+       -- , Traversable (Compare.Meta v)+       , SingI v+       )+    => CPsFmt+    -> Bytes+    -> m [Patch Int '[Compare.Meta v, Bin.Meta] Bytes]+prep c bs = case c.cPsFmtData of+  CDataBytes -> prep' @HexByteString c (return . fmap unHexPatch) bs+  CDataTextBin BR.Text.UTF8 BR.ByteString.C ->+      prep' @Text @(AsByteString 'BR.ByteString.C) c (binTextifyPatches @'BR.Text.UTF8) bs+  CDataAsm Asm.ArmV8ThumbLE -> prep' c (processAsm @'Asm.ArmV8ThumbLE) bs+  CDataText -> throwError ErrorUnimplemented+  cDataX -> throwError $ Error $ "can't yet handle patchscript data type: "<>show cDataX++unHexPatch+    :: Functor (HFunctorList fs)+    => Patch s fs HexByteString+    -> Patch s fs B.ByteString+unHexPatch = fmap unHex++binTextifyPatches+    :: forall (enc :: BR.Text.Encoding) (rep :: BR.ByteString.Rep) s fs m+    .  ( Predicate enc Text, BR.Text.Encode enc, Predicate rep B.ByteString+       , MonadError Error m, Traversable (HFunctorList fs) )+    => [Patch s fs Text]+    -> m [Patch s fs (AsByteString rep)]+binTextifyPatches = traverse (binTextifyPatch @enc)++binTextifyPatch+    :: forall (enc :: BR.Text.Encoding) (rep :: BR.ByteString.Rep) s fs m+    .  ( Predicate enc Text, BR.Text.Encode enc, Predicate rep B.ByteString+       , MonadError Error m, Traversable (HFunctorList fs) )+    => Patch s fs Text+    -> m (Patch s fs (AsByteString rep))+binTextifyPatch p = liftEither $ do+    pTextEnc <- liftMapProcessError (Error . show) $ traverse (refine @enc) p+    pBs <- liftMapProcessError (Error . show) $ traverse (BR.Text.encodeToRep @rep) pTextEnc+    return pBs++-- Binrep-compare, parsing @a@ and failably converting to @b@, In many cases,+-- you may want to parse and binrep the same type -- in such cases, use 'pure'.+prep'+    :: forall a b v m+    .  ( FromJSON a, Put b, BLen b, Show b+       , FromJSON (CompareRep v a)+       , SingI v+       , Show     (CompareRep v Bytes)+       , MonadError Error m+       )+    => CPsFmt+    -> (forall s fs. Traversable (HFunctorList fs) => [Patch s fs a] -> m [Patch s fs b])+    -> Bytes+    -> m [Patch Int '[Compare.Meta v, Bin.Meta] Bytes]+prep' c fBin bs =+    case c.cPsFmtAlign of+      CAlign ->     processDecode bs+                >>= processAlign @v Simple.convertBinAlign+                >>= fBin+                >>= processBin @b+                >>= processLinearize+      CNoAlign ->     processDecode bs+                  >>= return . map Simple.convertBin+                  >>= fBin+                  >>= processBin @b+                  >>= processLinearize++asPrettyYamlHexMultiPatch+    :: forall v s a fs+    .  ( ToJSON (CompareRep v (Hex a))+       , ToJSON (Hex a)+       , ToJSON s+       , Functor (MultiPatch s v)+       )+    => (Patch s fs a -> MultiPatch s v a)+    -> [Patch s fs a]+    -> B.ByteString+asPrettyYamlHexMultiPatch f ps =+      let psSimple    = fmap f ps+          psSimpleHex = fmap (fmap Hex) psSimple+       in Yaml.Pretty.encodePretty yamlPrettyCfg psSimpleHex++-- silly stuff+yamlPrettyCfg :: Yaml.Pretty.Config+yamlPrettyCfg = Yaml.Pretty.setConfCompare cmp $ Yaml.Pretty.setConfDropNull True $ Yaml.Pretty.defConfig+  where+    cmp "data" _  = LT+    cmp _  "data" = GT+    cmp "seek" _ = LT+    cmp _ "seek" = GT+    cmp k1     k2 = Prelude.compare k1 k2

@@ -0,0 +1,88 @@+{-# LANGUAGE OverloadedRecordDot #-}++module BytePatch.CLI ( parse ) where++import BytePatch.Config+import Raehik.CLI.Stream++import Options.Applicative+import Control.Monad.IO.Class+import StreamPatch.Patch.Compare qualified as Compare++import Binrep.Type.Assembly qualified as BR.Asm+import Binrep.Type.ByteString qualified as BR.ByteString+import Binrep.Type.Text qualified as BR.Text++parse :: MonadIO m => m C+parse = execParserWithDefaults desc pC+  where desc = "Patch data in a stream."++pC :: Parser C+pC = C <$> pCPsFmt <*> pPathIn <*> pCCmd++pCPsFmt :: Parser CPsFmt+pCPsFmt = CPsFmt <$> pCData+                 <*> pCAlign+                 <*> pCCompareVia+                 <*> pure ()++pCCmd :: Parser CCmd+pCCmd = hsubparser $+       cmd' "patch"   descPatch   (CCmdPatch'   <$> pCCmdPatch)+    <> cmd' "compile" descCompile (CCmdCompile' <$> pCCmdCompile)+  where+    descPatch   = "Apply patchscript to a stream."+    descCompile = "\"Compile\" patchscript to a processed form."++pCCmdPatch :: Parser CCmdPatch+pCCmdPatch = CCmdPatch <$> pStreamIn <*> pStreamOut <*> pPrintBinary++pCCmdCompile :: Parser CCmdCompile+pCCmdCompile = pure CCmdCompile++pCData :: Parser CData+pCData = option (maybeReader mapper) $+       long "type"+    <> short 't'+    <> help "Patch data meaning (see docs for full help)"+    <> metavar "PATCH_TYPE"+  where mapper = \case "bin"              -> Just CDataBytes+                       "text-bin:utf8,c"  -> Just $ CDataTextBin BR.Text.UTF8 BR.ByteString.C+                       "asm:armv8thumble" -> Just $ CDataAsm BR.Asm.ArmV8ThumbLE+                       "text-plain"       -> Just CDataText+                       _                  -> Nothing++pCAlign :: Parser CAlign+pCAlign = flag CNoAlign CAlign $+       long "aligned"+    <> help "Parse alignment data"++pPrintBinary :: Parser Bool+pPrintBinary = switch $+       long "print-binary"+    <> help "Force print binary to stdout"++pCCompareVia :: Parser Compare.Via+pCCompareVia = option (maybeReader mapper) $+       long "compare"+    <> short 'c'+    <> help "Comparison strategy (equal/prefix/size/hashB3)"+    <> metavar "COMPARISON_STRATEGY"+  where mapper = \case "equal"  -> Just $ Compare.ViaEq Compare.Exact+                       "prefix" -> Just $ Compare.ViaEq Compare.PrefixOf+                       "size"   -> Just Compare.ViaSize+                       "hashB3" -> Just $ Compare.ViaDigest Compare.B3+                       _        -> Nothing+++--------------------------------------------------------------------------------++-- | Execute a 'Parser' with decent defaults.+execParserWithDefaults :: MonadIO m => String -> Parser a -> m a+execParserWithDefaults desc p = liftIO $ customExecParser+    (prefs $ showHelpOnError)+    (info (helper <*> p) (progDesc desc))++-- | Shorthand for the way I always write commands.+cmd' :: String -> String -> Parser a -> Mod CommandFields a+cmd' name desc p = command name (info p (progDesc desc))

@@ -0,0 +1,62 @@+module BytePatch.Config where++import GHC.Generics ( Generic )+import Data.Data ( Typeable, Data )+import StreamPatch.Patch.Compare qualified as Compare++import Binrep.Type.Text qualified as BR.Text+import Binrep.Type.ByteString qualified as BR.ByteString+import Binrep.Type.Assembly qualified as BR.Asm++import Raehik.CLI.Stream++data C = C+  { cPsFmt  :: CPsFmt+  , cPsPath :: Path 'In "patchscript file"+  , cCmd    :: CCmd+  } deriving stock (Generic, Typeable, Data, Show, Eq)++data CPsFmt = CPsFmt+  { cPsFmtData    :: CData+  , cPsFmtAlign   :: CAlign+  , cPsFmtCompare :: Compare.Via+  , cPsFmtSeek    :: ()+  } deriving stock (Generic, Typeable, Data, Show, Eq)++-- | What the patch data indicates (base and target representation).+data CData+  = CDataBytes+  -- ^ Raw bytes (via hex), patched directly over a bytestring.++  | CDataTextBin BR.Text.Encoding BR.ByteString.Rep+  -- ^ Text, which is to be encoded to the given character encoding and placed+  --   in the given bytestring representation, then patched over a bytestring.++  | CDataAsm BR.Asm.Arch+  -- ^ Assembly instructions for the given architecture, which is to be+  --   assembled into machine code for the architecture, then patched over a+  --   bytestring.++  | CDataText+  -- ^ Text, which is to be patched directly over @Text@.+    deriving stock (Generic, Typeable, Data, Show, Eq)++data CCmd+  = CCmdPatch' CCmdPatch+  | CCmdCompile' CCmdCompile+    deriving stock (Generic, Typeable, Data, Show, Eq)++data CCmdPatch = CCmdPatch+  { cCmdPatchStreamIn    :: Stream 'In  "stream to patch"+  , cCmdPatchStreamOut   :: Stream 'Out "stream"+  , cCmdPatchPrintBinary :: Bool+  } deriving stock (Generic, Typeable, Data, Show, Eq)++-- TODO+data CCmdCompile = CCmdCompile+    deriving stock (Generic, Typeable, Data, Show, Eq)++data CAlign+  = CAlign   -- ^ Patch has alignment data.+  | CNoAlign -- ^ Patch does not have alignment data.+    deriving stock (Generic, Typeable, Data, Show, Eq)

@@ -1,66 +0,0 @@-module CLI ( parse ) where--import           Config-import           Options.Applicative-import           Control.Monad.IO.Class-import qualified StreamPatch.Patch.Binary as Bin--parse :: MonadIO m => m Config-parse = execParserWithDefaults desc pConfig-  where desc = "Patch bytestrings (TODO)."--pConfig :: Parser Config-pConfig = Config-    <$> strArgument (metavar "PATCHSCRIPT" <> help "Path to patchscript")-    <*> pCStreamPair-    <*> pCPatchFormat-    <*> pPrintBinary--pCStreamPair :: Parser CStreamPair-pCStreamPair = CStreamPair <$> pCSIn <*> pCSOut-  where-    pCSIn    = pFileArg <|> pStdin-    pCSOut   = pFileOpt <|> pure CStreamStd-    pFileArg = CStreamFile <$> strArgument (metavar "FILE" <> help "Input file")-    pFileOpt = CStreamFile <$> strOption (metavar "FILE" <> long "out-file" <> short 'o' <> help "Output file")-    pStdin   = flag' CStreamStd (long "stdin"  <> help "Use stdin")--pCPatchFormat :: Parser CPatchFormat-pCPatchFormat = CPatchFormat <$> pCPatchDataType <*> pCPatchAlign <*> pBinCfg--pCPatchDataType :: Parser CPatchDataType-pCPatchDataType = option (maybeReader mapper) $-       long "type"-    <> short 't'-    <> help "How to interpret & use patch data (binary/text/text-only)"-    <> metavar "PATCH_TYPE"-  where mapper = \case "text-only" -> Just CTextPatch-                       "bin"       -> Just CBinPatch-                       "binary"    -> Just CBinPatch-                       "text"      -> Just CTextBinPatch-                       _           -> Nothing--pCPatchAlign :: Parser CPatchAlign-pCPatchAlign = flag CNoAlignPatch CAlignPatch $-       long "aligned"-    <> help "Parse alignment data"--pBinCfg :: Parser Bin.Cfg-pBinCfg = Bin.Cfg <$> pExactMatch-  where-    pExactMatch = flag True False $-           long "match-exact"-        <> help "Expected binary data must match exactly (rather than be a prefix)"--pPrintBinary :: Parser Bool-pPrintBinary = switch $-       long "print-binary"-    <> help "Force print binary to stdout"-------------------------------------------------------------------------------------- | Execute a 'Parser' with decent defaults.-execParserWithDefaults :: MonadIO m => String -> Parser a -> m a-execParserWithDefaults desc p = liftIO $ customExecParser-    (prefs $ showHelpOnError)-    (info (helper <*> p) (progDesc desc))

@@ -1,39 +0,0 @@-module Config where--import           GHC.Generics ( Generic )-import qualified StreamPatch.Patch.Binary as Bin--data Config = Config-  { cfgPatchscript :: FilePath-  , cfgStreamPair  :: CStreamPair-  , cfgPatchFormat :: CPatchFormat-  , cfgPrintBinary :: Bool-  } deriving (Eq, Show, Generic)--data CStreamPair = CStreamPair-  { cStreamPairIn  :: CStream-  , cStreamPairOut :: CStream-  } deriving (Eq, Show, Generic)---- | "Single file" stream.-data CStream-  = CStreamFile FilePath-  | CStreamStd-    deriving (Eq, Show, Generic)--data CPatchFormat = CPatchFormat-  { cpfDataType :: CPatchDataType-  , cpfAlign    :: CPatchAlign-  , cpfBinCfg   :: Bin.Cfg-  } deriving (Eq, Show, Generic)--data CPatchAlign-  = CAlignPatch     -- ^ Patch has alignment data.-  | CNoAlignPatch   -- ^ Patch does not have alignment data.-    deriving (Eq, Show, Generic)--data CPatchDataType-  = CTextPatch      -- ^ Patch 'Text' over a 'Text' stream.-  | CBinPatch       -- ^ Patch bytestrings over a bytestream.-  | CTextBinPatch   -- ^ Patch 'Text' over a bytestream.-    deriving (Eq, Show, Generic)

@@ -1,190 +1,6 @@-{-# LANGUAGE AllowAmbiguousTypes #-}--module Main ( main ) where--import           Config-import qualified CLI--import           StreamPatch.Patch-import qualified StreamPatch.Patch.Align  as Align-import qualified StreamPatch.Patch.Linearize as Linear-import qualified StreamPatch.Patch.Binary as Bin-import           StreamPatch.Patch.Binary ( BinRep )-import qualified StreamPatch.Apply as Apply-import           BytePatch as BP-import qualified BytePatch.HexByteString as HexBS-import           BytePatch.HexByteString ( HexByteString )--import qualified System.Exit as System-import           Numeric.Natural-import           Data.Vinyl-import           Data.Vinyl.TypeLevel-import           Data.Functor.Const-import           Data.Either.Combinators ( mapLeft )-import           Control.Monad.IO.Class-import           Control.Monad.Reader-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BL-import qualified Data.Yaml as Yaml-import           Data.Yaml ( FromJSON )-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text-import           Data.Text ( Text )-import           Optics-import           Data.Generics.Product.Any--type Bytes = BS.ByteString+module Main where -data Error-  = ErrorYaml     Yaml.ParseException-  | ErrorAlign    String-  | ErrorBin      String-  | ErrorLinear   String-  | ErrorBinPatch String-  | Error         String-    deriving (Show)+import BytePatch qualified  main :: IO ()-main = CLI.parse >>= runReaderT run--run :: forall m. (MonadIO m, MonadReader Config m) => m ()-run = readPatchscript >>= processPatchScript >>= writePatched-  where-    readPatchscript = asks cfgPatchscript >>= readStream . CStreamFile--    processPatchScript psBs = do-        cpf <- asks cfgPatchFormat-        case cpfDataType cpf of-          CTextPatch    -> processText psBs-          CBinPatch     -> processBin' @HexByteString psBs-          CTextBinPatch -> processBin' @Text          psBs--    processText :: Bytes -> m Bytes-    processText psBs = do-        cpf <- asks cfgPatchFormat-        case processAny @Text psBs (cpfAlign cpf) of-          Left err -> quit err-          Right ps -> patchTextAwkward ps--    processBin' :: forall a. (BinRep a, FromJSON a, Show a) => Bytes -> m Bytes-    processBin' psBs = do-        cpf <- asks cfgPatchFormat-        case processBin @a psBs (cpfAlign cpf) of-          Left err -> quit err-          Right ps -> patchBin ps--    patchBin ps = do-        bsIn <- asks (cStreamPairIn . cfgStreamPair) >>= readStream-        binCfg <- asks $ cpfBinCfg . cfgPatchFormat-        case Apply.runPureFwdBin binCfg ps bsIn of-          Left err -> quit $ ErrorBinPatch (showErrorBin err)-          Right bsOut -> return $ BL.toStrict bsOut--    patchTextAwkward :: [Patch 'FwdSeek '[] Text] -> m Bytes-    patchTextAwkward ps = do-        bsIn <- asks (cStreamPairIn . cfgStreamPair) >>= readStream-        let psStr  = map (fmap Text.unpack) ps-            strIn  = Text.unpack $ Text.decodeUtf8 bsIn-            strOut = Apply.runPureSimpleFwdList psStr strIn-            bsOut  = Text.encodeUtf8 $ Text.pack strOut-        return bsOut--    writePatched bs =-        asks (cStreamPairOut . cfgStreamPair) >>= \case-          CStreamFile fp -> liftIO $ BS.writeFile fp bs-          CStreamStd     -> asks (cpfDataType . cfgPatchFormat) >>= \case-            CTextPatch -> liftIO $ BS.putStr bs-            _          -> asks cfgPrintBinary >>= \case-              True  -> liftIO $ BS.putStr bs-              False -> liftIO $ logWarn $-                     "refusing to print binary to stdout:"-                  <> " write to a file with --out-file FILE"-                  <> " or use --print-binary flag to override"--logWarn :: MonadIO m => String -> m ()-logWarn msg = liftIO $ putStrLn $ "bytepatch: warning: " <> msg---- | Parses your bytes into some binreppable patch form (aligned or not,---   depending on flag), converts it to the internal patch form, binreps it, and---   linearizes. The binrep type is consumed inside the function, making it---   ambiguous, so you need to pass it a type via @processBin \@Text@.------ Note that we linearize *after* binrepping. This is important -- it means the--- seeks are byte offsets, not using the pre-binrepped type.-processBin-    :: forall a. (BinRep a, FromJSON a, Show a) => Bytes -> CPatchAlign-    -> Either Error [Patch 'FwdSeek '[Bin.MetaStream] Bytes]-processBin bs = \case-  CAlignPatch   ->     mapLeft ErrorYaml (Yaml.decodeEither' @[Aligned (MultiPatch 'RelSeek a)] bs)-                   >>= mapLeft (ErrorAlign . show) . fmap concat . traverse (wrapAlign (BP.convertBinAlign @'AbsSeek))-                   >>= mapLeft (ErrorBin . showErrorBin) . traverse Bin.patchBinRep-                   >>= mapLeft (ErrorLinear . show) . Linear.linearize-  CNoAlignPatch ->     mapLeft ErrorYaml (Yaml.decodeEither' @[MultiPatch 'AbsSeek a] bs)-                   >>= mapLeft (ErrorBin . showErrorBin) . traverse Bin.patchBinRep . concat . map BP.convertBin-                   >>= mapLeft (ErrorLinear . show) . Linear.linearize---- | Like 'processBin' but no binrepping. Similarly beautiful and ambiguous.-processAny-    :: forall a. (Show a, FromJSON a, Linear.HasLength a) => Bytes -> CPatchAlign-    -> Either Error [Patch 'FwdSeek '[] a]-processAny bs = \case-  CAlignPatch   ->     mapLeft ErrorYaml (Yaml.decodeEither' @[Aligned (MultiPatch 'RelSeek a)] bs)-                   >>= mapLeft (ErrorAlign . show) . fmap concat . traverse (wrapAlign (BP.convertAlign @'AbsSeek))-                   >>= mapLeft (ErrorLinear . show) . Linear.linearize-  CNoAlignPatch ->     mapLeft ErrorYaml (Yaml.decodeEither' @[MultiPatch 'AbsSeek a] bs)-                   >>= mapLeft (ErrorLinear . show) . Linear.linearize . concat . map BP.convertEmpty--wrapAlign-    :: ( SeekRep s ~ Natural-       , r ~ Const (Align.Meta s)-       , rs ~ RDelete r ss-       , RElem r ss i-       , RSubset rs ss is )-    => (MultiPatch 'RelSeek a -> [Patch 'RelSeek ss a])-    -> Aligned (MultiPatch 'RelSeek a)-    -> Either (Align.Error s) [Patch s rs a]-wrapAlign f = align . over (the @"alignedPatches") (concat . map f)--quit :: MonadIO m => Error -> m a-quit err = do-    liftIO $ putStrLn $ "bytepatch: error: " <> errStr-    liftIO $ System.exitWith $ System.ExitFailure errExitCode-  where-    (errExitCode, errStr) = case err of-      ErrorYaml     e -> (1, "while parsing YAML: " <> show e)-      ErrorAlign    e -> (2, "while aligning: "     <> e)-      ErrorBin      e -> (3, "while converting to binary representation: " <> e)-      ErrorLinear   e -> (4, "while linearizing: " <> e)-      ErrorBinPatch e -> (5, "while applying binaryized patch: " <> e)-      Error         e -> (10, e)--readStream :: MonadIO m => CStream -> m Bytes-readStream s = liftIO $-    case s of-      CStreamStd     -> BS.getContents-      CStreamFile fp -> BS.readFile fp---- stupid but how else do I do this without pluggin HexByteString into Binary--- guess I just gotta write ACTUAL error handling. ffs-showErrorBin :: Show a => Bin.Error a -> String-showErrorBin = \case-  Bin.ErrorBadBinRep a s -> "ErrorBadBinRep " <> show a <> " " <> s-  Bin.ErrorUnexpectedNonNull bs -> "ErrorUnexpectedNonNull " <> go bs-  Bin.ErrorDidNotMatchExpected bs1 bs2 -> "ErrorDidNotMatchExpected " <> go bs1 <> " " <> go bs2-  Bin.ErrorBinRepTooLong bs n -> "ErrorBinRepTooLong " <> go bs <> " " <> show n-  where go bs = "\"" <> Text.unpack (HexBS.prettyHexByteString bs) <> "\""--{---writeStream :: MonadIO m => Bytes -> CStream -> m ()-writeStream bs s = liftIO $-    case s of-      CStreamStd     -> BS.putStr bs-      CStreamFile fp -> BS.writeFile fp bs--tryDecodeYaml-    :: forall a m. (FromJSON a, MonadIO m)-    => FilePath -> m (Either Yaml.ParseException a)-tryDecodeYaml fp = Yaml.decodeEither' <$> liftIO (BS.readFile fp)---}+main = BytePatch.main

@@ -0,0 +1,64 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Raehik.CLI.Stream where++import GHC.Generics ( Generic )+import Data.Data ( Typeable, Data )+import GHC.TypeLits ( Symbol, KnownSymbol, symbolVal' )+import GHC.Exts ( proxy#, Proxy# )++import Options.Applicative++import Data.Char qualified as Char++data Stream (d :: Direction) (s :: Symbol)+  = Path' (Path d s)+  | Std+    deriving stock (Generic, Typeable, Data, Show, Eq)++newtype Path (d :: Direction) (s :: Symbol)+  = Path { unPath :: FilePath }+    deriving stock (Generic, Typeable, Data)+    deriving (Show, Eq) via FilePath++data Direction = In | Out+    deriving stock (Generic, Typeable, Data, Show, Eq)++-- | Either a positional filepath, or standalone @--stdin@ switch.+pStreamIn :: forall s. KnownSymbol s => Parser (Stream 'In s)+pStreamIn = (Path' <$> pPathIn) <|> pStdinOpt+  where+    pStdinOpt = flag' Std $  long "stdin"+                          <> help ("Get "<>sym @s<>" from stdin")++-- | Either an @--out-file X@ option, or default to stdout.+pStreamOut :: forall s. KnownSymbol s => Parser (Stream 'Out s)+pStreamOut = (Path' <$> pPathOut) <|> pure Std+  where pPathOut = Path <$> strOption (modFileOut (sym @s))++-- | Positional filepath.+pPathIn :: forall s. KnownSymbol s => Parser (Path 'In s)+pPathIn = Path <$> strArgument (modFileIn (sym @s))++--------------------------------------------------------------------------------++-- | Generate a base 'Mod' for a file type using the given descriptive+--   name (the "type" of input, e.g. file format) and the given direction.+modFile :: HasMetavar f => String -> String -> Mod f a+modFile dir desc =  metavar "FILE" <> help (dir<>" "<>desc)++modFileIn :: HasMetavar f => String -> Mod f a+modFileIn = modFile "Input"++modFileOut :: (HasMetavar f, HasName f) => String -> Mod f a+modFileOut s = modFile "Output" s <> long "out-file" <> short 'o'++metavarify :: String -> String+metavarify = map $ Char.toUpper . spaceToUnderscore+  where spaceToUnderscore = \case ' ' -> '_'; ch -> ch++--------------------------------------------------------------------------------++-- | More succint 'symbolVal' via type application.+sym :: forall s. KnownSymbol s => String+sym = symbolVal' (proxy# :: Proxy# s)

@@ -1,12 +1,12 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.5.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack  name:           bytepatch-version:        0.3.1-synopsis:       Patch byte-representable data in a bytestream.+version:        0.4.0+synopsis:       Patch byte-representable data in a bytestream description:    Please see README.md. category:       CLI homepage:       https://github.com/raehik/bytepatch#readme@@ -17,7 +17,7 @@ license-file:   LICENSE build-type:     Simple tested-with:-    GHC >= 8.10 && < 9.2+    GHC ==9.2.3 extra-source-files:     README.md     CHANGELOG.md@@ -28,14 +28,23 @@  library   exposed-modules:-      BytePatch-      BytePatch.HexByteString+      Binrep.Type.Assembly+      Binrep.Type.Assembly.Assemble+      Binrep.Type.Assembly.Disassemble+      Raehik.HFunctorMap       StreamPatch.Apply+      StreamPatch.Example+      StreamPatch.HFunctorList       StreamPatch.Patch       StreamPatch.Patch.Align       StreamPatch.Patch.Binary-      StreamPatch.Patch.Binary.PascalText-      StreamPatch.Patch.Linearize+      StreamPatch.Patch.Compare+      StreamPatch.Patch.Compile+      StreamPatch.Patch.Linearize.Common+      StreamPatch.Patch.Linearize.InPlace+      StreamPatch.Patch.Linearize.Insert+      StreamPatch.Seek+      StreamPatch.Simple       StreamPatch.Stream       StreamPatch.Util   other-modules:@@ -44,99 +53,130 @@       src   default-extensions:       EmptyCase-      FlexibleContexts-      FlexibleInstances-      InstanceSigs-      MultiParamTypeClasses       LambdaCase+      InstanceSigs+      BangPatterns+      ExplicitNamespaces+      DerivingStrategies+      DerivingVia+      StandaloneDeriving+      DeriveAnyClass       DeriveGeneric-      DeriveFoldable+      DeriveDataTypeable       DeriveFunctor-      DeriveGeneric-      DeriveLift+      DeriveFoldable       DeriveTraversable-      DerivingStrategies-      GeneralizedNewtypeDeriving-      StandaloneDeriving-      BangPatterns-      KindSignatures-      TypeOperators+      DeriveLift+      FlexibleContexts+      FlexibleInstances+      MultiParamTypeClasses+      GADTs+      PolyKinds+      RoleAnnotations+      RankNTypes       TypeApplications-      DataKinds+      DefaultSignatures       TypeFamilies-      UndecidableInstances+      DataKinds+      MagicHash+      ImportQualifiedPost       StandaloneKindSignatures-      RankNTypes       ScopedTypeVariables+      TypeOperators+  ghc-options: -Wall   build-depends:-      aeson >=1.5 && <2.1-    , base >=4.12 && <4.17+      aeson >=2.0.2.0 && <2.1+    , base >=4.12 && <5+    , binrep+    , blake3 ==0.2.*     , bytestring >=0.10 && <0.12     , either >=5.0.1.1 && <5.1-    , generic-optics >=2.1 && <2.4+    , generic-optics >=2.2.1.0 && <2.3+    , heystone >=0.1.0 && <0.2     , megaparsec >=9.0 && <9.3+    , memory ==0.17.*     , mtl >=2.2.2 && <2.3     , optics >=0.3 && <0.5+    , singletons ==3.0.*+    , singletons-base ==3.1.*+    , singletons-th ==3.1.*     , text >=1.2.4.1 && <1.3-    , vinyl >=0.13.3 && <0.14+    , text-short >=0.1.5 && <0.2+    , vinyl >=0.14.1 && <0.15   default-language: Haskell2010  executable bytepatch   main-is: Main.hs   other-modules:-      CLI-      Config+      BytePatch+      BytePatch.CLI+      BytePatch.Config+      Raehik.CLI.Stream       Paths_bytepatch   hs-source-dirs:       app   default-extensions:       EmptyCase-      FlexibleContexts-      FlexibleInstances-      InstanceSigs-      MultiParamTypeClasses       LambdaCase+      InstanceSigs+      BangPatterns+      ExplicitNamespaces+      DerivingStrategies+      DerivingVia+      StandaloneDeriving+      DeriveAnyClass       DeriveGeneric-      DeriveFoldable+      DeriveDataTypeable       DeriveFunctor-      DeriveGeneric-      DeriveLift+      DeriveFoldable       DeriveTraversable-      DerivingStrategies-      GeneralizedNewtypeDeriving-      StandaloneDeriving-      BangPatterns-      KindSignatures-      TypeOperators+      DeriveLift+      FlexibleContexts+      FlexibleInstances+      MultiParamTypeClasses+      GADTs+      PolyKinds+      RoleAnnotations+      RankNTypes       TypeApplications-      DataKinds+      DefaultSignatures       TypeFamilies-      UndecidableInstances+      DataKinds+      MagicHash+      ImportQualifiedPost       StandaloneKindSignatures-      RankNTypes       ScopedTypeVariables+      TypeOperators   ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N   build-depends:-      aeson >=1.5 && <2.1-    , base >=4.12 && <4.17+      aeson >=2.0.2.0 && <2.1+    , base >=4.12 && <5+    , binrep+    , blake3 ==0.2.*     , bytepatch     , bytestring >=0.10 && <0.12     , either >=5.0.1.1 && <5.1-    , generic-optics >=2.1 && <2.4+    , generic-optics >=2.2.1.0 && <2.3+    , heystone >=0.1.0 && <0.2     , megaparsec >=9.0 && <9.3+    , memory ==0.17.*     , mtl >=2.2.2 && <2.3     , optics >=0.3 && <0.5-    , optparse-applicative >=0.16.1 && <0.17+    , optparse-applicative ==0.17.*+    , refined ==0.7.*+    , singletons ==3.0.*+    , singletons-base ==3.1.*+    , singletons-th ==3.1.*     , text >=1.2.4.1 && <1.3-    , vinyl >=0.13.3 && <0.14-    , yaml >=0.11.7 && <0.12+    , text-short >=0.1.5 && <0.2+    , vinyl >=0.14.1 && <0.15+    , yaml >=0.11.6.0 && <0.12   default-language: Haskell2010  test-suite spec   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:-      BytePatch.HexByteStringSpec       StreamPatch.ApplySpec       StreamPatch.Patch.AlignSpec       StreamPatch.Patch.LinearizeSpec@@ -146,44 +186,59 @@       test   default-extensions:       EmptyCase-      FlexibleContexts-      FlexibleInstances-      InstanceSigs-      MultiParamTypeClasses       LambdaCase+      InstanceSigs+      BangPatterns+      ExplicitNamespaces+      DerivingStrategies+      DerivingVia+      StandaloneDeriving+      DeriveAnyClass       DeriveGeneric-      DeriveFoldable+      DeriveDataTypeable       DeriveFunctor-      DeriveGeneric-      DeriveLift+      DeriveFoldable       DeriveTraversable-      DerivingStrategies-      GeneralizedNewtypeDeriving-      StandaloneDeriving-      BangPatterns-      KindSignatures-      TypeOperators+      DeriveLift+      FlexibleContexts+      FlexibleInstances+      MultiParamTypeClasses+      GADTs+      PolyKinds+      RoleAnnotations+      RankNTypes       TypeApplications-      DataKinds+      DefaultSignatures       TypeFamilies-      UndecidableInstances+      DataKinds+      MagicHash+      ImportQualifiedPost       StandaloneKindSignatures-      RankNTypes       ScopedTypeVariables+      TypeOperators+  ghc-options: -Wall   build-tool-depends:       hspec-discover:hspec-discover >=2.7 && <2.10   build-depends:       QuickCheck >=2.14.2 && <2.15-    , aeson >=1.5 && <2.1-    , base >=4.12 && <4.17+    , aeson >=2.0.2.0 && <2.1+    , base >=4.12 && <5+    , binrep+    , blake3 ==0.2.*     , bytepatch     , bytestring >=0.10 && <0.12     , either >=5.0.1.1 && <5.1-    , generic-optics >=2.1 && <2.4+    , generic-optics >=2.2.1.0 && <2.3+    , heystone >=0.1.0 && <0.2     , hspec >=2.7 && <2.10     , megaparsec >=9.0 && <9.3+    , memory ==0.17.*     , mtl >=2.2.2 && <2.3     , optics >=0.3 && <0.5+    , singletons ==3.0.*+    , singletons-base ==3.1.*+    , singletons-th ==3.1.*     , text >=1.2.4.1 && <1.3-    , vinyl >=0.13.3 && <0.14+    , text-short >=0.1.5 && <0.2+    , vinyl >=0.14.1 && <0.15   default-language: Haskell2010

@@ -0,0 +1,31 @@+module Binrep.Type.Assembly where++import GHC.Generics ( Generic )+import Data.Data ( Typeable, Data )++import Data.ByteString.Short ( ShortByteString )+import Data.ByteString ( ByteString )+import Data.Text.Short ( ShortText )+import Data.Aeson ( ToJSON, FromJSON )++import Binrep.Extra.HexByteString++import Binrep++data Arch+  = ArmV8ThumbLE+    deriving stock (Generic, Typeable, Data, Show, Eq)++newtype MachineInstr (arch :: Arch) = MachineInstr { getMachineInstr :: ShortByteString }+    deriving stock (Generic, Typeable, Data)+    deriving Show via (Hex ShortByteString)++newtype MachineCode  (arch :: Arch) = MachineCode  { getMachineCode  :: ByteString }+    deriving stock (Generic, Typeable, Data)+    deriving Eq via ByteString+    deriving Show via (Hex ByteString)+    deriving (BLen, Put, Get) via ByteString++newtype AsmInstr     (arch :: Arch) = AsmInstr     { getAsmInstr     :: ShortText }+    deriving stock (Generic, Typeable, Data, Show, Eq)+    deriving (ToJSON, FromJSON) via ShortText

@@ -0,0 +1,68 @@+{-# LANGUAGE OverloadedStrings #-}++module Binrep.Type.Assembly.Assemble where++import Binrep.Type.Assembly++import Heystone qualified as Keystone+import System.IO.Unsafe ( unsafeDupablePerformIO )+import Control.Monad.IO.Class+import Data.ByteString qualified as BS+import Data.Text.Short qualified as Text.Short+import Data.Text qualified as Text+import Data.List qualified as List++class Assemble arch where+    assemble :: [AsmInstr arch] -> Either String (MachineCode arch)++assemble1+    :: forall arch. Assemble arch+    => AsmInstr arch -> Either String (MachineCode arch)+assemble1 inst = assemble [inst]++instance Assemble 'ArmV8ThumbLE where+    assemble =+          fmap MachineCode+        . unsafeDupablePerformIO+        . assemble' Keystone.ArchArm modeFlags+        . prepInstrs+      where+        modeFlags =+            [Keystone.ModeV8, Keystone.ModeThumb, Keystone.ModeLittleEndian]++-- | TODO This is stupid because the assembler takes a '[String]'. Great for+--   end-user, poor for performance. I want the option to give it a+--   'BS.ByteString' that I've already prepared (as is the interface).+prepInstrs :: forall arch. [AsmInstr arch] -> [String]+prepInstrs =+      List.singleton+    . Text.unpack+    . Text.intercalate (Text.pack ";")+    . map (Text.Short.toText . getAsmInstr)++-- | Ideally, the assembler takes a raw 'BS.ByteString'. A+--   'BS.Short.ShortByteString' isn't appropriate, because it could be quite+--   large. But this way, this function is basically "compose a bunch of short+--   bytestrings into one big one".+prepInstrs' :: forall arch. [AsmInstr arch] -> BS.ByteString+prepInstrs' =+      BS.intercalate ";"+    . map (Text.Short.toByteString . getAsmInstr)++assemble'+    :: MonadIO m+    => Keystone.Architecture -> [Keystone.Mode]+    -> [String]+    -> m (Either String BS.ByteString)+assemble' arch modes instrs = do+    let as' = Keystone.open arch modes+    liftIO (Keystone.runAssembler as') >>= \case+      Left  e  -> err $ "failed to obtain assembler: "<>show e+      Right as -> do+        let out' = Keystone.assemble as instrs Nothing+        -- TODO have to inspect engine to find error. probably say if x=1 OK, if+        -- x>1 weird error, if x<1 check errno->strerror+        liftIO (Keystone.runAssembler out') >>= \case+          Left e -> err $ "error while assembling: "<>show e+          Right (mc, _count) -> return $ Right mc+  where err = return . Left

@@ -0,0 +1,8 @@+module Binrep.Type.Assembly.Disassemble where++import Binrep.Type.Assembly++import Numeric.Natural ( Natural )++class Disassemble arch where+    disassemble :: Natural -> (MachineCode arch) -> Either String [AsmInstr arch]

@@ -1,133 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE OverloadedStrings #-}--module BytePatch where--import           StreamPatch.Patch-import qualified StreamPatch.Patch.Binary as Bin-import qualified StreamPatch.Patch.Align  as Align--import           Numeric.Natural-import           Data.Functor.Const-import           Data.Vinyl-import           Data.Vinyl.TypeLevel-import           Data.Aeson-import           GHC.Generics ( Generic )--data MultiPatch s a = MultiPatch-  { mpData :: a-  , mpAt :: [Seek s a]-  } deriving (Generic)--deriving instance (Eq   a, Eq   (SeekRep s)) => Eq   (MultiPatch s a)-deriving instance (Show a, Show (SeekRep s)) => Show (MultiPatch s a)--data Seek s a = Seek-  { sSeek :: SeekRep s-  , sExpected :: Maybe a-  , sNullTerminates :: Maybe (SeekRep 'FwdSeek)-  , sMaxBytes :: Maybe (SeekRep 'FwdSeek) -- TODO confirm meaning, maybe improve name-  , sAligned :: Maybe Natural-  } deriving (Generic)--deriving instance (Eq   a, Eq   (SeekRep s)) => Eq   (Seek s a)-deriving instance (Show a, Show (SeekRep s)) => Show (Seek s a)---- TODO write a Text newtype for Haskell-style negated integers -- allowing--- negative hex integers!-data Aligned p = Aligned-  { alignedAlign   :: SeekRep 'RelSeek-  , alignedPatches :: [p]-  } deriving (Eq, Show, Generic)------------------------------------------------------------------------------------jsonCfgCamelDrop :: Int -> Options-jsonCfgCamelDrop x = defaultOptions-  { fieldLabelModifier = camelTo2 '_' . drop x-  , rejectUnknownFields = False }--instance (ToJSON   (SeekRep s), ToJSON   a) => ToJSON   (MultiPatch s a) where-    toJSON     = genericToJSON     $ jsonCfgCamelDrop 2-    toEncoding = genericToEncoding $ jsonCfgCamelDrop 2-instance (FromJSON (SeekRep s), FromJSON a) => FromJSON (MultiPatch s a) where-    parseJSON  = genericParseJSON  $ jsonCfgCamelDrop 2--instance (ToJSON   (SeekRep s), ToJSON   a) => ToJSON   (Seek s a) where-    toJSON     = genericToJSON     $ jsonCfgCamelDrop 1-    toEncoding = genericToEncoding $ jsonCfgCamelDrop 1-instance (FromJSON (SeekRep s), FromJSON a) => FromJSON (Seek s a) where-    parseJSON  = genericParseJSON  $ jsonCfgCamelDrop 1--instance (ToJSON   p) => ToJSON   (Aligned p) where-    toJSON     = genericToJSON     $ jsonCfgCamelDrop 7-    toEncoding = genericToEncoding $ jsonCfgCamelDrop 7-instance (FromJSON p) => FromJSON (Aligned p) where-    parseJSON  = genericParseJSON  $ jsonCfgCamelDrop 7------------------------------------------------------------------------------------convert :: (Seek s a -> Rec (Flap a) fs) -> MultiPatch s a -> [Patch s fs a]-convert f p = map go (mpAt p)-  where go s = Patch { patchData = mpData p-                     , patchSeek = sSeek s-                     , patchMeta = FunctorRec $ f s }---- TODO how to clean up (it's like liftA2 over n instead of 2. like a fold)--- likely 'ap'!-convertBinAlign-    :: forall s a-    .  SeekRep s ~ Natural-    => MultiPatch 'RelSeek a-    -> [Patch 'RelSeek '[Const (Align.Meta s), Const Bin.Meta, Bin.MetaStream] a]-convertBinAlign p = convert go p-  where go s = cmAlign s <+> cmBin s <+> cmBinStream s--convertBin-    :: forall s a-    .  MultiPatch s a-    -> [Patch s '[Const Bin.Meta, Bin.MetaStream] a]-convertBin p = convert go p-  where go s = cmBin s <+> cmBinStream s--convertAlign-    :: forall s a-    .  SeekRep s ~ Natural-    => MultiPatch 'RelSeek a-    -> [Patch 'RelSeek '[Const (Align.Meta s)] a]-convertAlign p = convert cmAlign p--convertEmpty-    :: forall s a-    .  MultiPatch s a-    -> [Patch s '[] a]-convertEmpty p = convert (const RNil) p------------------------------------------------------------------------------------align-    :: forall s a ss rs is i r-    .  ( SeekRep s ~ Natural-       , r ~ Const (Align.Meta s)-       , rs ~ RDelete r ss-       , RElem r ss i-       , RSubset rs ss is )-    => Aligned (Patch 'RelSeek ss a)-    -> Either (Align.Error s) [Patch s rs a]-align (Aligned a ps) = traverse (Align.align a) ps------------------------------------------------------------------------------------cmBin :: Seek s a -> Rec (Flap a) '[Const Bin.Meta]-cmBin s = cm $ Const $ Bin.Meta { Bin.mMaxBytes = sMaxBytes s }--cmBinStream :: Seek s a -> Rec (Flap a) '[Bin.MetaStream]-cmBinStream s = cm $ Bin.MetaStream-    { Bin.msNullTerminates = sNullTerminates s-    , Bin.msExpected = sExpected s }--cmAlign :: SeekRep s ~ Natural => Seek 'RelSeek a -> Rec (Flap a) '[Const (Align.Meta s)]-cmAlign s = cm $ Const $ Align.Meta { Align.mExpected = sAligned s }--cm :: f a -> Rec (Flap a) '[f]-cm fa = Flap fa :& RNil

@@ -1,68 +0,0 @@-{- |-A 'BS.ByteString' newtype wrapper indicating a human-readable bytestring, to be-displayed in hex form (e.g. 00 12 AB FF).--}--module BytePatch.HexByteString-  ( HexByteString(..)-  , parseHexByteString-  , prettyHexByteString-  ) where--import           StreamPatch.Patch.Binary ( BinRep(..) )--import           Data.Void-import           Text.Megaparsec-import qualified Text.Megaparsec.Char       as MC-import qualified Data.ByteString            as BS-import qualified Data.Char                  as Char-import           Data.Word-import qualified Data.Text                  as Text-import           Data.Text                  ( Text )-import           Data.List                  as List-import           Data.Aeson--newtype HexByteString = HexByteString { unHexByteString :: BS.ByteString }-    deriving (Eq)--instance Show HexByteString where-    show = Text.unpack . prettyHexByteString . unHexByteString--instance BinRep HexByteString where-    toBinRep = Right . unHexByteString--instance FromJSON HexByteString where-    parseJSON = withText "hex bytestring" $ \t ->-        case parseMaybe @Void parseHexByteString t of-          Nothing -> fail "failed to parse hex bytestring (TODO)"-          Just t' -> pure (HexByteString t')-instance ToJSON   HexByteString where-    toJSON = String . prettyHexByteString . unHexByteString---- | A hex bytestring looks like this: @00 01 89 8a   FEff@. You can mix and--- match capitalization and spacing, but I prefer to space each byte, full caps.-parseHexByteString :: (MonadParsec e s m, Token s ~ Char) => m BS.ByteString-parseHexByteString = BS.pack <$> parseHexByte `sepBy` MC.hspace---- | Parse a byte formatted as two hex digits e.g. EF. You _must_ provide both--- nibbles e.g. @0F@, not @F@. They cannot be spaced e.g. @E F@ is invalid.------ Returns a value 0-255, so can fit in any Num type that can store that.-parseHexByte :: (MonadParsec e s m, Token s ~ Char, Num a) => m a-parseHexByte = do-    c1 <- MC.hexDigitChar-    c2 <- MC.hexDigitChar-    return $ 0x10 * fromIntegral (Char.digitToInt c1) + fromIntegral (Char.digitToInt c2)--prettyHexByteString :: BS.ByteString -> Text-prettyHexByteString =-    Text.concat . List.intersperse (Text.singleton ' ') . fmap (f . prettyHexByte) . BS.unpack-  where-    f :: (Char, Char) -> Text-    f (c1, c2) = Text.cons c1 $ Text.singleton c2--prettyHexByte :: Word8 -> (Char, Char)-prettyHexByte w = (prettyNibble h, prettyNibble l)-  where-    (h,l) = fromIntegral w `divMod` 0x10-    prettyNibble = Char.toUpper . Char.intToDigit

@@ -0,0 +1,187 @@+{-# LANGUAGE AllowAmbiguousTypes, UndecidableInstances #-}++module Raehik.HFunctorMap where++import Data.Kind+import GHC.TypeLits+import Data.Vinyl+import Data.Vinyl.TypeLevel+import GHC.Generics ( Generic )+import Data.Aeson+import GHC.Exts+import Data.Aeson.KeyMap qualified as KM+import Data.Aeson.Key qualified as K++-- labelled flipped application+type LFlap :: k -> (Symbol, k -> Type) -> Type+newtype LFlap a fl = LFlap { getLFlap :: (Snd fl) a }+    deriving stock (Generic)+deriving stock    instance Show   (Snd fl a) => Show   (LFlap a fl)+deriving anyclass instance ToJSON (Snd fl a) => ToJSON (LFlap a fl)++{-+newtype Flap a f = Flap { getFlap :: f a }+    deriving stock   (Generic, Show, Eq, Ord)+    deriving Storable via (f a)+    deriving (ToJSON, FromJSON) via (f a)+-}++lFlap :: forall l a f. f a -> LFlap a '(l, f)+lFlap = LFlap++-- labelled functor list+newtype LFunctorList fs a = LFunctorList { getLFunctorList :: Rec (LFlap a) fs }+    deriving stock (Generic)+deriving stock    instance+    (ReifyConstraint Show (LFlap a) fs, RMap fs, RecordToList fs)+      => Show (LFunctorList fs a)++instance ToJSON (LFunctorList '[] a) where+    toJSON (LFunctorList RNil) = Object mempty+instance (ToJSON (f a), KnownSymbol l, ToJSON (LFunctorList fs a)) => ToJSON (LFunctorList ('(l, f) ': fs) a) where+    toJSON (LFunctorList (LFlap fa :& fs)) =+        let Object os = toJSON $ LFunctorList fs+            label = symbolVal'' @l+            o = toJSON fa+        in  Object $ KM.insert (K.fromString label) o os++symbolVal'' :: forall l. KnownSymbol l => String+symbolVal'' = symbolVal' (proxy# :: Proxy# l)++-- use with visible type applications+lflgetf+    :: forall (l :: Symbol) f fs a+    .  ( HasField Rec l fs fs f f )+    => LFunctorList fs a -> f a+lflgetf = getLFlap . rget @(l ::: f) . getLFunctorList++{-++import Data.Vinyl+import Data.Vinyl.TypeLevel ( RDelete, RIndex )+import Control.Applicative  ( liftA2 )+import GHC.Generics         ( Generic, Rep )+import Foreign.Storable     ( Storable )++import Optics++import Data.Aeson++instance ( ToJSON (Flap a r), Generic (Rec (Flap a) rs)+         , GToJSON' Value Zero (Rep (Rec (Flap a) rs))+         , GToJSON' Encoding Zero (Rep (Rec (Flap a) rs))+         ) => ToJSON (Rec (Flap a) (r ': rs))++-- | A list of functors parametric over a "shared" 'a', where each functor+--   stores a single value 'f a'.+--+-- Just a wrapper on top of Vinyl with some types swap around.+newtype HFunctorList fs a = HFunctorList { getHFunctorList :: Rec (Flap a) fs }+    deriving stock (Generic)++deriving via (Rec (Flap a) fs) instance ToJSON (Rec (Flap a) fs) => ToJSON (HFunctorList fs a)++deriving instance (ReifyConstraint Show (Flap a) fs, RMap fs, RecordToList fs) => Show (HFunctorList fs a)+deriving instance Eq        (Rec (Flap a) fs) => Eq        (HFunctorList fs a)+deriving instance Ord       (Rec (Flap a) fs) => Ord       (HFunctorList fs a)++-- Right. I only partly get this. As I understand, I'm leveraging deriving via+-- to generate the instance bodies, since they look the same as Rec but with a+-- set functor. So I just have to assure it that you can make it Storable in the+-- same way, given that @Flap a@ is storable (which is handled similarly at its+-- own definition).+deriving via (Rec (Flap a) '[])       instance Storable (HFunctorList '[] a)+deriving via (Rec (Flap a) (f ': fs)) instance (Storable (f a), Storable (Rec (Flap a) fs)) => Storable (HFunctorList (f ': fs) a)++-- It appears we can't do the same for 'Functor' etc., because the @a@ type+-- variable isn't bound, but must be for us to say what type to derive via. I+-- wonder if there is a workaround, but I can't figure it out.+instance Functor (HFunctorList '[]) where+  fmap _ (HFunctorList RNil) = HFunctorList RNil+instance (Functor r, Functor (HFunctorList rs)) => Functor (HFunctorList (r ': rs)) where+  fmap f (HFunctorList (Flap r :& rs)) =+    HFunctorList (Flap (fmap f r) :& getHFunctorList (fmap f (HFunctorList rs)))++instance Applicative (HFunctorList '[]) where+  pure _ = HFunctorList RNil+  HFunctorList RNil <*> HFunctorList RNil = HFunctorList RNil+instance (Applicative r, Applicative (HFunctorList rs)) => Applicative (HFunctorList (r ': rs)) where+  pure a = HFunctorList (Flap (pure a) :& getHFunctorList (pure a))+  HFunctorList (Flap f :& fs) <*> HFunctorList (Flap a :& as) =+    HFunctorList (Flap (f <*> a) :& getHFunctorList (HFunctorList fs <*> HFunctorList as))++instance Foldable (HFunctorList '[]) where+  foldr _ z (HFunctorList RNil) = z+instance (Foldable r, Foldable (HFunctorList rs)) => Foldable (HFunctorList (r ': rs)) where+    -- only foldmap because foldr is harder looool+    foldMap f (HFunctorList (Flap r :& rs)) = foldMap f r <> foldMap f (HFunctorList rs)++-- this took me ages because I'm stupid T_T+instance Traversable (HFunctorList '[]) where+  traverse _ (HFunctorList RNil) = pure (HFunctorList RNil)+instance (Traversable r, Traversable (HFunctorList rs)) => Traversable (HFunctorList (r ': rs)) where+  traverse+      :: forall f a b. Applicative f+      => (a -> f b)+      -> (HFunctorList (r ': rs)) a+      -> f (HFunctorList (r ': rs) b)+  traverse f (HFunctorList (Flap (r :: r a) :& rs)) =+      HFunctorList <$> rBoth+    where+      rBoth :: f (Rec (Flap b) (r ': rs))+      rBoth = liftA2 (:&) rHead rTail+      rHead :: f (Flap b r)+      rHead = Flap <$> traverse f r+      rTail :: f (Rec (Flap b) rs)+      rTail = getHFunctorList <$> traverse f (HFunctorList rs)++-- | Flipped apply: a single value at 'f a', but with "flipped" type arguments.+--   Very useless - has no Functor nor Contravariant nor HFunctor instance.+newtype Flap a f = Flap { getFlap :: f a }+    deriving stock   (Generic, Show, Eq, Ord)+    deriving Storable via (f a)+    deriving (ToJSON, FromJSON) via (f a)++--------------------------------------------------------------------------------++-- | Get the value at a type in an HFunctorList.+hflGet+    :: forall f fs a i+    .  RElem f fs i+    => HFunctorList fs a+    -> f a+hflGet = getFlap . rget . getHFunctorList++-- | Put a value at a type in an HFunctorList.+hflPut+    :: forall f f' fs fs' a+    .  RecElem Rec f f' fs fs' (RIndex f fs)+    => f' a+    -> HFunctorList fs a+    -> HFunctorList fs' a+hflPut x = HFunctorList . rput' @_ @f (Flap x) . getHFunctorList++-- | Get a lens to the value at a type in an HFunctorList.+hflLens+    :: forall f f' fs fs' a s t+    .  ( RecElem Rec f f' fs fs' (RIndex f fs)+       , RElem f fs (RIndex f fs)+       , s ~ HFunctorList fs  a+       , t ~ HFunctorList fs' a )+    => Lens s t (f a) (f' a)+hflLens = lens hflGet (\hfl x -> hflPut @f x hfl)++-- | Use the value at a type in an HFunctorList, and remove it from the list.+hflStrip+    :: forall f fs a fs' b i is+    .  ( RElem f fs i+       , fs' ~ RDelete f fs+       , RSubset fs' fs is )+    => (f a -> b)+    -> HFunctorList fs a+    -> (b, HFunctorList fs' a)+hflStrip f hfl =+    let hfl' = HFunctorList $ rcast $ getHFunctorList hfl+     in (f (hflGet hfl), hfl')++-}

@@ -1,60 +1,121 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+ module StreamPatch.Apply where -import           StreamPatch.Stream-import           StreamPatch.Patch-import qualified StreamPatch.Patch.Binary   as Bin-import           StreamPatch.Patch.Binary   ( BinRep )+import GHC.Generics ( Generic ) -import           Data.Vinyl-import qualified Data.ByteString            as BS-import qualified Data.ByteString.Builder    as BB-import qualified Data.ByteString.Lazy       as BL-import           Control.Monad.State-import           StreamPatch.Util           ( traverseM_ )+import StreamPatch.Patch+import StreamPatch.Stream+import StreamPatch.HFunctorList+import StreamPatch.Patch.Binary qualified as Bin+import StreamPatch.Patch.Compare qualified as Compare+import StreamPatch.Patch.Compare ( Compare(..), compareTo )+import StreamPatch.Patch.Linearize.InPlace ( HasLength, getLength ) --- TODO how to clean up, use Either monad inside m? (lift didn't work)-applyBinFwd-    :: forall a m. (MonadFwdInplaceStream m, Chunk m ~ BS.ByteString, BinRep a)-    => Bin.Cfg-    -> [Patch 'FwdSeek '[Bin.MetaStream] a]-    -> m (Either (Bin.Error a) ())-applyBinFwd cfg = traverseM_ $ \(Patch a s (FunctorRec (Flap m :& RNil))) -> do-    case Bin.toBinRep' a of-      Left err -> return $ Left err-      Right bs -> do-        advance s-        bsStream <- readahead $ fromIntegral $ BS.length bs-        case Bin.check cfg bsStream m of-          Left err -> return $ Left err-          Right () -> do-            overwrite bs-            return $ Right ()+import Data.Vinyl+import Data.ByteString qualified as BS+import Data.ByteString.Builder qualified as BB+import Data.ByteString.Lazy qualified as BL+import Control.Monad.State+import StreamPatch.Util ( traverseM_ ) -runPureFwdBin-    :: BinRep a-    => Bin.Cfg-    -> [Patch 'FwdSeek '[Bin.MetaStream] a]+import Control.Monad.Except++data Error+  = ErrorCompare String+  | ErrorBinUnexpectedNonNull BS.ByteString+    deriving (Generic, Eq, Show)++applyBinCompareFwd+    :: forall v m+    .  ( FwdInplaceStream m, Chunk m ~ BS.ByteString+       , Compare v BS.ByteString, Num (Index m) )+    => [Patch (Index m) '[Compare.Meta v, Bin.Meta] BS.ByteString]+    -> m (Either Error ())+applyBinCompareFwd = traverseM_ $ \(Patch bs s (HFunctorList (Flap cm :& Flap bm :& RNil))) -> runExceptT $ do+    -- advance to patch location+    lift $ advance s++    -- read same number of bytes as patch data+    bsStream  <- lift $ readahead $ fromIntegral $ getLength bs++    -- check for & strip expected terminating nulls+    bsStream' <- doNullTermCheck bsStream (Bin.mNullTerminates bm)++    -- compare with expected data+    doCompare bsStream' $ Compare.mCompare cm++    -- if that was all successful, write patch in-place+    lift $ overwrite bs+  where+    err = throwError+    doCompare bs' = \case+      Nothing   -> return ()+      Just cmp -> do+        case compareTo @v cmp bs' of+          Nothing -> return ()+          Just e -> err $ ErrorCompare e+    doNullTermCheck bs' = \case+      Nothing -> return bs'+      Just nt ->+        let (bs'', bsNulls) = BS.splitAt (fromIntegral nt) bs'+         in if   bsNulls == BS.replicate (BS.length bsNulls) 0x00+            then return bs''+            else err $ ErrorBinUnexpectedNonNull bs'++runPureBinCompareFwd+    :: (Compare v BS.ByteString)+    => [Patch Int '[Compare.Meta v, Bin.Meta] BS.ByteString]     -> BS.ByteString-    -> Either (Bin.Error a) BL.ByteString-runPureFwdBin cfg ps bs =-    let (mErr, (bsRemaining, bbPatched)) = runState (applyBinFwd cfg ps) (bs, mempty)+    -> Either Error BL.ByteString+runPureBinCompareFwd ps bs =+    let initState = (bs, mempty :: BB.Builder, 0 :: Int)+        (mErr, (bsRemaining, bbPatched, _)) = runState (applyBinCompareFwd ps) initState         bbPatched' = bbPatched <> BB.byteString bsRemaining      in case mErr of-          Left err -> Left err+          Left  e  -> Left e           Right () -> Right $ BB.toLazyByteString bbPatched' -applySimpleFwd-    :: (MonadFwdInplaceStream m, Chunk m ~ a)-    => [Patch 'FwdSeek '[] a]+applyFwd+    :: (FwdInplaceStream m, Chunk m ~ a)+    => [Patch (Index m) '[] a]     -> m ()-applySimpleFwd =-    mapM_ $ \(Patch a s (FunctorRec RNil)) -> advance s >> overwrite a+applyFwd =+    mapM_ $ \(Patch a s (HFunctorList RNil)) ->+        advance s >> overwrite a --- stupid because no monotraversable :<-runPureSimpleFwdList-    :: [Patch 'FwdSeek '[] [a]]+runPureFwdList+    :: [Patch Int '[] [a]]     -> [a]     -> [a]-runPureSimpleFwdList ps start =-    let ((), (remaining, patched)) = runState (applySimpleFwd ps) (start, mempty)+runPureFwdList ps start =+    let ((), (remaining, patched, _)) = runState (applyFwd ps) (start, mempty, 0 :: Int)      in patched <> remaining++applyFwdCompare+    :: forall a v m+    .  ( FwdInplaceStream m, Chunk m ~ a+       , Compare v a, HasLength a, Num (Index m) )+    => [Patch (Index m) '[Compare.Meta v] a]+    -> m (Either Error ())+applyFwdCompare = traverseM_ $ \(Patch a s (HFunctorList (Flap cm :& RNil))) -> do+    advance s+    aStream <- readahead $ fromIntegral $ getLength a+    case Compare.mCompare cm of+      Nothing   -> do+        x <- overwrite a+        return $ Right x+      Just aCmp -> case compareTo @v aCmp aStream of+                     Nothing -> return $ Right ()+                     Just e  -> return $ Left $ ErrorCompare e++runPureFwdCompareString+    :: Compare v String+    => [Patch Int '[Compare.Meta v] String]+    -> String+    -> Either Error String+runPureFwdCompareString ps start =+    let (r, (remaining, patched, _)) = runState (applyFwdCompare ps) (start, "", 0 :: Int)+    in  case r of+          Left err -> Left err+          Right () -> Right $ patched <> remaining

@@ -0,0 +1,19 @@+{-# LANGUAGE OverloadedStrings #-}++module StreamPatch.Example where++import StreamPatch.Patch+import StreamPatch.Seek+import StreamPatch.Patch.Compare qualified as Compare+import StreamPatch.Patch.Compare ( Via(..), EqualityCheck(..) )+import StreamPatch.HFunctorList+import Data.Vinyl++import Data.Text ( Text )+import Numeric.Natural++ex :: Patch (SIx Natural) '[Compare.Meta ('ViaEq 'Exact)] Text+ex = Patch "no way this works LMAO" (SIx 0) $ HFunctorList $ Flap (Compare.Meta Nothing) :& RNil++ex2 :: Patch (SIx Natural) '[] Text+ex2 = Patch "no way this works LMAO" (SIx 0) $ HFunctorList RNil

@@ -0,0 +1,130 @@+{-# LANGUAGE AllowAmbiguousTypes, UndecidableInstances #-}++module StreamPatch.HFunctorList where++import Data.Vinyl+import Data.Vinyl.TypeLevel ( RDelete, RIndex )+import Control.Applicative  ( liftA2 )+import GHC.Generics         ( Generic, Rep )+import Foreign.Storable     ( Storable )++import Optics++import Data.Aeson++instance ( ToJSON (Flap a r), Generic (Rec (Flap a) rs)+         , GToJSON' Value Zero (Rep (Rec (Flap a) rs))+         , GToJSON' Encoding Zero (Rep (Rec (Flap a) rs))+         ) => ToJSON (Rec (Flap a) (r ': rs))++-- | A list of functors parametric over a "shared" 'a', where each functor+--   stores a single value 'f a'.+--+-- Just a wrapper on top of Vinyl with some types swap around.+newtype HFunctorList fs a = HFunctorList { getHFunctorList :: Rec (Flap a) fs }+    deriving stock (Generic)++deriving via (Rec (Flap a) fs) instance ToJSON (Rec (Flap a) fs) => ToJSON (HFunctorList fs a)++deriving instance (ReifyConstraint Show (Flap a) fs, RMap fs, RecordToList fs) => Show (HFunctorList fs a)+deriving instance Eq        (Rec (Flap a) fs) => Eq        (HFunctorList fs a)+deriving instance Ord       (Rec (Flap a) fs) => Ord       (HFunctorList fs a)++-- Right. I only partly get this. As I understand, I'm leveraging deriving via+-- to generate the instance bodies, since they look the same as Rec but with a+-- set functor. So I just have to assure it that you can make it Storable in the+-- same way, given that @Flap a@ is storable (which is handled similarly at its+-- own definition).+deriving via (Rec (Flap a) '[])       instance Storable (HFunctorList '[] a)+deriving via (Rec (Flap a) (f ': fs)) instance (Storable (f a), Storable (Rec (Flap a) fs)) => Storable (HFunctorList (f ': fs) a)++-- It appears we can't do the same for 'Functor' etc., because the @a@ type+-- variable isn't bound, but must be for us to say what type to derive via. I+-- wonder if there is a workaround, but I can't figure it out.+instance Functor (HFunctorList '[]) where+  fmap _ (HFunctorList RNil) = HFunctorList RNil+instance (Functor r, Functor (HFunctorList rs)) => Functor (HFunctorList (r ': rs)) where+  fmap f (HFunctorList (Flap r :& rs)) =+    HFunctorList (Flap (fmap f r) :& getHFunctorList (fmap f (HFunctorList rs)))++instance Applicative (HFunctorList '[]) where+  pure _ = HFunctorList RNil+  HFunctorList RNil <*> HFunctorList RNil = HFunctorList RNil+instance (Applicative r, Applicative (HFunctorList rs)) => Applicative (HFunctorList (r ': rs)) where+  pure a = HFunctorList (Flap (pure a) :& getHFunctorList (pure a))+  HFunctorList (Flap f :& fs) <*> HFunctorList (Flap a :& as) =+    HFunctorList (Flap (f <*> a) :& getHFunctorList (HFunctorList fs <*> HFunctorList as))++instance Foldable (HFunctorList '[]) where+  foldr _ z (HFunctorList RNil) = z+instance (Foldable r, Foldable (HFunctorList rs)) => Foldable (HFunctorList (r ': rs)) where+    -- only foldmap because foldr is harder looool+    foldMap f (HFunctorList (Flap r :& rs)) = foldMap f r <> foldMap f (HFunctorList rs)++-- this took me ages because I'm stupid T_T+instance Traversable (HFunctorList '[]) where+  traverse _ (HFunctorList RNil) = pure (HFunctorList RNil)+instance (Traversable r, Traversable (HFunctorList rs)) => Traversable (HFunctorList (r ': rs)) where+  traverse+      :: forall f a b. Applicative f+      => (a -> f b)+      -> (HFunctorList (r ': rs)) a+      -> f (HFunctorList (r ': rs) b)+  traverse f (HFunctorList (Flap (r :: r a) :& rs)) =+      HFunctorList <$> rBoth+    where+      rBoth :: f (Rec (Flap b) (r ': rs))+      rBoth = liftA2 (:&) rHead rTail+      rHead :: f (Flap b r)+      rHead = Flap <$> traverse f r+      rTail :: f (Rec (Flap b) rs)+      rTail = getHFunctorList <$> traverse f (HFunctorList rs)++-- | Flipped apply: a single value at 'f a', but with "flipped" type arguments.+--   Very useless - has no Functor nor Contravariant nor HFunctor instance.+newtype Flap a f = Flap { getFlap :: f a }+    deriving stock   (Generic, Show, Eq, Ord)+    deriving Storable via (f a)+    deriving (ToJSON, FromJSON) via (f a)++--------------------------------------------------------------------------------++-- | Get the value at a type in an HFunctorList.+hflGet+    :: forall f fs a i+    .  RElem f fs i+    => HFunctorList fs a+    -> f a+hflGet = getFlap . rget . getHFunctorList++-- | Put a value at a type in an HFunctorList.+hflPut+    :: forall f f' fs fs' a+    .  RecElem Rec f f' fs fs' (RIndex f fs)+    => f' a+    -> HFunctorList fs a+    -> HFunctorList fs' a+hflPut x = HFunctorList . rput' @_ @f (Flap x) . getHFunctorList++-- | Get a lens to the value at a type in an HFunctorList.+hflLens+    :: forall f f' fs fs' a s t+    .  ( RecElem Rec f f' fs fs' (RIndex f fs)+       , RElem f fs (RIndex f fs)+       , s ~ HFunctorList fs  a+       , t ~ HFunctorList fs' a )+    => Lens s t (f a) (f' a)+hflLens = lens hflGet (\hfl x -> hflPut @f x hfl)++-- | Use the value at a type in an HFunctorList, and remove it from the list.+hflStrip+    :: forall f fs a fs' b i is+    .  ( RElem f fs i+       , fs' ~ RDelete f fs+       , RSubset fs' fs is )+    => (f a -> b)+    -> HFunctorList fs a+    -> (b, HFunctorList fs' a)+hflStrip f hfl =+    let hfl' = HFunctorList $ rcast $ getHFunctorList hfl+     in (f (hflGet hfl), hfl')

@@ -1,78 +1,37 @@--- | Core patch type definitions: patches, seeks, metadata.--module StreamPatch.Patch where--import           Data.Kind-import           GHC.Generics ( Generic )-import           GHC.Natural-import           Data.Vinyl-import           Control.Applicative ( liftA2 )--type Patch :: SeekKind -> [Type -> Type] -> Type -> Type-data Patch s fs a = Patch-  { patchData :: a-  , patchSeek :: SeekRep s-  , patchMeta :: FunctorRec fs a-  } deriving (Generic)+{-# LANGUAGE UndecidableInstances #-} -deriving instance (Eq   a, Eq   (SeekRep s), Eq (Rec (Flap a) fs))  => Eq (Patch s fs a)-deriving instance (Show a, Show (SeekRep s), ReifyConstraint Show (Flap a) fs, RMap fs, RecordToList fs) => Show (Patch s fs a)-deriving instance (Functor (FunctorRec fs)) => Functor (Patch s fs)+{- | Core patch type: patches, seeks, metadata container. --- Taken from vinyl-plus. Functor and Applicative instances were provided.-newtype Flap a f = Flap { getFlap :: f a } deriving (Eq, Show, Generic)-newtype FunctorRec fs a = FunctorRec { getFunctorRec :: Rec (Flap a) fs } deriving (Generic)-deriving instance (ReifyConstraint Show (Flap a) fs, RMap fs, RecordToList fs) => Show (FunctorRec fs a)-deriving instance Eq (Rec (Flap a) fs) => Eq (FunctorRec fs a)+This library is based around patches to streams i.e. containers indexed by the+natural numbers (or integers, depending on your view). As such, we restrict what+a seek can look like. Parts of the codebase could be generalized to work over+any seek kind, so you could e.g. write a text patcher that uses line and column+positions to seek through the data. But you can't transform line and column to+byte position, at least not without parsing the file. So it would need a lot of+thought and careful design to generalize in that direction.+-} -instance Functor (FunctorRec '[]) where-  fmap _ (FunctorRec RNil) = FunctorRec RNil-instance (Functor r, Functor (FunctorRec rs)) => Functor (FunctorRec (r ': rs)) where-  fmap f (FunctorRec (Flap r :& rs)) =-    FunctorRec (Flap (fmap f r) :& getFunctorRec (fmap f (FunctorRec rs)))+module StreamPatch.Patch where -instance Applicative (FunctorRec '[]) where-  pure _ = FunctorRec RNil-  FunctorRec RNil <*> FunctorRec RNil = FunctorRec RNil-instance (Applicative r, Applicative (FunctorRec rs)) => Applicative (FunctorRec (r ': rs)) where-  pure a = FunctorRec (Flap (pure a) :& getFunctorRec (pure a))-  FunctorRec (Flap f :& fs) <*> FunctorRec (Flap a :& as) =-    FunctorRec (Flap (f <*> a) :& getFunctorRec (FunctorRec fs <*> FunctorRec as))+import StreamPatch.HFunctorList -instance Foldable (FunctorRec '[]) where-  foldr _ z (FunctorRec RNil) = z-instance (Foldable r, Foldable (FunctorRec rs)) => Foldable (FunctorRec (r ': rs)) where-    -- TODO foldr is harder lol-    foldMap f (FunctorRec (Flap r :& rs)) = foldMap f r <> foldMap f (FunctorRec rs)+import GHC.Generics ( Generic )+import Data.Data ( Data, Typeable )+import Data.Aeson --- I am shit at this LOL-instance Traversable (FunctorRec '[]) where-  traverse _ (FunctorRec RNil) = pure (FunctorRec RNil)-instance (Traversable r, Traversable (FunctorRec rs)) => Traversable (FunctorRec (r ': rs)) where-  traverse-      :: forall f a b. Applicative f-      => (a -> f b)-      -> (FunctorRec (r ': rs)) a-      -> f (FunctorRec (r ': rs) b)-  traverse f (FunctorRec (Flap (r :: r a) :& rs)) =-      FunctorRec <$> rBoth-    where-      rBoth :: f (Rec (Flap b) (r ': rs))-      rBoth = liftA2 (:&) rHead rTail-      rHead :: f (Flap b r)-      rHead = Flap <$> traverse f r-      rTail :: f (Rec (Flap b) rs)-      rTail = getFunctorRec <$> traverse f (FunctorRec rs)+-- | A single patch on a stream of 'a'.+data Patch s fs a = Patch+  { patchData :: a+  , patchSeek :: s+  , patchMeta :: HFunctorList fs a+  } deriving stock (Generic) --- | What a patch seek value means.-data SeekKind-  = FwdSeek -- ^ seeks only move cursor forward-  | RelSeek -- ^ seeks are relative e.g. to a universal base, or a stream cursor-  | AbsSeek -- ^ seeks specify an exact offset in stream-    deriving (Eq, Show, Generic)+deriving stock instance (Eq   a, Eq   s, Eq   (HFunctorList fs a)) => Eq   (Patch s fs a)+deriving stock instance (Show a, Show s, Show (HFunctorList fs a)) => Show (Patch s fs a)+deriving stock instance (Data a, Data s, Data (HFunctorList fs a), Typeable fs) => Data (Patch s fs a)+deriving stock instance Functor     (HFunctorList fs) => Functor     (Patch s fs)+deriving stock instance Foldable    (HFunctorList fs) => Foldable    (Patch s fs)+deriving stock instance Traversable (HFunctorList fs) => Traversable (Patch s fs) --- | Get the representation for a 'SeekKind'. Allows us a bit more safety.-type family SeekRep (s :: SeekKind) where-    SeekRep 'FwdSeek = Natural-    SeekRep 'RelSeek = Integer-    SeekRep 'AbsSeek = Natural+instance (ToJSON   a, ToJSON   s, ToJSON   (HFunctorList fs a)) => ToJSON   (Patch s fs a)+instance (FromJSON a, FromJSON s, FromJSON (HFunctorList fs a)) => FromJSON (Patch s fs a)

@@ -1,59 +1,49 @@ module StreamPatch.Patch.Align where -import           StreamPatch.Patch+import StreamPatch.Patch+import StreamPatch.HFunctorList ( hflStrip ) -import           GHC.Generics ( Generic )-import           Numeric.Natural-import           GHC.Natural ( naturalFromInteger )-import           Data.Vinyl-import           Data.Vinyl.TypeLevel-import           Data.Functor.Const+import GHC.Generics ( Generic )+import Data.Vinyl+import Data.Vinyl.TypeLevel+import Data.Functor.Const -data Meta s = Meta-  { mExpected :: Maybe (SeekRep s)+data Meta st = Meta+  { mExpected :: Maybe st   -- ^ Absolute stream offset for edit. Used for checking against actual offset.-  } deriving (Generic)--deriving instance (Eq   (SeekRep s)) => Eq   (Meta s)-deriving instance (Show (SeekRep s)) => Show (Meta s)--data Error s-  = ErrorSeekBelow0 (SeekRep 'RelSeek)-  | ErrorDoesntMatchExpected (SeekRep s) (SeekRep s) -- expected, then actual-    deriving (Generic)+  } deriving (Generic, Show, Eq) -deriving instance (Eq   (SeekRep s)) => Eq   (Error s)-deriving instance (Show (SeekRep s)) => Show (Error s)+data Error st+  = ErrorAlignedToNegative Integer -- guaranteed negative+  | ErrorDoesntMatchExpected st st+    deriving (Generic, Show, Eq)  -- | Attempt to align the given patch to 0 using the given base.+--+-- The resulting seek is guaranteed to be non-negative, so you may use+-- natural-like types safely.+--+-- TODO Complicated. align-    :: forall s a ss rs is i r-    .  ( SeekRep s ~ Natural-       , r ~ Const (Meta s)+    :: forall sf st a ss is r rs+    .  ( Integral sf, Num st, Eq st+       , r ~ Const (Meta st)        , rs ~ RDelete r ss-       , RElem r ss i+       , RElem r ss (RIndex r ss)        , RSubset rs ss is )-    => SeekRep 'RelSeek-    -> Patch 'RelSeek ss a-    -> Either (Error s) (Patch s rs a)-align sBase (Patch a s ms) =-    case tryIntegerToNatural sAligned of-      Nothing          -> Left $ ErrorSeekBelow0 sAligned-      Just sAlignedNat ->-        case mExpected m of-          Nothing        -> reform sAlignedNat-          Just sExpected ->-            if   sExpected == sAlignedNat-            then reform sAlignedNat-            else Left $ ErrorDoesntMatchExpected sExpected sAlignedNat+    => Integer+    -> Patch sf ss a+    -> Either (Error st) (Patch st rs a)+align sBase (Patch a s ms)+  | s' < 0 = Left $ ErrorAlignedToNegative s'+  | otherwise =+      case mExpected m of+        Nothing        -> Right $ Patch a s'' ms'+        Just sExpected ->+          if   sExpected == s''+          then Right $ Patch a s'' ms'+          else Left $ ErrorDoesntMatchExpected sExpected s''   where-    sAligned = sBase + s-    -- TODO require a visible type application here, unsure why. even without-    -- the SeekRep indirection-    m = getConst @(Meta s) $ getFlap $ rget $ getFunctorRec ms-    ms' = FunctorRec $ rcast @rs $ getFunctorRec ms-    reform s' = Right $ Patch a s' ms'--tryIntegerToNatural :: Integer -> Maybe Natural-tryIntegerToNatural n | n < 0     = Nothing-                      | otherwise = Just $ naturalFromInteger n+    s' = sBase + toInteger s+    s'' = fromInteger s'+    (m, ms') = hflStrip getConst ms

@@ -1,136 +1,109 @@ {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE AllowAmbiguousTypes #-}  -- TODO rewrite patch/check bits (some overlap)+-- TODO rewrite, rename checks (one for process, one for apply) -module StreamPatch.Patch.Binary-  ( Meta(..)-  , MetaStream(..)-  , Cfg(..)-  , Error(..)-  , patchBinRep-  , BinRep(..)-  , toBinRep'-  , check-  ) where+module StreamPatch.Patch.Binary where -import           StreamPatch.Patch+import StreamPatch.Patch+import StreamPatch.HFunctorList -import           GHC.Generics       ( Generic )-import           GHC.Natural-import qualified Data.ByteString    as BS-import qualified Data.Text.Encoding as Text-import qualified Data.Text          as Text-import           Data.Text          ( Text )-import           Data.Either.Combinators-import           Data.Vinyl-import           Data.Functor.Const-import           Data.Vinyl.TypeLevel+import Binrep -data Meta = Meta-  { mMaxBytes :: Maybe (SeekRep 'FwdSeek)-  -- ^ Maximum number of bytes permitted to write at the associated position.-  } deriving (Eq, Show, Generic)+import GHC.Generics       ( Generic )+import GHC.Natural+import Data.ByteString qualified as BS+import Data.Vinyl+import Data.Functor.Const+import Data.Vinyl.TypeLevel -data MetaStream a = MetaStream-  { msNullTerminates :: Maybe (SeekRep 'FwdSeek)-  -- ^ Stream segment should be null bytes (0x00) only from this index onwards.+import StreamPatch.Patch.Compare qualified as Compare+import StreamPatch.Patch.Compare hiding ( Meta ) -  , msExpected       :: Maybe a-  -- ^ Stream segment should be this.-  } deriving (Eq, Show, Generic, Functor, Foldable, Traversable)+import Optics -data Cfg = Cfg-  { cfgAllowPartialExpected :: Bool-  -- ^ If enabled, allow partial expected bytes checking. If disabled, then even-  --   if the expected bytes are a prefix of the actual, fail.+data Meta a = Meta+  { mNullTerminates :: Maybe Natural+  -- ^ Stream segment should be null bytes (0x00) only from this index onwards.+  } deriving (Generic, Eq, Show, Functor, Foldable, Traversable)++data MetaPrep = MetaPrep+  { mpMaxBytes :: Maybe Natural+  -- ^ Maximum bytelength of binrepped data.+  --+  -- Though binrepping is a safe operation, this is a useful sanity check in+  -- cases where you know the maximum space available.+  --+  -- Note that this is only available for the patch data, not other meta data.+  -- (If you want that, you'll need to shove this field into the patch type.)+  -- itself. Probably not very useful.)   } deriving (Eq, Show, Generic)  data Error a-  = ErrorBadBinRep a String-  | ErrorUnexpectedNonNull BS.ByteString-  | ErrorDidNotMatchExpected BS.ByteString BS.ByteString-  | ErrorBinRepTooLong BS.ByteString Natural+  = ErrorBinRepOverlong BLenT BLenT a (Maybe BS.ByteString)+  -- ^ If the value was serialized, it's given in the 'Maybe'.     deriving (Eq, Show, Generic, Functor, Foldable, Traversable) -patchBinRep-    :: forall a s ss rs is i r-    .  ( BinRep a-       , Traversable (FunctorRec rs)-       , r ~ Const Meta+-- Note that via binrep's 'BLen' typeclass, we can check sizing "for free",+-- without serializing. TODO, I could make another function that serializes,+-- then checks. That way, we can return the serialization attempt to the user,+-- and not require 'BLen'. In exchange, it's less efficient on errors. Both have+-- the same main path complexity.+binRepify+    :: forall a s ss is r rs+    .  ( Put a, BLen a+       , Traversable (HFunctorList rs)+       , r ~ Const MetaPrep        , rs ~ RDelete r ss-       , RElem r ss i+       , RElem r ss (RIndex r ss)        , RSubset rs ss is )     => Patch s ss a     -> Either (Error a) (Patch s rs BS.ByteString)-patchBinRep (Patch a s ms) = do-    a' <- toBinRep' a-    () <- case mMaxBytes m of-            Nothing       -> return ()-            Just maxBytes -> if   BS.length a' > fromIntegral maxBytes-                             then Left $ ErrorBinRepTooLong a' maxBytes-                             else return ()-    let msDroppedMeta = FunctorRec $ rcast @rs $ getFunctorRec ms-    ms' <- traverse toBinRep' msDroppedMeta-    return $ Patch a' s ms'-  where m = getConst @Meta $ getFlap $ rget $ getFunctorRec ms+binRepify (Patch a s ms) = do+    let (m, ms') = hflStrip getConst ms+    checkMeta m+    let bs = runPut a+        bsms = fmap runPut ms'+    return $ Patch bs s bsms+  where+    checkMeta m =+        case mpMaxBytes m of+          Nothing       -> return ()+          Just maxBytes ->+            let maxBytes' = natToBLen maxBytes+             in if   blen a > maxBytes'+                then Left $ ErrorBinRepOverlong (blen a) maxBytes' a Nothing+                else return () --- | Type has a binary representation for using in patchscripts.------ Patchscripts are parsed parameterized over the type to edit. That type needs--- to become a bytestring for eventual patch application. We're forced into--- newtypes and typeclasses by Aeson already, so this just enables us to define--- some important patch generation behaviour in one place. Similarly to Aeson,--- if you require custom behaviour for existing types (e.g. length-prefixed--- strings instead of C-style null terminated), define a newtype over it.+-- | Treat the nulls field as a "this is how many extra nulls there are", and+--   amend the compare meta for a patch by appending those nulls, and strip that+--   stream-time bin meta. ----- Some values may not have valid patch representations, for example if you're--- patching a 1-byte length-prefixed string and your string is too long (>255--- encoded bytes). Thus, 'toPatchRep' is failable.-class BinRep a where-    toBinRep :: a -> Either String BS.ByteString--toBinRep' :: BinRep a => a -> Either (Error a) BS.ByteString-toBinRep' a = mapLeft (ErrorBadBinRep a) $ toBinRep a---- | Bytestrings are copied as-is.-instance BinRep BS.ByteString where-    toBinRep = Right . id---- | Text is converted to UTF-8 bytes and null-terminated.-instance BinRep Text where-    toBinRep = Right . flip BS.snoc 0x00 . Text.encodeUtf8---- | String is the same but goes the long way round, through Text.-instance BinRep String where-    toBinRep = toBinRep . Text.pack--check :: BinRep a => Cfg -> BS.ByteString -> MetaStream a -> Either (Error a) ()-check cfg bs meta = do-    case msExpected meta of-      Nothing -> Right ()-      Just aExpected -> do-        bsExpected <- checkInner aExpected Nothing -- cheating a bit here-        case msNullTerminates meta of-          Nothing -> check' bs bsExpected-          Just nullsFrom ->-            let (bs', bsNulls) = BS.splitAt (fromIntegral nullsFrom) bs-             in if   bsNulls == BS.replicate (BS.length bsNulls) 0x00-                then check' bs' bsExpected-                else Left $ ErrorUnexpectedNonNull bs+-- Correct thing to do, but needs lots of changes elsewhere too. Dang.+binRepifyNull+    :: forall ec s r1 r2 ss rs is+    .  ( r1 ~ Meta+       , r2 ~ Compare.Meta ('ViaEq ec)+       , rs ~ RDelete r1 ss+       , RElem r1 ss (RIndex r1 ss)+       , RSubset rs ss is+       , RElem r2 rs (RIndex r2 rs)+       , RecElem Rec r2 r2 rs rs (RIndex r2 rs)+       )+    => Patch s ss BS.ByteString+    -> Patch s rs BS.ByteString+binRepifyNull (Patch a s ms) = do+    let (mNT, ms') = hflStrip @r1 mNullTerminates ms+    case mNT of+      Nothing -> Patch a s ms'+      Just nt ->+        let mCmpLens = hflLens @r2 @r2 @rs @rs+            ms'' = over mCmpLens (\(Compare.Meta x) -> go nt x) ms'+         in Patch a s ms''   where-    check' bs' bsExpected =-        case checkExpected bs' bsExpected of-          True  -> Right ()-          False -> Left $ ErrorDidNotMatchExpected bs' bsExpected-    checkInner a mn = do-        bs' <- toBinRep' a-        case mn of-          Nothing -> Right bs'-          Just n  ->-            if   fromIntegral (BS.length bs') > n-            then Left $ ErrorBinRepTooLong bs' n-            else Right bs'-    checkExpected bs' bsExpected =-        case cfgAllowPartialExpected cfg of-          True  -> BS.isPrefixOf bs' bsExpected-          False -> bs' == bsExpected+    go nt = \case+      Nothing  -> Compare.Meta Nothing+      Just cmp ->+        let cmp' = cmp <> BS.replicate (fromIntegral nt) 0x00+         in Compare.Meta $ Just cmp'

@@ -1,48 +0,0 @@-{-| Newtype for manipulating length-prefixed strings.--This type is for UTF-8 'Text' that you intend to write out to a length-prefixed-bytestring. The size of the length field is static. You essentially have to-decide the maximum bytesize of the string on creation.--}--module StreamPatch.Patch.Binary.PascalText where--import           StreamPatch.Patch.Binary ( BinRep(..) )--import qualified Data.Text.Encoding         as Text-import           Data.Text                  ( Text )-import qualified Data.ByteString            as BS-import           GHC.TypeNats-import           Data.Proxy-import           Data.Bits--newtype PascalText (n :: Nat) = PascalText { unPascalText :: Text }--instance KnownNat n => BinRep (PascalText n) where-    toBinRep t =-        case encodePascalText t of-          Nothing -> Left "UTF-8 encoded text too long for length prefix field"-          Just bs -> Right bs--encodePascalText :: forall n. KnownNat n => PascalText n -> Maybe BS.ByteString-encodePascalText t = do-    lenBs <- encodeToSizedBE (fromIntegral (natVal (Proxy @n))) (BS.length bs)-    return $ lenBs <> bs-  where-    bs = Text.encodeUtf8 . unPascalText $ t--encodeToSizedBE :: (Integral a, Bits a) => Int -> a -> Maybe BS.ByteString-encodeToSizedBE byteSize x =-    let bs = i2be x-        nulls = byteSize - BS.length bs-     in if   nulls < 0-        then Nothing-        else Just $ BS.replicate nulls 0x00 <> bs---- | Re-encode an 'Integer' to a little-endian integer stored as a---   'BS.ByteString' using the fewest bytes needed to represent it.------ adapated from crypto-api 0.13.3, Crypto.Util.i2bs_unsized-i2be :: (Integral a, Bits a) => a -> BS.ByteString-i2be 0 = BS.singleton 0-i2be i = BS.reverse $ BS.unfoldr (\i' -> if i' <= 0 then Nothing else Just (fromIntegral i', (i' `shiftR` 8))) i

@@ -0,0 +1,208 @@+{- TODO+  * Via -> Strategy (? I do like the brevity of Via)+  * Rename Compare (but not sure what to...)+-}++{-# LANGUAGE AllowAmbiguousTypes, UndecidableInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module StreamPatch.Patch.Compare where++import GHC.Generics ( Generic )+import Data.Data ( Typeable, Data )++import Numeric.Natural+import Data.ByteString qualified as BS+import Data.Text qualified as Text+import Data.Text ( Text )++import Data.Void+import Control.Monad ( void )++import GHC.Exts ( Proxy#, proxy# )+import GHC.TypeLits ( KnownSymbol, symbolVal' )++import Binrep.Extra.HexByteString++import Data.Aeson qualified as Aeson+import Data.Aeson ( ToJSON(..), FromJSON(..) )++import Text.Megaparsec+import Text.Megaparsec.Char qualified as MC+import Text.Megaparsec.Char.Lexer qualified as MCL++import BLAKE3 qualified as B3+import Data.ByteArray qualified as BA+import Data.ByteString qualified as B+import Data.Word ( Word8 )++import Data.Singletons.TH+-- required for deriving instances (seems like bug)+import Prelude.Singletons hiding ( AbsSym0, Compare )+import Data.Singletons.Base.TH ( FromString, sFromString )++$(singletons [d|+    -- | What sort of equality check to do.+    data EqualityCheck+      = Exact -- ^ "Exact equality" is defined as whatever the 'Eq' class does. (lol)+      | PrefixOf+        deriving stock (Show, Eq)+    |])+deriving stock instance Generic  EqualityCheck+deriving stock instance Typeable EqualityCheck+deriving stock instance Data     EqualityCheck++$(singletons [d|+    data HashFunc+      = B3+      | SHA256+      | MD5+        deriving stock (Show, Eq)+    |])+deriving stock instance Generic  HashFunc+deriving stock instance Typeable HashFunc+deriving stock instance Data     HashFunc++$(singletons [d|+    -- | How should we compare two values?+    data Via+      -- | Are they equal in some way?+      = ViaEq EqualityCheck++      -- | Do they have the same size?+      | ViaSize++      -- | Do they have the same digest under the given hash function?+      | ViaDigest HashFunc+        deriving stock (Show, Eq)+    |])+deriving stock instance Generic  Via+deriving stock instance Typeable Via+deriving stock instance Data     Via++data Meta (v :: Via) a = Meta+  { mCompare :: Maybe (CompareRep v a)+  } deriving stock (Generic)++deriving stock instance Eq   (CompareRep v a) => Eq   (Meta v a)+deriving stock instance Show (CompareRep v a) => Show (Meta v a)++deriving anyclass instance ToJSON   (CompareRep v a) => ToJSON   (Meta v a)+deriving anyclass instance FromJSON (CompareRep v a) => FromJSON (Meta v a)++instance SingI v => Functor     (Meta v) where+    fmap f (Meta c) = case sing @v of+      SViaEq     _ -> Meta $ fmap f c+      SViaSize     -> Meta c+      SViaDigest _ -> Meta c++instance SingI v => Foldable    (Meta v) where+    foldMap f (Meta c) = case sing @v of+      SViaEq     _ -> foldMap f c+      SViaSize     -> mempty+      SViaDigest _ -> mempty++instance SingI v => Traversable (Meta v) where+    traverse f (Meta c) = case sing @v of+      SViaEq     _ -> Meta <$> traverse f c+      SViaSize     -> pure $ Meta c+      SViaDigest _ -> pure $ Meta c++type family CompareRep (v :: Via) a where+    CompareRep ('ViaEq _)     a = a+    CompareRep 'ViaSize       _ = Natural+    CompareRep ('ViaDigest h) _ = Digest h B.ByteString++-- | The resulting digest from hashing some data using the given hash function.+--+-- TODO+-- As of 2022, most good cryptographic hash functions produce digest sizes+-- between 256-512 bits. That's 32-64 bytes. So I want to use a ShortByteString,+-- but the BLAKE3 library uses the memory library, which I can't figure out. I+-- bet it'd be more efficient. So, I'm polymorphising in preparation.+newtype Digest (h :: HashFunc) a = Digest { getDigest :: a }+    deriving stock (Generic, Eq, Show)++type Digest' h = Digest h B.ByteString++type family HashFuncLabel (h :: HashFunc) where+    HashFuncLabel 'B3     = "b3"+    HashFuncLabel 'SHA256 = "sha256"+    HashFuncLabel 'MD5    = "md5"++hashFuncLabel :: forall h l. (l ~ HashFuncLabel h, KnownSymbol l) => Text+hashFuncLabel = Text.pack (symbolVal' (proxy# :: Proxy# l))++-- | Add a @digest:@ prefix to better separate from regular text.+instance (l ~ HashFuncLabel h, KnownSymbol l) => ToJSON   (Digest h B.ByteString) where+    toJSON = Aeson.String . Text.append "digest:" . prettyDigest B.unpack++instance (l ~ HashFuncLabel h, KnownSymbol l) => FromJSON (Digest h B.ByteString) where+    parseJSON = Aeson.withText "hex hash digest" $ \t ->+        case parseMaybe @Void parseDigest t of+          Nothing   -> fail "failed to parse hex hash digest"+          Just hash -> pure hash++-- | Pretty print a hash like @hashfunc:123abc@.+prettyDigest+    :: forall h a l. (l ~ HashFuncLabel h, KnownSymbol l)+    => (a -> [Word8]) -> Digest h a -> Text+prettyDigest unpack (Digest d) =+       hashFuncLabel @h+    <> Text.singleton ':'+    <> prettyHexByteStringCompact unpack d++-- Bad naming, these maybe aren't symbols/lexemes in the expected sense+-- (horizontal spacing is optional).+parseDigest+    :: forall h l e s m+    .  (l ~ HashFuncLabel h, KnownSymbol l, MonadParsec e s m, Token s ~ Char, Tokens s ~ Text)+    => m (Digest h B.ByteString)+parseDigest = do+    symbol "digest"+    symbol ":"+    symbol $ hashFuncLabel @h+    symbol ":"+    Digest <$> parseHexByteString B.pack+  where symbol = void . MCL.lexeme MC.hspace . chunk++class Compare (v :: Via) a where+    compare'     :: CompareRep v a -> CompareRep v a -> Maybe String+    toCompareRep :: a -> CompareRep v a++compareTo :: forall v a. Compare v a => CompareRep v a -> a -> Maybe String+compareTo cmp = compare' @v @a cmp . toCompareRep @v @a++-- Free instance: Compare for exact equality via 'Eq'.+-- TODO show is bandaid. no need to handle it here.+instance (Eq a, Show a) => Compare ('ViaEq 'Exact) a where+    toCompareRep = id+    compare' c1 c2 | c1 == c2  = Nothing+                   | otherwise = Just $ "values not equal: "<>show c1<>" /= "<>show c2++instance Compare ('ViaDigest 'B3) BS.ByteString where+    toCompareRep = Digest . hashB3+    compare' c1 c2 | c1 == c2  = Nothing+                   | otherwise = Just "digests not equal"++-- TODO I need to define the compare class better lol, I'm confused which is+-- real and which is test.+instance Compare ('ViaEq 'PrefixOf) BS.ByteString where+    toCompareRep = id+    compare' c1 c2 | c2 `B.isPrefixOf` c1 = Nothing+                   | otherwise = Just $ "prefix compare check fail: "<>show c1<>" vs. "<>show c2++-- I unpack to '[Word8]' then repack to 'ByteString' because the memory library+-- is very keen on complicated unsafe IO. cheers no thanks+hashB3 :: BS.ByteString -> BS.ByteString+hashB3 bs = BS.pack $ BA.unpack $ B3.hash @B3.DEFAULT_DIGEST_LEN [bs]++class SwapCompare a (vFrom :: Via) (vTo :: Via) where+    swapCompare :: CompareRep vFrom a -> Either String (CompareRep vTo a)++instance SwapCompare a v v where+    swapCompare = Right++instance SwapCompare BS.ByteString ('ViaEq 'Exact) ('ViaDigest 'B3) where+    swapCompare = Right . Digest . hashB3

@@ -0,0 +1,35 @@+-- | Compiling/normalizing patches using 'Compare'.++{-# LANGUAGE AllowAmbiguousTypes #-}++module StreamPatch.Patch.Compile where++import StreamPatch.Patch+import StreamPatch.Patch.Compare qualified as Compare+import StreamPatch.Patch.Compare ( Compare(..), Via(..), EqualityCheck(..) )++import StreamPatch.HFunctorList+import Optics+import Data.Generics.Product.Any+import Data.Vinyl+import Data.Vinyl.TypeLevel ( RIndex )++compilePatch+    :: forall v a s f f' fs fs' i+    .  ( Compare v a+       , f  ~ Compare.Meta ('ViaEq 'Exact)+       , f' ~ Compare.Meta v+       , RElem f fs i+       , RecElem Rec f f' fs fs' i+       , i ~ RIndex f fs+       )+    => Patch s fs  a+    -> Patch s fs' a+compilePatch = over ((the @"patchMeta") % hflLens) (compileCompareMeta @v)++compileCompareMeta+    :: forall v a. Compare v a+    => Compare.Meta ('ViaEq 'Exact) a+    -> Compare.Meta v a+compileCompareMeta (Compare.Meta cmp) =+    Compare.Meta $ fmap (toCompareRep @v) cmp

@@ -1,58 +0,0 @@-module StreamPatch.Patch.Linearize where--import           StreamPatch.Patch--import           GHC.Generics ( Generic )-import           Numeric.Natural-import           GHC.Natural ( minusNaturalMaybe )-import           Data.Vinyl--import           Control.Monad.State-import qualified Data.List              as List-import qualified Data.ByteString        as BS-import qualified Data.Text              as Text-import           Data.Text              ( Text )-import           StreamPatch.Util       ( traverseM )--class HasLength a where-    getLength :: a -> Natural--instance HasLength BS.ByteString where-    getLength = fromIntegral . BS.length-instance HasLength Text where-    getLength = fromIntegral . Text.length-instance HasLength String where-    getLength = fromIntegral . List.length--data Error fs a-  = ErrorOverlap -- ^ Two edits wrote to the same offset.-        (SeekRep 'AbsSeek)    -- ^ absolute position in stream-        (Patch 'AbsSeek fs a) -- ^ overlapping patch-        (Patch 'AbsSeek fs a) -- ^ previous patch-    deriving (Generic)--deriving instance (Eq a, Eq (Patch 'AbsSeek fs a)) => Eq (Error fs a)-deriving instance (Show a, ReifyConstraint Show (Flap a) fs, RMap fs, RecordToList fs) => Show (Error fs a)-deriving instance (Functor     (Patch 'AbsSeek fs)) => Functor     (Error fs)-deriving instance (Foldable    (Patch 'AbsSeek fs)) => Foldable    (Error fs)-deriving instance (Traversable (Patch 'AbsSeek fs)) => Traversable (Error fs)--linearize-    :: HasLength a-    => [Patch 'AbsSeek fs a]-    -> Either (Error fs a) [Patch 'FwdSeek fs a]-linearize ps = evalState (traverseM go (List.sortBy comparePatchSeeks ps)) (0, undefined)-  where-    go p@(Patch a s _)  = do-        (cursor, pPrev) <- get-        case s `minusNaturalMaybe` cursor of-          -- next absolute seek is before cursor: current patch overlaps prev-          Nothing -> return $ Left $ ErrorOverlap cursor p pPrev-          Just skip -> do-            let cursor' = cursor + skip + getLength a-                p' = p { patchSeek = skip }-            put (cursor', p)-            return $ Right p'--comparePatchSeeks :: Ord (SeekRep s) => Patch s fs a -> Patch s fs a -> Ordering-comparePatchSeeks p1 p2 = compare (patchSeek p1) (patchSeek p2)

@@ -0,0 +1,6 @@+module StreamPatch.Patch.Linearize.Common where++import StreamPatch.Patch++comparePatchSeeks :: Ord s => Patch s fs a -> Patch s fs a -> Ordering+comparePatchSeeks p1 p2 = compare (patchSeek p1) (patchSeek p2)

@@ -0,0 +1,58 @@+{-# LANGUAGE UndecidableInstances #-}++module StreamPatch.Patch.Linearize.InPlace where++import StreamPatch.Patch+import StreamPatch.HFunctorList+import StreamPatch.Patch.Linearize.Common++import GHC.Generics ( Generic )+import Data.Vinyl++import Control.Monad.State+import qualified Data.List              as List+import qualified Data.ByteString        as BS+import qualified Data.Text              as Text+import Data.Text              ( Text )+import StreamPatch.Util       ( traverseM )++type Len = Int++class HasLength a where+    -- | Returns non-negative values only.+    getLength :: a -> Len++instance HasLength BS.ByteString where getLength = BS.length+instance HasLength Text          where getLength = Text.length+instance HasLength String        where getLength = List.length++data Error fs a+  = ErrorOverlap -- ^ Two edits wrote to the same offset.+        Len -- ^ absolute position in stream+        (Patch Len fs a) -- ^ overlapping patch+        (Patch Len fs a) -- ^ previous patch+    deriving (Generic)++deriving instance (Eq a, Eq (Rec (Flap a) fs)) => Eq (Error fs a)+deriving instance (Show a, ReifyConstraint Show (Flap a) fs, RMap fs, RecordToList fs) => Show (Error fs a)+deriving instance Functor     (HFunctorList fs) => Functor     (Error fs)+deriving instance Foldable    (HFunctorList fs) => Foldable    (Error fs)+deriving instance Traversable (HFunctorList fs) => Traversable (Error fs)++linearizeInPlace+    :: forall a fs. HasLength a+    => [Patch Len fs a]+    -> Either (Error fs a) [Patch Len fs a]+linearizeInPlace ps = evalState (traverseM go (List.sortBy comparePatchSeeks ps)) (0, undefined)+  where+    go p@(Patch a s _)  = do+        (cursor, pPrev) <- get+        let skip = s - cursor+        if skip < 0 then do+            -- next absolute seek is before cursor: current patch overlaps prev+            return $ Left $ ErrorOverlap cursor p pPrev+        else do+            let cursor' = cursor + skip + getLength a+                p' = p { patchSeek = skip }+            put (cursor', p)+            return $ Right p'

@@ -0,0 +1,41 @@+module StreamPatch.Patch.Linearize.Insert where++import Control.Monad.State+import Data.List qualified as List+import StreamPatch.Util ( traverseM )++{-+-- Result seeks are non-negative, so natural-like types are safe to use.+linearizeInsert+    :: (Integral sf, Integral st)+    => [Patch sf fs a] -> Either (Error (Patch sf fs a)) [Patch st fs a]+linearizeInsert = linearize patchSeek (\s p -> p { patchSeek = s })+-}++-- | Linearize some list of @a@s.+--+-- For non-empty lists, the result is a tuple of the first @a@, followed by the+-- linearized @a@s (converted to @b@). Linearized values are non-negative, so+-- natural-like types are safe to use for @st@.+linearize+    :: (Integral sf, Integral st)+    => (a -> sf)+    -> (st -> a -> b)+    -> [a] -> Either (a, a) (Maybe (a, [b]))+linearize f g as =+    case List.sortBy cmp as of+      []      -> Right Nothing+      (a:as') -> do+        bs <- evalState (traverseM go as') a+        Right $ Just (a, bs)+  where+    cmp a1 a2 = compare (f a1) (f a2)+    go a = do+        a' <- get+        let s' = fromIntegral $ f a - f a'+        if s' == 0+        then return $ Left (a, a')+        else put a >> return (Right (g s' a))++linearize' :: (Integral sf, Integral st) => [sf] -> Either (sf, sf) (Maybe (sf, [st]))+linearize' = linearize id const

@@ -0,0 +1,19 @@+module StreamPatch.Seek where++import Data.Kind+import GHC.Generics ( Generic )+import Data.Data ( Data )+import Data.Aeson++class Seek (s :: Type) where+    type SeekRep s :: Type+    unSeek :: s -> SeekRep s+    mkSeek :: SeekRep s -> s++-- | Seek to stream index. Relative to a base, which can either move during+--   patching (actual relative) or stay constant ("absolute"). We abstract over+--   the internal type to allow using natural types where we want to disallow+--   negatives, and possibly allow sized types for efficiency.+newtype SIx a = SIx { unSIx :: a }+    deriving stock (Generic, Data, Show, Eq, Ord)+    deriving (ToJSON, FromJSON) via a

@@ -0,0 +1,148 @@+-- | TODO remove ASAP. figure out Aeson with Vinyl++{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++module StreamPatch.Simple where++import StreamPatch.Patch+import StreamPatch.HFunctorList+import StreamPatch.Patch.Binary qualified as Bin+import StreamPatch.Patch.Compare qualified as Compare+import StreamPatch.Patch.Compare ( Via(..), CompareRep )+import StreamPatch.Patch.Align qualified as Align++import Numeric.Natural+import Data.Functor.Const+import Data.Vinyl+import Data.Vinyl.TypeLevel+import Data.Aeson+import GHC.Generics++data MultiPatch s (v :: Via) a = MultiPatch+  { mpData           :: a+  , mpSeek           :: s+  , mpCompare        :: Maybe (CompareRep v a)+  , mpNullTerminates :: Maybe Natural+  , mpMaxBytes       :: Maybe Natural -- TODO confirm meaning, maybe improve name+  , mpAligned        :: Maybe Integer+  } deriving (Generic)++instance Functor (MultiPatch s ('ViaEq ec)) where+    fmap f (MultiPatch d s c n m a) = MultiPatch (f d) s (fmap f c) n m a+instance Functor (MultiPatch s ('ViaDigest h)) where+    fmap f (MultiPatch d s c n m a) = MultiPatch (f d) s c          n m a++deriving instance (Eq   a, Eq   s, Eq   (CompareRep v a)) => Eq   (MultiPatch s v a)+deriving instance (Show a, Show s, Show (CompareRep v a)) => Show (MultiPatch s v a)++data Aligned p = Aligned+  { alignedAlign   :: Integer+  , alignedPatches :: [p]+  } deriving (Eq, Show, Generic)++--------------------------------------------------------------------------------++jsonCfgCamelDrop :: Int -> Options+jsonCfgCamelDrop x = defaultOptions+  { fieldLabelModifier = camelTo2 '_' . drop x+  , rejectUnknownFields = True }++instance (ToJSON   (CompareRep v a), ToJSON   a, ToJSON   s) => ToJSON   (MultiPatch s v a) where+    toJSON     = genericToJSON     $ jsonCfgCamelDrop 2+    toEncoding = genericToEncoding $ jsonCfgCamelDrop 2+instance (FromJSON (CompareRep v a), FromJSON a, FromJSON s) => FromJSON (MultiPatch s v a) where+    parseJSON  = genericParseJSON  $ jsonCfgCamelDrop 2++instance (ToJSON   p) => ToJSON   (Aligned p) where+    toJSON     = genericToJSON     $ jsonCfgCamelDrop 7+    toEncoding = genericToEncoding $ jsonCfgCamelDrop 7+instance (FromJSON p) => FromJSON (Aligned p) where+    parseJSON  = genericParseJSON  $ jsonCfgCamelDrop 7++--------------------------------------------------------------------------------++convert :: (MultiPatch s v a -> Rec (Flap a) fs) -> MultiPatch s v a -> Patch s fs a+convert f p = Patch { patchData = mpData p+                    , patchSeek = mpSeek p+                    , patchMeta = HFunctorList $ f p }++-- TODO how to clean up (it's like liftA2 over n instead of 2. like a fold)+-- likely 'ap'!+convertBinAlign+    :: forall a v+    .  MultiPatch Integer v a+    -> Patch Integer '[Const (Align.Meta Int), Const Bin.MetaPrep, Compare.Meta v, Bin.Meta] a+convertBinAlign = convert go+  where go p = cmAlign p <+> cmBinPrep p <+> cmCompare p <+> cmBin p++convertBin+    :: forall s a v+    .  MultiPatch s v a+    -> Patch s '[Const Bin.MetaPrep, Compare.Meta v, Bin.Meta] a+convertBin p = convert go p+  where go s = cmBinPrep s <+> cmCompare s <+> cmBin s++convertAlign+    :: forall a v+    .  MultiPatch Integer v a+    -> Patch Integer '[Const (Align.Meta Int)] a+convertAlign p = convert cmAlign p++convertEmpty+    :: forall s a v+    .  MultiPatch s v a+    -> Patch s '[] a+convertEmpty p = convert (const RNil) p++--------------------------------------------------------------------------------++align+    :: forall st a ss rs is i r+    .  ( r ~ Const (Align.Meta st)+       , Num st, Eq st+       , rs ~ RDelete r ss+       , RElem r ss i+       , RSubset rs ss is )+    => Aligned (Patch Integer ss a)+    -> Either (Align.Error st) [Patch st rs a]+align (Aligned a ps) = traverse (Align.align a) ps++--------------------------------------------------------------------------------++cmBin :: MultiPatch s c a -> Rec (Flap a) '[Bin.Meta]+cmBin p = cm $ Bin.Meta { Bin.mNullTerminates = mpNullTerminates p }++cmCompare :: MultiPatch s v a -> Rec (Flap a) '[Compare.Meta v]+cmCompare p = cm $ Compare.Meta { Compare.mCompare = mpCompare p }++cmBinPrep :: MultiPatch s c a -> Rec (Flap a) '[Const Bin.MetaPrep]+cmBinPrep p = cm $ Const $ Bin.MetaPrep { Bin.mpMaxBytes = mpMaxBytes p }++cmAlign :: MultiPatch Integer c a -> Rec (Flap a) '[Const (Align.Meta Int)]+cmAlign p = cm $ Const $ Align.Meta { Align.mExpected = fromInteger <$> mpAligned p }++cm :: f a -> Rec (Flap a) '[f]+cm fa = Flap fa :& RNil++--------------------------------------------------------------------------------++-- | Convenience function to wrap a single meta into an 'HFunctorList'.+metaWrap1 :: f a -> HFunctorList '[f] a+metaWrap1 = HFunctorList . cm++-- | Convenience function for the empty 'HFunctorList'.+metaEmpty :: HFunctorList '[] a+metaEmpty = HFunctorList RNil++--------------------------------------------------------------------------------++convertBackBin :: forall v s a. Patch s '[Compare.Meta v, Bin.Meta] a -> MultiPatch s v a+convertBackBin p = MultiPatch { mpData           = patchData p+                              , mpSeek           = patchSeek p+                              , mpCompare        = Compare.mCompare @v $ hflGet $ patchMeta p+                              , mpNullTerminates = Bin.mNullTerminates $ hflGet $ patchMeta p+                              , mpMaxBytes       = Nothing+                              , mpAligned        = Nothing+                              }

@@ -1,78 +1,131 @@-module StreamPatch.Stream where+{- | Stream monads. -import           GHC.Natural-import           Data.Kind-import qualified Data.ByteString            as BS-import qualified Data.ByteString.Builder    as BB-import           Control.Monad.State-import           Control.Monad.Reader-import           System.IO                  ( Handle, SeekMode(..), hSeek )+By stream, I mean a container indexed by the naturals(/integers). Note that not+all parts of streampatch are limited to this, but it's an extremely useful+invariant, without which patch linearization & application gets a whole lot more+complex. So for now, streams it is. -import qualified Data.List                  as List+These are designed to support easy pure and impure implementations. That's the+reasoning behind forward-only streams, and separating overwrites (easy impure,+mid pure) from inserts (hard impure, ease pure).+-} --- TODO also require reporting cursor position (for error reporting)-class Monad m => MonadFwdInplaceStream m where+module StreamPatch.Stream where++import Data.Kind+import Data.ByteString qualified as B+import Data.ByteString.Builder qualified as BB+import Control.Monad.State+import Control.Monad.Reader+import System.IO qualified as IO+import Data.List qualified as List++-- | Streams supporting forward seeking and in-place edits (length never+--   changes).+class Monad m => FwdInplaceStream m where     type Chunk m :: Type -    -- | Read a number of bytes without advancing the cursor.-    readahead :: Natural -> m (Chunk m)+    -- | The unsigned integral type used for indexing. 'Int' has a sign, but is+    --   often used internally; 'Integer' also gets some use; 'Natural' is the+    --   most mathematically honest. I leave the decision up to the instance to+    --   allow them to be as efficient as possible.+    type Index m :: Type -    -- | Advance cursor without reading.-    advance :: Natural -> m ()+    -- | Read a number of elements forward without moving the cursor.+    --+    -- Argument must be positive.+    readahead :: Index m -> m (Chunk m) -    -- | Insert bytes into the stream at the cursor position, overwriting-    --   existing bytes.+    -- | Overlay a chunk onto the stream at the current cursor position,+    --   overwriting existing elements.+    --+    -- Moves the cursor to the right by the length of the chunk.     overwrite :: Chunk m -> m () --- TODO Need MonoTraversable to define for Text, ByteString etc easily. Bleh. I--- think Snoyman's advice is to reimplement. Also bleh.-instance Monad m => MonadFwdInplaceStream (StateT ([a], [a]) m) where-    type Chunk (StateT ([a], [a]) m) = [a]-    readahead n = List.take (fromIntegral n) <$> gets fst-    advance n = do-        (src, out) <- get-        let (bs, src') = List.splitAt (fromIntegral n) src-        put (src', out <> bs)+    -- | Move cursor forwards without reading. Must be positive.+    advance :: Index m -> m ()++    -- | Get the current cursor position.+    --+    -- Intended for error messages.+    getCursor :: m (Index m)++instance Monad m => FwdInplaceStream (StateT (B.ByteString, BB.Builder, Int) m) where+    type Chunk (StateT (B.ByteString, BB.Builder, Int) m) = B.ByteString+    type Index (StateT (B.ByteString, BB.Builder, Int) m) = Int+    readahead n = get >>= \(src, _, _) -> return $ B.take n src     overwrite bs = do-        (src, out) <- get-        let (_, src') = List.splitAt (List.length bs) src-        put (src', out <> bs)+        (src, out, pos) <- get+        let (_, src') = B.splitAt (B.length bs) src+            out' = out <> BB.byteString bs+            pos' = pos + B.length bs+        put (src', out', pos')+    advance n = do+        (src, out, pos) <- get+        let (bs, src') = B.splitAt n src+            out' = out <> BB.byteString bs+            pos' = pos + n+        put (src', out', pos')+    getCursor = get >>= \(_, _, pos) -> return pos -instance MonadIO m => MonadFwdInplaceStream (ReaderT Handle m) where-    type Chunk (ReaderT Handle m) = BS.ByteString+instance MonadIO m => FwdInplaceStream (ReaderT IO.Handle m) where+    type Chunk (ReaderT IO.Handle m) = B.ByteString+    type Index (ReaderT IO.Handle m) = Integer     readahead n = do         hdl <- ask-        bs <- liftIO $ BS.hGet hdl (fromIntegral n)-        liftIO $ hSeek hdl RelativeSeek (- fromIntegral n)-        return bs+        bs <- liftIO $ B.hGet hdl $ fromInteger n -- TODO Integer -> Int :(+        liftIO $ IO.hSeek hdl IO.RelativeSeek (-n)+        pure bs+    overwrite bs = do+        hdl <- ask+        liftIO $ B.hPut hdl bs     advance n = do         hdl <- ask-        liftIO $ hSeek hdl RelativeSeek (fromIntegral n)-    overwrite bs = do+        liftIO $ IO.hSeek hdl IO.RelativeSeek n+    getCursor = do         hdl <- ask-        liftIO $ BS.hPut hdl bs+        pos <- liftIO $ IO.hTell hdl+        return $ fromInteger pos -instance Monad m => MonadFwdInplaceStream (StateT (BS.ByteString, BB.Builder) m) where-    type Chunk (StateT (BS.ByteString, BB.Builder) m) = BS.ByteString-    readahead n = BS.take (fromIntegral n) <$> gets fst-    advance n = do-        (src, out) <- get-        let (bs, src') = BS.splitAt (fromIntegral n) src-        put (src', out <> BB.byteString bs)+-- TODO Need MonoTraversable to define for Text, ByteString etc easily. Bleh. I+-- think Snoyman's advice is to reimplement. Also bleh.+instance Monad m => FwdInplaceStream (StateT ([a], [a], Int) m) where+    type Chunk (StateT ([a], [a], Int) m) = [a]+    type Index (StateT ([a], [a], Int) m) = Int+    readahead n = get >>= \(src, _, _) -> return $ List.take n src     overwrite bs = do-        (src, out) <- get-        let (_, src') = BS.splitAt (BS.length bs) src-        put (src', out <> BB.byteString bs)+        (src, out, pos) <- get+        let (_, src') = List.splitAt (List.length bs) src+            out' = out <> bs+            pos' = pos + List.length bs+        put (src', out', pos')+    advance n = do+        (src, out, pos) <- get+        let (bs, src') = List.splitAt (fromIntegral n) src+            out' = out <> bs+            pos' = pos + n+        put (src', out', pos')+    getCursor = get >>= \(_, _, pos) -> return pos --- | A forward stream, but backward too.-class MonadFwdInplaceStream m => MonadCursorInplaceStream m where-    -- | Move cursor.-    move :: Integer -> m ()+-- | Streams supporting forward seeking and arbitrary edits.+class FwdInplaceStream m => FwdStream m where+    -- | Write a chunk into the stream at the current cursor position.+    --+    -- Moves the cursor to the right by the length of the chunk.+    write :: Chunk m -> m () -instance MonadIO m => MonadCursorInplaceStream (ReaderT Handle m) where-    move n = do-        hdl <- ask-        liftIO $ hSeek hdl RelativeSeek (fromIntegral n)+    -- | Delete a sized chunk at the current cursor position.+    --+    -- Argument must be positive.+    delete :: Index m -> m () -class MonadFwdInplaceStream m => MonadFwdStream m where-    insert :: Chunk m -> m ()+instance Monad m => FwdStream (StateT (B.ByteString, BB.Builder, Int) m) where+    write bs = do+        (src, out, pos) <- get+        let out' = out <> BB.byteString bs+            pos' = pos + B.length bs+        put (src, out', pos')+    delete n = do+        (src, out, pos) <- get+        let src' = B.drop n src+        put (src', out, pos)

@@ -1,23 +0,0 @@-module BytePatch.HexByteStringSpec ( spec ) where--import           BytePatch.HexByteString-import           Test.Hspec-import           Util--import qualified Data.ByteString                as BS--spec :: Spec-spec = do-    let parse = parseFromCharStream parseHexByteString-        bs = BS.pack-    it "parses valid hex bytestrings" $ do-      parse "00" `shouldBe` Just (bs [0x00])-      parse "FF" `shouldBe` Just (bs [0xFF])-      parse "1234" `shouldBe` Just (bs [0x12, 0x34])-      parse "01 9A FE" `shouldBe` Just (bs [0x01, 0x9A, 0xFE])-      parse "FFFFFFFF" `shouldBe` Just (BS.replicate 4 0xFF)-      parse "12 34    AB CD" `shouldBe` Just (bs [0x12, 0x34, 0xAB, 0xCD])-    it "fails to parse invalid hex bytestrings" $ do-      parse "-00" `shouldBe` Nothing-      parse "FG" `shouldBe` Nothing-      parse "0x1234" `shouldBe` Nothing

@@ -1,19 +1,19 @@ module StreamPatch.ApplySpec ( spec ) where -import           StreamPatch.Apply-import           Test.Hspec-import           Test.Hspec.QuickCheck-import           Test.QuickCheck-import           Util+import StreamPatch.Apply+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck+import Util -import           StreamPatch.Patch-import           Data.Functor.Const-import           Data.Vinyl-import           GHC.Natural+import StreamPatch.Patch+import Data.Functor.Const+import Data.Vinyl+import GHC.Natural  spec :: Spec spec = do-    let patch' ps = runPureSimpleFwdList $ makePatchscript ps+    let patch' ps = runPureFwdList $ makePatchscript ps     it "applies valid simple forward in-place patches" $ do       patch' []           "1234567890" `shouldBe` "1234567890"       patch' [(0, "XXX")] "1234567890" `shouldBe` "XXX4567890"@@ -30,7 +30,7 @@ -- nah I cba lol just trust me --manualPatch :: [Patch 'FwdSeek '[] [a]] -> [a] -> [a] -genPatchList :: Arbitrary a => Natural -> Gen [Patch 'FwdSeek '[] [a]]+genPatchList :: Arbitrary a => Natural -> Gen [Patch Natural '[] [a]] genPatchList = skip []   where     skip ps n = do

@@ -1,23 +1,24 @@ module StreamPatch.Patch.AlignSpec ( spec ) where -import           StreamPatch.Patch.Align-import           Test.Hspec-import           Util+import StreamPatch.Patch.Align+import Test.Hspec+import Util -import           StreamPatch.Patch-import           Data.Vinyl-import           Data.Functor.Const-import           GHC.Natural+import StreamPatch.Patch+import StreamPatch.HFunctorList+import Data.Vinyl+import Data.Functor.Const+import GHC.Natural  makeUnalignedPatch     :: [(Integer, a)]-    -> [Patch 'RelSeek '[Const (Meta 'FwdSeek)] a]+    -> [Patch Integer '[Const (Meta Natural)] a] makeUnalignedPatch = map go-  where go (n, a) = Patch a n $ FunctorRec $ Flap (Const (Meta Nothing)) :& RNil+  where go (n, a) = Patch a n $ HFunctorList $ Flap (Const (Meta Nothing)) :& RNil  align'     :: Integer -> [(Integer, String)]-    -> Either (Error 'FwdSeek) [Patch 'FwdSeek '[] String]+    -> Either (Error Natural) [Patch Natural '[] String] align' sBase = traverse (align sBase) . makeUnalignedPatch  spec :: Spec

@@ -1,19 +1,23 @@ module StreamPatch.Patch.LinearizeSpec ( spec ) where -import           StreamPatch.Patch.Linearize-import           Test.Hspec-import           Util+import StreamPatch.Patch.Linearize.InPlace+import StreamPatch.Patch.Linearize.Insert+import Test.Hspec+import Util -import           StreamPatch.Patch-import           Data.Functor.Const-import           Data.Either.Combinators-import           GHC.Natural-import           Optics-import           Data.Generics.Product.Any+import StreamPatch.Patch+import Data.Functor.Const+import Data.Either.Combinators+import GHC.Natural+import Optics+import Data.Generics.Product.Any  spec :: Spec spec = do-    let p  = makePatch' @'AbsSeek-        p' = makePatch' @'FwdSeek-    it "linearizes a simple valid patch" $ do-      linearize [p "1" 1, p "5" 5, p "2" 2] `shouldBe` Right [p' "1" 1, p' "2" 0, p' "5" 2]+    let p  = makePatch+    it "linearizes a simple valid in-place patch" $ do+      linearizeInPlace   [p "1" 1, p "5" 5, p "2" 2]+        `shouldBe` Right [p "1" 1, p "2" 0, p "5" 2]+    it "TODO" $ do+      linearize'  [1,2,3,4,5] `shouldBe` Right (Just ( 1, [1,1,1,1]))+      linearize' [-1,2,3,4,5] `shouldBe` Right (Just (-1, [3,1,1,1]))

@@ -2,28 +2,20 @@  module Util where -import           StreamPatch.Patch-import           Data.Vinyl-import           Text.Megaparsec-import           Data.Void-import           GHC.Natural-import           Test.QuickCheck----parseFromCharStream :: (MonadParsec e s m, Token s ~ Char) => m a -> s -> Maybe a-parseFromCharStream :: (Stream s, Token s ~ Char) => Parsec Void s a -> s -> Maybe a-parseFromCharStream parser text = parseMaybe parser text+import StreamPatch.Patch+import StreamPatch.HFunctorList+import Data.Vinyl+import GHC.Natural+import Test.QuickCheck  -- TODO this is in quickcheck-instances instance Arbitrary Natural where   arbitrary = arbitrarySizedNatural   shrink    = shrinkIntegral -makePatch :: a -> Natural -> Patch 'FwdSeek '[] a-makePatch a n = Patch a n $ FunctorRec RNil--makePatch' :: forall s a. a -> SeekRep s -> Patch s '[] a-makePatch' a n = Patch a n $ FunctorRec RNil+makePatch :: a -> s -> Patch s '[] a+makePatch a s = Patch a s $ HFunctorList RNil -makePatchscript :: [(Natural, a)] -> [Patch 'FwdSeek '[] a]+makePatchscript :: [(s, a)] -> [Patch s '[] a] makePatchscript = map go   where go (n, a) = makePatch a n