module Darcs.UI.ApplyPatches
    ( PatchApplier(..)
    , PatchProxy(..)
    , StandardPatchApplier(..)
    , applyPatchesStart
    , applyPatchesFinish
    ) where

import Darcs.Prelude

import Control.Monad ( when, void )

import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd )
import Darcs.Util.SignalHandler ( withSignalsBlocked )
import Darcs.UI.Commands
    ( putVerbose
    , putFinished
    , setEnvDarcsPatches
    )
import Darcs.UI.Commands.Util ( printDryRunMessageAndExit )
import Darcs.UI.Flags
    ( DarcsFlag, verbosity, compress, reorder, allowConflicts, externalMerge
    , wantGuiPause, diffingOpts, setScriptsExecutable, isInteractive, testChanges
    , xmlOutput, dryRun
    )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.Options ( (?) )
import Darcs.UI.Commands.Util ( testTentativeAndMaybeExit )
import Darcs.Repository.Flags ( UpdatePending(..) )
import Darcs.Repository
    ( Repository
    , tentativelyMergePatches
    , finalizeRepositoryChanges
    , applyToWorking
    , invalidateIndex
    , setScriptsExecutablePatches
    )
import Darcs.Repository.Job ( RepoJob(RepoJob) )
import Darcs.Patch ( RepoPatch, RepoType, IsRepoType, description )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.FromPrim ( PrimOf )
import Darcs.Patch.Set ( PatchSet, Origin )
import Darcs.Patch.Witnesses.Ordered
    ( FL, Fork(..), mapFL, nullFL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )

import Darcs.Util.English ( presentParticiple )
import Darcs.Util.Printer ( vcat, text )
import Darcs.Util.Tree( Tree )

import GHC.Exts ( Constraint )

data PatchProxy (p :: * -> * -> *) = PatchProxy

-- |This class is a hack to abstract over pull/apply and rebase pull/apply.
class PatchApplier pa where

    type ApplierRepoTypeConstraint pa (rt :: RepoType) :: Constraint

    repoJob
        :: pa
        -> (forall rt p wR wU
               . ( IsRepoType rt, ApplierRepoTypeConstraint pa rt
                 , RepoPatch p, ApplyState p ~ Tree
                 )
              => (PatchProxy p -> Repository rt p wR wU wR -> IO ()))
        -> RepoJob ()

    applyPatches
        :: forall rt p wR wU wZ
         . ( ApplierRepoTypeConstraint pa rt, IsRepoType rt
           , RepoPatch p, ApplyState p ~ Tree
           )
        => pa
        -> PatchProxy p
        -> String
        -> [DarcsFlag]
        -> Repository rt p wR wU wR
        -> Fork (PatchSet rt p)
                (FL (PatchInfoAnd rt p))
                (FL (PatchInfoAnd rt p)) Origin wR wZ
        -> IO ()

data StandardPatchApplier = StandardPatchApplier

instance PatchApplier StandardPatchApplier where
    type ApplierRepoTypeConstraint StandardPatchApplier rt = ()
    repoJob :: StandardPatchApplier
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
    (IsRepoType rt, ApplierRepoTypeConstraint StandardPatchApplier rt,
     RepoPatch p, ApplyState p ~ Tree) =>
    PatchProxy p -> Repository rt p wR wU wR -> IO ())
-> RepoJob ()
repoJob StandardPatchApplier
StandardPatchApplier forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, ApplierRepoTypeConstraint StandardPatchApplier rt,
 RepoPatch p, ApplyState p ~ Tree) =>
PatchProxy p -> Repository rt p wR wU wR -> IO ()
f = (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob (PatchProxy p -> Repository rt p wR wU wR -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, ApplierRepoTypeConstraint StandardPatchApplier rt,
 RepoPatch p, ApplyState p ~ Tree) =>
PatchProxy p -> Repository rt p wR wU wR -> IO ()
f PatchProxy p
forall (p :: * -> * -> *). PatchProxy p
PatchProxy)
    applyPatches :: StandardPatchApplier
-> PatchProxy p
-> String
-> [DarcsFlag]
-> Repository rt p wR wU wR
-> Fork
     (PatchSet rt p)
     (FL (PatchInfoAnd rt p))
     (FL (PatchInfoAnd rt p))
     Origin
     wR
     wZ
-> IO ()
applyPatches StandardPatchApplier
StandardPatchApplier PatchProxy p
PatchProxy = String
-> [DarcsFlag]
-> Repository rt p wR wU wR
-> Fork
     (PatchSet rt p)
     (FL (PatchInfoAnd rt p))
     (FL (PatchInfoAnd rt p))
     Origin
     wR
     wZ
-> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wZ.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
String
-> [DarcsFlag]
-> Repository rt p wR wU wR
-> Fork
     (PatchSet rt p)
     (FL (PatchInfoAnd rt p))
     (FL (PatchInfoAnd rt p))
     Origin
     wR
     wZ
-> IO ()
standardApplyPatches

standardApplyPatches :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                     => String
                     -> [DarcsFlag]
                     -> Repository rt p wR wU wR
                     -> Fork (PatchSet rt p)
                             (FL (PatchInfoAnd rt p))
                             (FL (PatchInfoAnd rt p)) Origin wR wZ
                     -> IO ()
standardApplyPatches :: String
-> [DarcsFlag]
-> Repository rt p wR wU wR
-> Fork
     (PatchSet rt p)
     (FL (PatchInfoAnd rt p))
     (FL (PatchInfoAnd rt p))
     Origin
     wR
     wZ
-> IO ()
standardApplyPatches String
cmdName [DarcsFlag]
opts Repository rt p wR wU wR
_repository patches :: Fork
  (PatchSet rt p)
  (FL (PatchInfoAnd rt p))
  (FL (PatchInfoAnd rt p))
  Origin
  wR
  wZ
patches@(Fork PatchSet rt p Origin wU
_ FL (PatchInfoAnd rt p) wU wR
_ FL (PatchInfoAnd rt p) wU wZ
to_be_applied) = do
    String -> [DarcsFlag] -> FL (PatchInfoAnd rt p) wU wZ -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
(RepoPatch p, ApplyState p ~ Tree) =>
String -> [DarcsFlag] -> FL (PatchInfoAnd rt p) wX wY -> IO ()
applyPatchesStart String
cmdName [DarcsFlag]
opts FL (PatchInfoAnd rt p) wU wZ
to_be_applied

    Sealed FL (PrimOf p) wU wX
pw <- Repository rt p wR wU wR
-> String
-> AllowConflicts
-> ExternalMerge
-> WantGuiPause
-> Compression
-> Verbosity
-> Reorder
-> (UseIndex, ScanKnown, DiffAlgorithm)
-> Fork
     (PatchSet rt p)
     (FL (PatchInfoAnd rt p))
     (FL (PatchInfoAnd rt p))
     Origin
     wR
     wZ
-> IO (Sealed (FL (PrimOf p) wU))
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wY.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wR
-> String
-> AllowConflicts
-> ExternalMerge
-> WantGuiPause
-> Compression
-> Verbosity
-> Reorder
-> (UseIndex, ScanKnown, DiffAlgorithm)
-> Fork
     (PatchSet rt p)
     (FL (PatchInfoAnd rt p))
     (FL (PatchInfoAnd rt p))
     Origin
     wR
     wY
-> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches Repository rt p wR wU wR
_repository String
cmdName
                         ([DarcsFlag] -> AllowConflicts
allowConflicts [DarcsFlag]
opts)
                         (PrimDarcsOption ExternalMerge
externalMerge PrimDarcsOption ExternalMerge -> [DarcsFlag] -> ExternalMerge
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) ([DarcsFlag] -> WantGuiPause
wantGuiPause [DarcsFlag]
opts)
                         (PrimDarcsOption Compression
compress PrimDarcsOption Compression -> [DarcsFlag] -> Compression
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
                         (PrimDarcsOption Reorder
reorder PrimDarcsOption Reorder -> [DarcsFlag] -> Reorder
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) ([DarcsFlag] -> (UseIndex, ScanKnown, DiffAlgorithm)
diffingOpts [DarcsFlag]
opts)
                         Fork
  (PatchSet rt p)
  (FL (PatchInfoAnd rt p))
  (FL (PatchInfoAnd rt p))
  Origin
  wR
  wZ
patches
    Repository rt p wR wU wR -> IO ()
forall t. t -> IO ()
invalidateIndex Repository rt p wR wU wR
_repository
    Repository rt p wR wU wR
-> Verbosity
-> TestChanges
-> SetScriptsExecutable
-> Bool
-> String
-> String
-> Maybe String
-> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT
-> Verbosity
-> TestChanges
-> SetScriptsExecutable
-> Bool
-> String
-> String
-> Maybe String
-> IO ()
testTentativeAndMaybeExit Repository rt p wR wU wR
_repository
         (PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
         (PrimDarcsOption TestChanges
testChanges PrimDarcsOption TestChanges -> [DarcsFlag] -> TestChanges
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
         (PrimDarcsOption SetScriptsExecutable
setScriptsExecutable PrimDarcsOption SetScriptsExecutable
-> [DarcsFlag] -> SetScriptsExecutable
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
         (Bool -> [DarcsFlag] -> Bool
isInteractive Bool
True [DarcsFlag]
opts)
         String
"those patches do not pass the tests." (String
cmdName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" them") Maybe String
forall a. Maybe a
Nothing

    String
-> [DarcsFlag]
-> Repository rt p wR wU wR
-> FL (PrimOf p) wU wX
-> Bool
-> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wY.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
String
-> [DarcsFlag]
-> Repository rt p wR wU wR
-> FL (PrimOf p) wU wY
-> Bool
-> IO ()
applyPatchesFinish String
cmdName [DarcsFlag]
opts Repository rt p wR wU wR
_repository FL (PrimOf p) wU wX
pw (FL (PatchInfoAnd rt p) wU wZ -> Bool
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL (PatchInfoAnd rt p) wU wZ
to_be_applied)

applyPatchesStart :: (RepoPatch p, ApplyState p ~ Tree)
                  => String -> [DarcsFlag] -> FL (PatchInfoAnd rt p) wX wY -> IO ()
applyPatchesStart :: String -> [DarcsFlag] -> FL (PatchInfoAnd rt p) wX wY -> IO ()
applyPatchesStart String
cmdName [DarcsFlag]
opts FL (PatchInfoAnd rt p) wX wY
to_be_applied = do
    String
-> Verbosity
-> WithSummary
-> DryRun
-> XmlOutput
-> Bool
-> FL (PatchInfoAnd rt p) wX wY
-> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
RepoPatch p =>
String
-> Verbosity
-> WithSummary
-> DryRun
-> XmlOutput
-> Bool
-> FL (PatchInfoAnd rt p) wX wY
-> IO ()
printDryRunMessageAndExit String
cmdName
        (PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
        (PrimDarcsOption WithSummary
O.withSummary PrimDarcsOption WithSummary -> [DarcsFlag] -> WithSummary
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
        (PrimDarcsOption DryRun
dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
        (PrimDarcsOption XmlOutput
xmlOutput PrimDarcsOption XmlOutput -> [DarcsFlag] -> XmlOutput
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
        (Bool -> [DarcsFlag] -> Bool
isInteractive Bool
True [DarcsFlag]
opts)
        FL (PatchInfoAnd rt p) wX wY
to_be_applied
    if FL (PatchInfoAnd rt p) wX wY -> Bool
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL (PatchInfoAnd rt p) wX wY
to_be_applied then
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"You don't want to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmdName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" any patches, and that's fine with me!"
    else do
        [DarcsFlag] -> Doc -> IO ()
putVerbose [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ String
"Will " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmdName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" the following patches:"
        [DarcsFlag] -> Doc -> IO ()
putVerbose [DarcsFlag]
opts (Doc -> IO ()) -> ([Doc] -> Doc) -> [Doc] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
vcat ([Doc] -> IO ()) -> [Doc] -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall wW wZ. PatchInfoAnd rt p wW wZ -> Doc)
-> FL (PatchInfoAnd rt p) wX wY -> [Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL forall wW wZ. PatchInfoAnd rt p wW wZ -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
description FL (PatchInfoAnd rt p) wX wY
to_be_applied
        FL (PatchInfoAnd rt p) wX wY -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
RepoPatch p =>
FL (PatchInfoAnd rt p) wX wY -> IO ()
setEnvDarcsPatches FL (PatchInfoAnd rt p) wX wY
to_be_applied

applyPatchesFinish :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
                   => String
                   -> [DarcsFlag]
                   -> Repository rt p wR wU wR
                   -> FL (PrimOf p) wU wY
                   -> Bool
                   -> IO ()
applyPatchesFinish :: String
-> [DarcsFlag]
-> Repository rt p wR wU wR
-> FL (PrimOf p) wU wY
-> Bool
-> IO ()
applyPatchesFinish String
cmdName [DarcsFlag]
opts Repository rt p wR wU wR
_repository FL (PrimOf p) wU wY
pw Bool
any_applied = do
    IO () -> IO ()
forall a. IO a -> IO a
withSignalsBlocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Repository rt p wR wU wR
_repository <-
            Repository rt p wR wU wR
-> UpdatePending -> Compression -> IO (Repository rt p wR wU wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> UpdatePending -> Compression -> IO (Repository rt p wT wU wT)
finalizeRepositoryChanges Repository rt p wR wU wR
_repository UpdatePending
YesUpdatePending (PrimDarcsOption Compression
compress PrimDarcsOption Compression -> [DarcsFlag] -> Compression
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
        IO (Repository rt p wR wY wR) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Repository rt p wR wY wR) -> IO ())
-> IO (Repository rt p wR wY wR) -> IO ()
forall a b. (a -> b) -> a -> b
$ Repository rt p wR wU wR
-> Verbosity
-> FL (PrimOf p) wU wY
-> IO (Repository rt p wR wY wR)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wR wU wT
-> Verbosity
-> FL (PrimOf p) wU wY
-> IO (Repository rt p wR wY wT)
applyToWorking Repository rt p wR wU wR
_repository (PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) FL (PrimOf p) wU wY
pw
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PrimDarcsOption SetScriptsExecutable
setScriptsExecutable PrimDarcsOption SetScriptsExecutable
-> [DarcsFlag] -> SetScriptsExecutable
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts SetScriptsExecutable -> SetScriptsExecutable -> Bool
forall a. Eq a => a -> a -> Bool
== SetScriptsExecutable
O.YesSetScriptsExecutable) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            FL (PrimOf p) wU wY -> IO ()
forall (p :: * -> * -> *) wX wY. PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches FL (PrimOf p) wU wY
pw
        () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    case (Bool
any_applied, PrimDarcsOption Reorder
reorder PrimDarcsOption Reorder -> [DarcsFlag] -> Reorder
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts Reorder -> Reorder -> Bool
forall a. Eq a => a -> a -> Bool
== Reorder
O.Reorder) of
        (Bool
True,Bool
True)  -> [DarcsFlag] -> String -> IO ()
putFinished [DarcsFlag]
opts (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"reordering"
        (Bool
False,Bool
True) -> [DarcsFlag] -> String -> IO ()
putFinished [DarcsFlag]
opts (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
presentParticiple String
cmdName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and reordering"
        (Bool, Bool)
_            -> [DarcsFlag] -> String -> IO ()
putFinished [DarcsFlag]
opts (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String
presentParticiple String
cmdName