{-# LANGUAGE DataKinds, TypeFamilies, UndecidableInstances #-}

module BytePatch.Linear.Gen (gen, Error(..)) where

import           BytePatch.Core

import qualified Data.ByteString        as BS
import           Control.Monad.State
import qualified Data.List              as List
import           GHC.Natural

type Bytes = BS.ByteString

-- | Error encountered during linear patchscript generation.
data Error s a
  = ErrorOverlap (Patch s a) (Patch s a)
  -- ^ Two edits wrote to the same offset.

deriving instance (Eq (SeekRep s), Eq a) => Eq (Error s a)
deriving instance (Show (SeekRep s), Show a) => Show (Error s a)

-- | Process a list of patches into a linear patch script.
--
-- Errors are reported, but do not interrupt patch generation. The user could
-- discard patchscripts that errored, or perhaps attempt to recover them. This
-- is what we do for errors:
--
--   * overlapping edit: later edit is skipped & overlapping edits reported
gen
    :: [Patch 'AbsSeek Bytes]
    -> ([Patch 'FwdSeek Bytes], [Error 'AbsSeek Bytes])
gen :: [Patch 'AbsSeek Bytes]
-> ([Patch 'FwdSeek Bytes], [Error 'AbsSeek Bytes])
gen [Patch 'AbsSeek Bytes]
pList =
    let pList' :: [Patch 'AbsSeek Bytes]
pList'                 = (Patch 'AbsSeek Bytes -> Patch 'AbsSeek Bytes -> Ordering)
-> [Patch 'AbsSeek Bytes] -> [Patch 'AbsSeek Bytes]
forall a. (a -> a -> Ordering) -> [a] -> [a]
List.sortBy Patch 'AbsSeek Bytes -> Patch 'AbsSeek Bytes -> Ordering
forall {s :: SeekKind} {s :: SeekKind} {a} {a}.
(Ord (SeekRep s), SeekRep s ~ SeekRep s) =>
Patch s a -> Patch s a -> Ordering
comparePatchOffsets [Patch 'AbsSeek Bytes]
pList
        (Natural
_, [Patch 'FwdSeek Bytes]
script, [Error 'AbsSeek Bytes]
errors, Patch 'AbsSeek Bytes
_) = State
  (Natural, [Patch 'FwdSeek Bytes], [Error 'AbsSeek Bytes],
   Patch 'AbsSeek Bytes)
  ()
-> (Natural, [Patch 'FwdSeek Bytes], [Error 'AbsSeek Bytes],
    Patch 'AbsSeek Bytes)
-> (Natural, [Patch 'FwdSeek Bytes], [Error 'AbsSeek Bytes],
    Patch 'AbsSeek Bytes)
forall s a. State s a -> s -> s
execState ([Patch 'AbsSeek Bytes]
-> State
     (Natural, [Patch 'FwdSeek Bytes], [Error 'AbsSeek Bytes],
      Patch 'AbsSeek Bytes)
     ()
forall (m :: * -> *).
MonadState
  (Natural, [Patch 'FwdSeek Bytes], [Error 'AbsSeek Bytes],
   Patch 'AbsSeek Bytes)
  m =>
[Patch 'AbsSeek Bytes] -> m ()
go [Patch 'AbsSeek Bytes]
pList') (Natural
0, [], [], Patch 'AbsSeek Bytes
forall a. HasCallStack => a
undefined)
        -- I believe the undefined is inaccessible providing the first patch has
        -- a non-negative offset (negative offsets are forbidden)
     in ([Patch 'FwdSeek Bytes] -> [Patch 'FwdSeek Bytes]
forall a. [a] -> [a]
reverse [Patch 'FwdSeek Bytes]
script, [Error 'AbsSeek Bytes] -> [Error 'AbsSeek Bytes]
forall a. [a] -> [a]
reverse [Error 'AbsSeek Bytes]
errors)
  where
    comparePatchOffsets :: Patch s a -> Patch s a -> Ordering
comparePatchOffsets (Patch SeekRep s
o1 Edit a
_) (Patch SeekRep s
o2 Edit a
_) = SeekRep s -> SeekRep s -> Ordering
forall a. Ord a => a -> a -> Ordering
compare SeekRep s
SeekRep s
o1 SeekRep s
o2
    go
        :: (MonadState (Natural, [Patch 'FwdSeek Bytes], [Error 'AbsSeek Bytes], Patch 'AbsSeek Bytes) m)
        => [Patch 'AbsSeek Bytes]
        -> m ()
    go :: forall (m :: * -> *).
MonadState
  (Natural, [Patch 'FwdSeek Bytes], [Error 'AbsSeek Bytes],
   Patch 'AbsSeek Bytes)
  m =>
[Patch 'AbsSeek Bytes] -> m ()
go [] = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    go (p :: Patch 'AbsSeek Bytes
p@(Patch SeekRep 'AbsSeek
offset Edit Bytes
edit) : [Patch 'AbsSeek Bytes]
ps) = do
        (Natural
cursor, [Patch 'FwdSeek Bytes]
script, [Error 'AbsSeek Bytes]
errors, Patch 'AbsSeek Bytes
prevPatch) <- m (Natural, [Patch 'FwdSeek Bytes], [Error 'AbsSeek Bytes],
   Patch 'AbsSeek Bytes)
forall s (m :: * -> *). MonadState s m => m s
get
        case Natural
SeekRep 'AbsSeek
offset Natural -> Natural -> Maybe Natural
`minusNaturalMaybe` Natural
cursor of
          -- next offset is behind current cursor: overlapping patches
          -- record error, recover via dropping patch
          Maybe Natural
Nothing -> do
            let e :: Error 'AbsSeek Bytes
e = Patch 'AbsSeek Bytes
-> Patch 'AbsSeek Bytes -> Error 'AbsSeek Bytes
forall (s :: SeekKind) a. Patch s a -> Patch s a -> Error s a
ErrorOverlap Patch 'AbsSeek Bytes
p Patch 'AbsSeek Bytes
prevPatch
            let errors' :: [Error 'AbsSeek Bytes]
errors' = Error 'AbsSeek Bytes
e Error 'AbsSeek Bytes
-> [Error 'AbsSeek Bytes] -> [Error 'AbsSeek Bytes]
forall a. a -> [a] -> [a]
: [Error 'AbsSeek Bytes]
errors
            (Natural, [Patch 'FwdSeek Bytes], [Error 'AbsSeek Bytes],
 Patch 'AbsSeek Bytes)
-> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Natural
cursor, [Patch 'FwdSeek Bytes]
script, [Error 'AbsSeek Bytes]
errors', Patch 'AbsSeek Bytes
p)
            [Patch 'AbsSeek Bytes] -> m ()
forall (m :: * -> *).
MonadState
  (Natural, [Patch 'FwdSeek Bytes], [Error 'AbsSeek Bytes],
   Patch 'AbsSeek Bytes)
  m =>
[Patch 'AbsSeek Bytes] -> m ()
go [Patch 'AbsSeek Bytes]
ps
          Just Natural
skip -> do
            let dataLen :: Natural
dataLen = Int -> Natural
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Natural) -> Int -> Natural
forall a b. (a -> b) -> a -> b
$ Bytes -> Int
BS.length (Bytes -> Int) -> Bytes -> Int
forall a b. (a -> b) -> a -> b
$ Edit Bytes -> Bytes
forall a. Edit a -> a
editData Edit Bytes
edit
            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
+ Natural
dataLen
            (Natural, [Patch 'FwdSeek Bytes], [Error 'AbsSeek Bytes],
 Patch 'AbsSeek Bytes)
-> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Natural
cursor', SeekRep 'FwdSeek -> Edit Bytes -> Patch 'FwdSeek Bytes
forall (s :: SeekKind) a. SeekRep s -> Edit a -> Patch s a
Patch Natural
SeekRep 'FwdSeek
skip Edit Bytes
edit Patch 'FwdSeek Bytes
-> [Patch 'FwdSeek Bytes] -> [Patch 'FwdSeek Bytes]
forall a. a -> [a] -> [a]
: [Patch 'FwdSeek Bytes]
script, [Error 'AbsSeek Bytes]
errors, Patch 'AbsSeek Bytes
p)
            [Patch 'AbsSeek Bytes] -> m ()
forall (m :: * -> *).
MonadState
  (Natural, [Patch 'FwdSeek Bytes], [Error 'AbsSeek Bytes],
   Patch 'AbsSeek Bytes)
  m =>
[Patch 'AbsSeek Bytes] -> m ()
go [Patch 'AbsSeek Bytes]
ps