{-# 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
getLength :: a -> Len
instance HasLength BS.ByteString where getLength :: ByteString -> Len
getLength = ByteString -> Len
BS.length
instance HasLength Text where getLength :: Text -> Len
getLength = Text -> Len
Text.length
instance HasLength String where getLength :: String -> Len
getLength = forall (t :: * -> *) a. Foldable t => t a -> Len
List.length
data Error fs a
= ErrorOverlap
Len
(Patch Len fs a)
(Patch Len fs a)
deriving (forall (fs :: [* -> *]) a x. Rep (Error fs a) x -> Error fs a
forall (fs :: [* -> *]) a x. Error fs a -> Rep (Error fs a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall (fs :: [* -> *]) a x. Rep (Error fs a) x -> Error fs a
$cfrom :: forall (fs :: [* -> *]) a x. Error fs a -> Rep (Error fs a) x
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 :: forall a (fs :: [* -> *]).
HasLength a =>
[Patch Len fs a] -> Either (Error fs a) [Patch Len fs a]
linearizeInPlace [Patch Len fs a]
ps = forall s a. State s a -> s -> a
evalState (forall (t :: * -> *) (f :: * -> *) (m :: * -> *) v v'.
(Traversable t, Applicative f, Monad m) =>
(v -> m (f v')) -> t v -> m (f (t v'))
traverseM forall {m :: * -> *} {fs :: [* -> *]} {a}.
(MonadState (Len, Patch Len fs a) m, HasLength a) =>
Patch Len fs a -> m (Either (Error fs a) (Patch Len fs a))
go (forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy forall s (fs :: [* -> *]) a.
Ord s =>
Patch s fs a -> Patch s fs a -> Ordering
comparePatchSeeks [Patch Len fs a]
ps)) (Len
0, forall a. HasCallStack => a
undefined)
where
go :: Patch Len fs a -> m (Either (Error fs a) (Patch Len fs a))
go p :: Patch Len fs a
p@(Patch a
a Len
s HFunctorList fs a
_) = do
(Len
cursor, Patch Len fs a
pPrev) <- forall s (m :: * -> *). MonadState s m => m s
get
let skip :: Len
skip = Len
s forall a. Num a => a -> a -> a
- Len
cursor
if Len
skip forall a. Ord a => a -> a -> Bool
< Len
0 then do
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
$ forall (fs :: [* -> *]) a.
Len -> Patch Len fs a -> Patch Len fs a -> Error fs a
ErrorOverlap Len
cursor Patch Len fs a
p Patch Len fs a
pPrev
else do
let cursor' :: Len
cursor' = Len
cursor forall a. Num a => a -> a -> a
+ Len
skip forall a. Num a => a -> a -> a
+ forall a. HasLength a => a -> Len
getLength a
a
p' :: Patch Len fs a
p' = Patch Len fs a
p { patchSeek :: Len
patchSeek = Len
skip }
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Len
cursor', Patch Len fs a
p)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Patch Len fs a
p'