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 -- ^ 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 ((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
          -- next absolute seek is before cursor: current patch overlaps prev
          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)