{-# OPTIONS_GHC -fno-warn-orphans #-}
module Darcs.Patch.Prim.V1 ( Prim ) where

import Darcs.Prelude

import Data.Maybe ( fromMaybe )

import Darcs.Patch.Prim.V1.Apply ()
import Darcs.Patch.Prim.V1.Coalesce ()
import Darcs.Patch.Prim.V1.Commute ()
import Darcs.Patch.Prim.V1.Core ( Prim )
import Darcs.Patch.Prim.V1.Details ()
import Darcs.Patch.Prim.V1.Mangle ()
import Darcs.Patch.Prim.V1.Read ()
import Darcs.Patch.Prim.V1.Show ()

import Darcs.Patch.Commute ( Commute(..), commuteFL )
import Darcs.Patch.Invert ( Invert(..), dropInverses )
import Darcs.Patch.Prim.Class
    ( PrimSift(..)
    , PrimClassify
      ( primIsHunk
      , primIsBinary
      , primIsSetpref
      , primIsAddfile
      , primIsAdddir
      )
    , PrimCanonize(tryToShrink)
    )
import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )
import Darcs.Patch.Witnesses.Ordered
    ( FL(..)
    , RL(..)
    , (:>)(..)
    , allFL
    , lengthFL
    , reverseFL
    , filterOutFLFL
    )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )

instance PrimSift Prim where
  siftForPending :: FL Prim wX wY -> Sealed (FL Prim wX)
siftForPending = FL Prim wX wY -> Sealed (FL Prim wX)
forall (prim :: * -> * -> *) wX wY.
(Commute prim, Invert prim, Eq2 prim, PrimCanonize prim,
 PrimClassify prim) =>
FL prim wX wY -> Sealed (FL prim wX)
v1siftForPending where

    -- | An optimized version of 'siftForPending' that avoids commutation
    -- in case all prim patches are "simple" i.e. hunk, binary, or setpref.
    -- Otherwise it returns the original sequence.
    crudeSift :: forall prim wX wY. PrimClassify prim
              => FL prim wX wY -> FL prim wX wY
    crudeSift :: FL prim wX wY -> FL prim wX wY
crudeSift FL prim wX wY
xs =
      if FL prim wX wY -> Bool
forall wW wZ. FL prim wW wZ -> Bool
isSimple FL prim wX wY
xs
        then (forall wX wY. prim wX wY -> EqCheck wX wY)
-> FL prim wX wY -> FL prim wX wY
forall (p :: * -> * -> *) wW wZ.
(forall wX wY. p wX wY -> EqCheck wX wY)
-> FL p wW wZ -> FL p wW wZ
filterOutFLFL forall wX wY. prim wX wY -> EqCheck wX wY
ishunkbinary FL prim wX wY
xs
        else FL prim wX wY
xs
      where
        ishunkbinary :: prim wA wB -> EqCheck wA wB
        ishunkbinary :: prim wA wB -> EqCheck wA wB
ishunkbinary prim wA wB
x
          | prim wA wB -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsHunk prim wA wB
x Bool -> Bool -> Bool
|| prim wA wB -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsBinary prim wA wB
x = EqCheck Any Any -> EqCheck wA wB
forall (a :: * -> * -> *) wX wY wB wC. a wX wY -> a wB wC
unsafeCoerceP EqCheck Any Any
forall wA. EqCheck wA wA
IsEq
          | Bool
otherwise = EqCheck wA wB
forall wA wB. EqCheck wA wB
NotEq
        isSimple :: FL prim wW wZ -> Bool
isSimple = (forall wX wY. prim wX wY -> Bool) -> FL prim wW wZ -> Bool
forall (a :: * -> * -> *) wW wZ.
(forall wX wY. a wX wY -> Bool) -> FL a wW wZ -> Bool
allFL ((forall wX wY. prim wX wY -> Bool) -> FL prim wW wZ -> Bool)
-> (forall wX wY. prim wX wY -> Bool) -> FL prim wW wZ -> Bool
forall a b. (a -> b) -> a -> b
$ \prim wX wY
x -> prim wX wY -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsHunk prim wX wY
x Bool -> Bool -> Bool
|| prim wX wY -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsBinary prim wX wY
x Bool -> Bool -> Bool
|| prim wX wY -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsSetpref prim wX wY
x

    -- | Alternately 'sift' and 'tryToShrink' until shrinking no longer reduces
    -- the length of the sequence. Here, 'sift' means to commute hunks
    -- and binary patches to the end of the sequence and then drop them.
    v1siftForPending
      :: forall prim wX wY.
         (Commute prim, Invert prim, Eq2 prim, PrimCanonize prim, PrimClassify prim)
      => FL prim wX wY
      -> Sealed (FL prim wX)
    v1siftForPending :: FL prim wX wY -> Sealed (FL prim wX)
v1siftForPending FL prim wX wY
simple_ps
      -- optimization: no need to sift if only adddir or addfile are present
      | (forall wX wY. prim wX wY -> Bool) -> FL prim wX wY -> Bool
forall (a :: * -> * -> *) wW wZ.
(forall wX wY. a wX wY -> Bool) -> FL a wW wZ -> Bool
allFL (\prim wX wY
p -> prim wX wY -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsAddfile prim wX wY
p Bool -> Bool -> Bool
|| prim wX wY -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsAdddir prim wX wY
p) FL prim wX wY
oldps = FL prim wX wY -> Sealed (FL prim wX)
forall (a :: * -> *) wX. a wX -> Sealed a
seal FL prim wX wY
oldps
      | Bool
otherwise =
          case RL prim wX wY -> FL prim wY wY -> Sealed (FL prim wX)
forall wA wB wC.
RL prim wA wB -> FL prim wB wC -> Sealed (FL prim wA)
sift (FL prim wX wY -> RL prim wX wY
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL prim wX wY
oldps) FL prim wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL of
            Sealed FL prim wX wX
x ->
              let ps :: FL prim wX wX
ps = FL prim wX wX -> FL prim wX wX
forall (prim :: * -> * -> *) wX wY.
PrimCanonize prim =>
FL prim wX wY -> FL prim wX wY
tryToShrink FL prim wX wX
x in
              if (FL prim wX wX -> Int
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Int
lengthFL FL prim wX wX
ps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< FL prim wX wY -> Int
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Int
lengthFL FL prim wX wY
oldps)
                then FL prim wX wX -> Sealed (FL prim wX)
forall (prim :: * -> * -> *) wX wY.
(Commute prim, Invert prim, Eq2 prim, PrimCanonize prim,
 PrimClassify prim) =>
FL prim wX wY -> Sealed (FL prim wX)
v1siftForPending FL prim wX wX
ps
                else FL prim wX wX -> Sealed (FL prim wX)
forall (a :: * -> *) wX. a wX -> Sealed a
seal FL prim wX wX
ps
      where
        oldps :: FL prim wX wY
oldps = FL prim wX wY -> Maybe (FL prim wX wY) -> FL prim wX wY
forall a. a -> Maybe a -> a
fromMaybe FL prim wX wY
simple_ps (Maybe (FL prim wX wY) -> FL prim wX wY)
-> Maybe (FL prim wX wY) -> FL prim wX wY
forall a b. (a -> b) -> a -> b
$ FL prim wX wY -> Maybe (FL prim wX wY)
forall (p :: * -> * -> *) wX wY.
(Invert p, Eq2 p) =>
FL p wX wY -> Maybe (FL p wX wY)
dropInverses (FL prim wX wY -> Maybe (FL prim wX wY))
-> FL prim wX wY -> Maybe (FL prim wX wY)
forall a b. (a -> b) -> a -> b
$ FL prim wX wY -> FL prim wX wY
forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
FL prim wX wY -> FL prim wX wY
crudeSift FL prim wX wY
simple_ps
        -- get rid of any hunk/binary patches that we can commute out the
        -- back (ie. we work our way backwards, pushing the patches down
        -- to the very end and popping them off; so in (addfile f :> hunk)
        -- we can nuke the hunk, but not so in (hunk :> replace)
        sift :: RL prim wA wB -> FL prim wB wC -> Sealed (FL prim wA)
        sift :: RL prim wA wB -> FL prim wB wC -> Sealed (FL prim wA)
sift RL prim wA wB
NilRL FL prim wB wC
sofar = FL prim wB wC -> Sealed (FL prim wB)
forall (a :: * -> *) wX. a wX -> Sealed a
seal FL prim wB wC
sofar
        sift (RL prim wA wY
ps :<: prim wY wB
p) FL prim wB wC
sofar
          | prim wY wB -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsHunk prim wY wB
p Bool -> Bool -> Bool
|| prim wY wB -> Bool
forall (prim :: * -> * -> *) wX wY.
PrimClassify prim =>
prim wX wY -> Bool
primIsBinary prim wY wB
p
          , Just (FL prim wY wZ
sofar' :> prim wZ wC
_) <- (:>) prim (FL prim) wY wC -> Maybe ((:>) (FL prim) prim wY wC)
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p (FL p) wX wY -> Maybe ((:>) (FL p) p wX wY)
commuteFL (prim wY wB
p prim wY wB -> FL prim wB wC -> (:>) prim (FL prim) wY wC
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL prim wB wC
sofar) = RL prim wA wY -> FL prim wY wZ -> Sealed (FL prim wA)
forall wA wB wC.
RL prim wA wB -> FL prim wB wC -> Sealed (FL prim wA)
sift RL prim wA wY
ps FL prim wY wZ
sofar'
          | Bool
otherwise = RL prim wA wY -> FL prim wY wC -> Sealed (FL prim wA)
forall wA wB wC.
RL prim wA wB -> FL prim wB wC -> Sealed (FL prim wA)
sift RL prim wA wY
ps (prim wY wB
p prim wY wB -> FL prim wB wC -> FL prim wY wC
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL prim wB wC
sofar)