{-# LANGUAGE AllowAmbiguousTypes #-}
module StreamPatch.Apply where
import GHC.Generics ( Generic )
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 )
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_ )
import Control.Monad.Except
data Error
= ErrorCompare String
| ErrorBinUnexpectedNonNull BS.ByteString
deriving (forall x. Rep Error x -> Error
forall x. Error -> Rep Error x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Error x -> Error
$cfrom :: forall x. Error -> Rep Error x
Generic, Error -> Error -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Error -> Error -> Bool
$c/= :: Error -> Error -> Bool
== :: Error -> Error -> Bool
$c== :: Error -> Error -> Bool
Eq, Int -> Error -> ShowS
[Error] -> ShowS
Error -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Error] -> ShowS
$cshowList :: [Error] -> ShowS
show :: Error -> String
$cshow :: Error -> String
showsPrec :: Int -> Error -> ShowS
$cshowsPrec :: Int -> Error -> ShowS
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 :: forall (v :: Via) (m :: * -> *).
(FwdInplaceStream m, Chunk m ~ ByteString, Compare v ByteString,
Num (Index m)) =>
[Patch (Index m) '[Meta v, Meta] ByteString] -> m (Either Error ())
applyBinCompareFwd = forall (t :: * -> *) (f :: * -> *) (m :: * -> *) v.
(Traversable t, Applicative f, Monad m) =>
(v -> m (f ())) -> t v -> m (f ())
traverseM_ forall a b. (a -> b) -> a -> b
$ \(Patch ByteString
bs Index m
s (HFunctorList (Flap r ByteString
cm :& Flap r ByteString
bm :& Rec (Flap ByteString) rs
RNil))) -> forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). FwdInplaceStream m => Index m -> m ()
advance Index m
s
ByteString
bsStream <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). FwdInplaceStream m => Index m -> m (Chunk m)
readahead forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. HasLength a => a -> Int
getLength ByteString
bs
ByteString
bsStream' <- ByteString -> Maybe Natural -> ExceptT Error m ByteString
doNullTermCheck ByteString
bsStream (forall {k} (a :: k). Meta a -> Maybe Natural
Bin.mNullTerminates r ByteString
bm)
ByteString -> Maybe (CompareRep v ByteString) -> ExceptT Error m ()
doCompare ByteString
bsStream' forall a b. (a -> b) -> a -> b
$ forall (v :: Via) a. Meta v a -> Maybe (CompareRep v a)
Compare.mCompare r ByteString
cm
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). FwdInplaceStream m => Chunk m -> m ()
overwrite ByteString
bs
where
err :: Error -> ExceptT Error m a
err = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
doCompare :: ByteString -> Maybe (CompareRep v ByteString) -> ExceptT Error m ()
doCompare ByteString
bs' = \case
Maybe (CompareRep v ByteString)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just CompareRep v ByteString
cmp -> do
case forall (v :: Via) a.
Compare v a =>
CompareRep v a -> a -> Maybe String
compareTo @v CompareRep v ByteString
cmp ByteString
bs' of
Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just String
e -> forall {a}. Error -> ExceptT Error m a
err forall a b. (a -> b) -> a -> b
$ String -> Error
ErrorCompare String
e
doNullTermCheck :: ByteString -> Maybe Natural -> ExceptT Error m ByteString
doNullTermCheck ByteString
bs' = \case
Maybe Natural
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs'
Just Natural
nt ->
let (ByteString
bs'', ByteString
bsNulls) = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
nt) ByteString
bs'
in if ByteString
bsNulls forall a. Eq a => a -> a -> Bool
== Int -> Word8 -> ByteString
BS.replicate (ByteString -> Int
BS.length ByteString
bsNulls) Word8
0x00
then forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
bs''
else forall {a}. Error -> ExceptT Error m a
err forall a b. (a -> b) -> a -> b
$ ByteString -> Error
ErrorBinUnexpectedNonNull ByteString
bs'
runPureBinCompareFwd
:: (Compare v BS.ByteString)
=> [Patch Int '[Compare.Meta v, Bin.Meta] BS.ByteString]
-> BS.ByteString
-> Either Error BL.ByteString
runPureBinCompareFwd :: forall (v :: Via).
Compare v ByteString =>
[Patch Int '[Meta v, Meta] ByteString]
-> ByteString -> Either Error ByteString
runPureBinCompareFwd [Patch Int '[Meta v, Meta] ByteString]
ps ByteString
bs =
let initState :: (ByteString, Builder, Int)
initState = (ByteString
bs, forall a. Monoid a => a
mempty :: BB.Builder, Int
0 :: Int)
(Either Error ()
mErr, (ByteString
bsRemaining, Builder
bbPatched, Int
_)) = forall s a. State s a -> s -> (a, s)
runState (forall (v :: Via) (m :: * -> *).
(FwdInplaceStream m, Chunk m ~ ByteString, Compare v ByteString,
Num (Index m)) =>
[Patch (Index m) '[Meta v, Meta] ByteString] -> m (Either Error ())
applyBinCompareFwd [Patch Int '[Meta v, Meta] ByteString]
ps) (ByteString, Builder, Int)
initState
bbPatched' :: Builder
bbPatched' = Builder
bbPatched forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BB.byteString ByteString
bsRemaining
in case Either Error ()
mErr of
Left Error
e -> forall a b. a -> Either a b
Left Error
e
Right () -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
BB.toLazyByteString Builder
bbPatched'
applyFwd
:: (FwdInplaceStream m, Chunk m ~ a)
=> [Patch (Index m) '[] a]
-> m ()
applyFwd :: forall (m :: * -> *) a.
(FwdInplaceStream m, Chunk m ~ a) =>
[Patch (Index m) '[] a] -> m ()
applyFwd =
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a b. (a -> b) -> a -> b
$ \(Patch a
a Index m
s (HFunctorList Rec (Flap a) '[]
RNil)) ->
forall (m :: * -> *). FwdInplaceStream m => Index m -> m ()
advance Index m
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). FwdInplaceStream m => Chunk m -> m ()
overwrite a
a
runPureFwdList
:: [Patch Int '[] [a]]
-> [a]
-> [a]
runPureFwdList :: forall a. [Patch Int '[] [a]] -> [a] -> [a]
runPureFwdList [Patch Int '[] [a]]
ps [a]
start =
let ((), ([a]
remaining, [a]
patched, Int
_)) = forall s a. State s a -> s -> (a, s)
runState (forall (m :: * -> *) a.
(FwdInplaceStream m, Chunk m ~ a) =>
[Patch (Index m) '[] a] -> m ()
applyFwd [Patch Int '[] [a]]
ps) ([a]
start, forall a. Monoid a => a
mempty, Int
0 :: Int)
in [a]
patched forall a. Semigroup a => a -> a -> a
<> [a]
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 :: forall a (v :: Via) (m :: * -> *).
(FwdInplaceStream m, Chunk m ~ a, Compare v a, HasLength a,
Num (Index m)) =>
[Patch (Index m) '[Meta v] a] -> m (Either Error ())
applyFwdCompare = forall (t :: * -> *) (f :: * -> *) (m :: * -> *) v.
(Traversable t, Applicative f, Monad m) =>
(v -> m (f ())) -> t v -> m (f ())
traverseM_ forall a b. (a -> b) -> a -> b
$ \(Patch a
a Index m
s (HFunctorList (Flap r a
cm :& Rec (Flap a) rs
RNil))) -> do
forall (m :: * -> *). FwdInplaceStream m => Index m -> m ()
advance Index m
s
a
aStream <- forall (m :: * -> *). FwdInplaceStream m => Index m -> m (Chunk m)
readahead forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. HasLength a => a -> Int
getLength a
a
case forall (v :: Via) a. Meta v a -> Maybe (CompareRep v a)
Compare.mCompare r a
cm of
Maybe (CompareRep v a)
Nothing -> do
()
x <- forall (m :: * -> *). FwdInplaceStream m => Chunk m -> m ()
overwrite a
a
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()
x
Just CompareRep v a
aCmp -> case forall (v :: Via) a.
Compare v a =>
CompareRep v a -> a -> Maybe String
compareTo @v CompareRep v a
aCmp a
aStream of
Maybe String
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right ()
Just String
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> Error
ErrorCompare String
e
runPureFwdCompareString
:: Compare v String
=> [Patch Int '[Compare.Meta v] String]
-> String
-> Either Error String
runPureFwdCompareString :: forall (v :: Via).
Compare v String =>
[Patch Int '[Meta v] String] -> String -> Either Error String
runPureFwdCompareString [Patch Int '[Meta v] String]
ps String
start =
let (Either Error ()
r, (String
remaining, String
patched, Int
_)) = forall s a. State s a -> s -> (a, s)
runState (forall a (v :: Via) (m :: * -> *).
(FwdInplaceStream m, Chunk m ~ a, Compare v a, HasLength a,
Num (Index m)) =>
[Patch (Index m) '[Meta v] a] -> m (Either Error ())
applyFwdCompare [Patch Int '[Meta v] String]
ps) (String
start, String
"", Int
0 :: Int)
in case Either Error ()
r of
Left Error
err -> forall a b. a -> Either a b
Left Error
err
Right () -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ String
patched forall a. Semigroup a => a -> a -> a
<> String
remaining