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 :: ByteString -> Natural
getLength = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> (ByteString -> Int) -> ByteString -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int
BS.length
instance HasLength Text where
getLength :: Text -> Natural
getLength = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> (Text -> Int) -> Text -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Int
Text.length
instance HasLength String where
getLength :: String -> Natural
getLength = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> (String -> Int) -> String -> Natural
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
List.length
data Error fs a
= ErrorOverlap
(SeekRep 'AbsSeek)
(Patch 'AbsSeek fs a)
(Patch 'AbsSeek fs a)
deriving ((forall x. Error fs a -> Rep (Error fs a) x)
-> (forall x. Rep (Error fs a) x -> Error fs a)
-> Generic (Error fs a)
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 x. Rep (Error fs a) x -> Error fs a
forall 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 (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 :: forall a (fs :: [* -> *]).
HasLength a =>
[Patch 'AbsSeek fs a] -> Either (Error fs a) [Patch 'FwdSeek fs a]
linearize [Patch 'AbsSeek fs a]
ps = State
(Natural, Patch 'AbsSeek fs a)
(Either (Error fs a) [Patch 'FwdSeek fs a])
-> (Natural, Patch 'AbsSeek fs a)
-> Either (Error fs a) [Patch 'FwdSeek fs a]
forall s a. State s a -> s -> a
evalState ((Patch 'AbsSeek fs a
-> StateT
(Natural, Patch 'AbsSeek fs a)
Identity
(Either (Error fs a) (Patch 'FwdSeek fs a)))
-> [Patch 'AbsSeek fs a]
-> State
(Natural, Patch 'AbsSeek fs a)
(Either (Error fs a) [Patch 'FwdSeek fs a])
forall (t :: * -> *) (f :: * -> *) (m :: * -> *) v v'.
(Traversable t, Applicative f, Monad m) =>
(v -> m (f v')) -> t v -> m (f (t v'))
traverseM Patch 'AbsSeek fs a
-> StateT
(Natural, Patch 'AbsSeek fs a)
Identity
(Either (Error fs a) (Patch 'FwdSeek fs a))
forall {m :: * -> *} {fs :: [* -> *]} {a} {s :: SeekKind}.
(MonadState (Natural, Patch 'AbsSeek fs a) m, HasLength a,
SeekRep s ~ Natural) =>
Patch 'AbsSeek fs a -> m (Either (Error fs a) (Patch s fs a))
go ((Patch 'AbsSeek fs a -> Patch 'AbsSeek fs a -> Ordering)
-> [Patch 'AbsSeek fs a] -> [Patch 'AbsSeek fs a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy Patch 'AbsSeek fs a -> Patch 'AbsSeek fs a -> Ordering
forall (s :: SeekKind) (fs :: [* -> *]) a.
Ord (SeekRep s) =>
Patch s fs a -> Patch s fs a -> Ordering
comparePatchSeeks [Patch 'AbsSeek fs a]
ps)) (Natural
0, Patch 'AbsSeek fs a
forall a. HasCallStack => a
undefined)
where
go :: Patch 'AbsSeek fs a -> m (Either (Error fs a) (Patch s fs a))
go p :: Patch 'AbsSeek fs a
p@(Patch a
a SeekRep 'AbsSeek
s FunctorRec fs a
_) = do
(Natural
cursor, Patch 'AbsSeek fs a
pPrev) <- m (Natural, Patch 'AbsSeek fs a)
forall s (m :: * -> *). MonadState s m => m s
get
case Natural
SeekRep 'AbsSeek
s Natural -> Natural -> Maybe Natural
`minusNaturalMaybe` Natural
cursor of
Maybe Natural
Nothing -> Either (Error fs a) (Patch s fs a)
-> m (Either (Error fs a) (Patch s fs a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Error fs a) (Patch s fs a)
-> m (Either (Error fs a) (Patch s fs a)))
-> Either (Error fs a) (Patch s fs a)
-> m (Either (Error fs a) (Patch s fs a))
forall a b. (a -> b) -> a -> b
$ Error fs a -> Either (Error fs a) (Patch s fs a)
forall a b. a -> Either a b
Left (Error fs a -> Either (Error fs a) (Patch s fs a))
-> Error fs a -> Either (Error fs a) (Patch s fs a)
forall a b. (a -> b) -> a -> b
$ SeekRep 'AbsSeek
-> Patch 'AbsSeek fs a -> Patch 'AbsSeek fs a -> Error fs a
forall (fs :: [* -> *]) a.
SeekRep 'AbsSeek
-> Patch 'AbsSeek fs a -> Patch 'AbsSeek fs a -> Error fs a
ErrorOverlap Natural
SeekRep 'AbsSeek
cursor Patch 'AbsSeek fs a
p Patch 'AbsSeek fs a
pPrev
Just Natural
skip -> do
let cursor' :: Natural
cursor' = Natural
cursor Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ Natural
skip Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
+ a -> Natural
forall a. HasLength a => a -> Natural
getLength a
a
p' :: Patch s fs a
p' = Patch 'AbsSeek fs a
p { patchSeek :: SeekRep s
patchSeek = Natural
SeekRep s
skip }
(Natural, Patch 'AbsSeek fs a) -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Natural
cursor', Patch 'AbsSeek fs a
p)
Either (Error fs a) (Patch s fs a)
-> m (Either (Error fs a) (Patch s fs a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Error fs a) (Patch s fs a)
-> m (Either (Error fs a) (Patch s fs a)))
-> Either (Error fs a) (Patch s fs a)
-> m (Either (Error fs a) (Patch s fs a))
forall a b. (a -> b) -> a -> b
$ Patch s fs a -> Either (Error fs a) (Patch s fs a)
forall a b. b -> Either a b
Right Patch s fs a
p'
comparePatchSeeks :: Ord (SeekRep s) => Patch s fs a -> Patch s fs a -> Ordering
comparePatchSeeks :: forall (s :: SeekKind) (fs :: [* -> *]) a.
Ord (SeekRep s) =>
Patch s fs a -> Patch s fs a -> Ordering
comparePatchSeeks Patch s fs a
p1 Patch s fs a
p2 = SeekRep s -> SeekRep s -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Patch s fs a -> SeekRep s
forall (s :: SeekKind) (fs :: [* -> *]) a.
Patch s fs a -> SeekRep s
patchSeek Patch s fs a
p1) (Patch s fs a -> SeekRep s
forall (s :: SeekKind) (fs :: [* -> *]) a.
Patch s fs a -> SeekRep s
patchSeek Patch s fs a
p2)