module StreamPatch.Patch.Align where

import           StreamPatch.Patch

import           GHC.Generics ( Generic )
import           Numeric.Natural
import           GHC.Natural ( naturalFromInteger )
import           Data.Vinyl
import           Data.Vinyl.TypeLevel
import           Data.Functor.Const

data Meta s = Meta
  { forall (s :: SeekKind). Meta s -> Maybe (SeekRep s)
mExpected :: Maybe (SeekRep s)
  -- ^ Absolute stream offset for edit. Used for checking against actual offset.
  } deriving ((forall x. Meta s -> Rep (Meta s) x)
-> (forall x. Rep (Meta s) x -> Meta s) -> Generic (Meta s)
forall x. Rep (Meta s) x -> Meta s
forall x. Meta s -> Rep (Meta s) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (s :: SeekKind) x. Rep (Meta s) x -> Meta s
forall (s :: SeekKind) x. Meta s -> Rep (Meta s) x
$cto :: forall (s :: SeekKind) x. Rep (Meta s) x -> Meta s
$cfrom :: forall (s :: SeekKind) x. Meta s -> Rep (Meta s) x
Generic)

deriving instance (Eq   (SeekRep s)) => Eq   (Meta s)
deriving instance (Show (SeekRep s)) => Show (Meta s)

data Error s
  = ErrorSeekBelow0 (SeekRep 'RelSeek)
  | ErrorDoesntMatchExpected (SeekRep s) (SeekRep s) -- expected, then actual
    deriving ((forall x. Error s -> Rep (Error s) x)
-> (forall x. Rep (Error s) x -> Error s) -> Generic (Error s)
forall x. Rep (Error s) x -> Error s
forall x. Error s -> Rep (Error s) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (s :: SeekKind) x. Rep (Error s) x -> Error s
forall (s :: SeekKind) x. Error s -> Rep (Error s) x
$cto :: forall (s :: SeekKind) x. Rep (Error s) x -> Error s
$cfrom :: forall (s :: SeekKind) x. Error s -> Rep (Error s) x
Generic)

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

-- | Attempt to align the given patch to 0 using the given base.
align
    :: forall s a ss rs is i r
    .  ( SeekRep s ~ Natural
       , r ~ Const (Meta s)
       , rs ~ RDelete r ss
       , RElem r ss i
       , RSubset rs ss is )
    => SeekRep 'RelSeek
    -> Patch 'RelSeek ss a
    -> Either (Error s) (Patch s rs a)
align :: forall (s :: SeekKind) a (ss :: [* -> *]) (rs :: [* -> *])
       (is :: [Nat]) (i :: Nat) (r :: * -> *).
(SeekRep s ~ Natural, r ~ Const (Meta s), rs ~ RDelete r ss,
 RElem r ss i, RSubset rs ss is) =>
SeekRep 'RelSeek
-> Patch 'RelSeek ss a -> Either (Error s) (Patch s rs a)
align SeekRep 'RelSeek
sBase (Patch a
a SeekRep 'RelSeek
s FunctorRec ss a
ms) =
    case Integer -> Maybe Natural
tryIntegerToNatural Integer
sAligned of
      Maybe Natural
Nothing          -> Error s -> Either (Error s) (Patch s rs a)
forall a b. a -> Either a b
Left (Error s -> Either (Error s) (Patch s rs a))
-> Error s -> Either (Error s) (Patch s rs a)
forall a b. (a -> b) -> a -> b
$ SeekRep 'RelSeek -> Error s
forall (s :: SeekKind). SeekRep 'RelSeek -> Error s
ErrorSeekBelow0 Integer
SeekRep 'RelSeek
sAligned
      Just Natural
sAlignedNat ->
        case Meta s -> Maybe (SeekRep s)
forall (s :: SeekKind). Meta s -> Maybe (SeekRep s)
mExpected Meta s
m of
          Maybe (SeekRep s)
Nothing        -> Natural -> Either (Error s) (Patch s rs a)
reform Natural
sAlignedNat
          Just SeekRep s
sExpected ->
            if   Natural
SeekRep s
sExpected Natural -> Natural -> Bool
forall a. Eq a => a -> a -> Bool
== Natural
sAlignedNat
            then Natural -> Either (Error s) (Patch s rs a)
reform Natural
sAlignedNat
            else Error s -> Either (Error s) (Patch s rs a)
forall a b. a -> Either a b
Left (Error s -> Either (Error s) (Patch s rs a))
-> Error s -> Either (Error s) (Patch s rs a)
forall a b. (a -> b) -> a -> b
$ SeekRep s -> SeekRep s -> Error s
forall (s :: SeekKind). SeekRep s -> SeekRep s -> Error s
ErrorDoesntMatchExpected SeekRep s
sExpected Natural
SeekRep s
sAlignedNat
  where
    sAligned :: Integer
sAligned = Integer
SeekRep 'RelSeek
sBase Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
SeekRep 'RelSeek
s
    -- TODO require a visible type application here, unsure why. even without
    -- the SeekRep indirection
    m :: Meta s
m = forall a b. Const a b -> a
forall {k} a (b :: k). Const a b -> a
getConst @(Meta s) (Const (Meta s) a -> Meta s) -> Const (Meta s) a -> Meta s
forall a b. (a -> b) -> a -> b
$ Flap a (Const (Meta s)) -> Const (Meta s) a
forall a (f :: * -> *). Flap a f -> f a
getFlap (Flap a (Const (Meta s)) -> Const (Meta s) a)
-> Flap a (Const (Meta s)) -> Const (Meta s) a
forall a b. (a -> b) -> a -> b
$ Rec (Flap a) ss -> Flap a (Const (Meta s))
forall {k} (r :: k) (rs :: [k]) (f :: k -> *)
       (record :: (k -> *) -> [k] -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f) =>
record f rs -> f r
rget (Rec (Flap a) ss -> Flap a (Const (Meta s)))
-> Rec (Flap a) ss -> Flap a (Const (Meta s))
forall a b. (a -> b) -> a -> b
$ FunctorRec ss a -> Rec (Flap a) ss
forall (fs :: [* -> *]) a. FunctorRec fs a -> Rec (Flap a) fs
getFunctorRec FunctorRec ss a
ms
    ms' :: FunctorRec rs a
ms' = Rec (Flap a) rs -> FunctorRec rs a
forall (fs :: [* -> *]) a. Rec (Flap a) fs -> FunctorRec fs a
FunctorRec (Rec (Flap a) rs -> FunctorRec rs a)
-> Rec (Flap a) rs -> FunctorRec rs a
forall a b. (a -> b) -> a -> b
$ forall (rs :: [* -> *]) (ss :: [* -> *]) (f :: (* -> *) -> *)
       (record :: ((* -> *) -> *) -> [* -> *] -> *) (is :: [Nat]).
(RecSubset record rs ss is, RecSubsetFCtx record f) =>
record f ss -> record f rs
forall {k1} {k2} (rs :: [k1]) (ss :: [k1]) (f :: k2 -> *)
       (record :: (k2 -> *) -> [k1] -> *) (is :: [Nat]).
(RecSubset record rs ss is, RecSubsetFCtx record f) =>
record f ss -> record f rs
rcast @rs (Rec (Flap a) ss -> Rec (Flap a) rs)
-> Rec (Flap a) ss -> Rec (Flap a) rs
forall a b. (a -> b) -> a -> b
$ FunctorRec ss a -> Rec (Flap a) ss
forall (fs :: [* -> *]) a. FunctorRec fs a -> Rec (Flap a) fs
getFunctorRec FunctorRec ss a
ms
    reform :: Natural -> Either (Error s) (Patch s rs a)
reform Natural
s' = Patch s rs a -> Either (Error s) (Patch s rs a)
forall a b. b -> Either a b
Right (Patch s rs a -> Either (Error s) (Patch s rs a))
-> Patch s rs a -> Either (Error s) (Patch s rs a)
forall a b. (a -> b) -> a -> b
$ a -> SeekRep s -> FunctorRec rs a -> Patch s rs a
forall (s :: SeekKind) (fs :: [* -> *]) a.
a -> SeekRep s -> FunctorRec fs a -> Patch s fs a
Patch a
a Natural
SeekRep s
s' FunctorRec rs a
ms'

tryIntegerToNatural :: Integer -> Maybe Natural
tryIntegerToNatural :: Integer -> Maybe Natural
tryIntegerToNatural Integer
n | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0     = Maybe Natural
forall a. Maybe a
Nothing
                      | Bool
otherwise = Natural -> Maybe Natural
forall a. a -> Maybe a
Just (Natural -> Maybe Natural) -> Natural -> Maybe Natural
forall a b. (a -> b) -> a -> b
$ Integer -> Natural
naturalFromInteger Integer
n