{-# 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 :: 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 = String -> Len
forall (t :: * -> *) a. Foldable t => t a -> Len
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 ((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 (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 = State (Len, Patch Len fs a) (Either (Error fs a) [Patch Len fs a])
-> (Len, Patch Len fs a) -> Either (Error fs a) [Patch Len fs a]
forall s a. State s a -> s -> a
evalState ((Patch Len fs a
 -> StateT
      (Len, Patch Len fs a)
      Identity
      (Either (Error fs a) (Patch Len fs a)))
-> [Patch Len fs a]
-> State
     (Len, Patch Len fs a) (Either (Error fs a) [Patch Len 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 Len fs a
-> StateT
     (Len, Patch Len fs a)
     Identity
     (Either (Error fs a) (Patch Len fs a))
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 ((Patch Len fs a -> Patch Len fs a -> Ordering)
-> [Patch Len fs a] -> [Patch Len fs a]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy Patch Len fs a -> Patch Len fs a -> Ordering
forall s (fs :: [* -> *]) a.
Ord s =>
Patch s fs a -> Patch s fs a -> Ordering
comparePatchSeeks [Patch Len fs a]
ps)) (Len
0, Patch Len fs a
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) <- m (Len, Patch Len fs a)
forall s (m :: * -> *). MonadState s m => m s
get
        let skip :: Len
skip = Len
s Len -> Len -> Len
forall a. Num a => a -> a -> a
- Len
cursor
        if Len
skip Len -> Len -> Bool
forall a. Ord a => a -> a -> Bool
< Len
0 then do
            -- next absolute seek is before cursor: current patch overlaps prev
            Either (Error fs a) (Patch Len fs a)
-> m (Either (Error fs a) (Patch Len fs a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Error fs a) (Patch Len fs a)
 -> m (Either (Error fs a) (Patch Len fs a)))
-> Either (Error fs a) (Patch Len fs a)
-> m (Either (Error fs a) (Patch Len fs a))
forall a b. (a -> b) -> a -> b
$ Error fs a -> Either (Error fs a) (Patch Len fs a)
forall a b. a -> Either a b
Left (Error fs a -> Either (Error fs a) (Patch Len fs a))
-> Error fs a -> Either (Error fs a) (Patch Len fs a)
forall a b. (a -> b) -> a -> b
$ Len -> Patch Len fs a -> Patch Len fs a -> Error fs a
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 Len -> Len -> Len
forall a. Num a => a -> a -> a
+ Len
skip Len -> Len -> Len
forall a. Num a => a -> a -> a
+ a -> Len
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 }
            (Len, Patch Len fs a) -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Len
cursor', Patch Len fs a
p)
            Either (Error fs a) (Patch Len fs a)
-> m (Either (Error fs a) (Patch Len fs a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Error fs a) (Patch Len fs a)
 -> m (Either (Error fs a) (Patch Len fs a)))
-> Either (Error fs a) (Patch Len fs a)
-> m (Either (Error fs a) (Patch Len fs a))
forall a b. (a -> b) -> a -> b
$ Patch Len fs a -> Either (Error fs a) (Patch Len fs a)
forall a b. b -> Either a b
Right Patch Len fs a
p'