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, reorder, allowConflicts
    , wantGuiPause, diffingOpts, setScriptsExecutable, isInteractive
    , xmlOutput, dryRun
    )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.Options ( (?) )
import Darcs.UI.Commands.Util ( testTentativeAndMaybeExit )
import Darcs.Repository
    ( Repository
    , AccessType(..)
    , tentativelyMergePatches
    , finalizeRepositoryChanges
    , applyToWorking
    , setScriptsExecutablePatches
    )
import Darcs.Repository.Pristine ( readPristine )
import Darcs.Repository.Job ( RepoJob(RepoJob) )
import Darcs.Patch ( RepoPatch, 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 )

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

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

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

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

data StandardPatchApplier = StandardPatchApplier

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

standardApplyPatches :: (RepoPatch p, ApplyState p ~ Tree)
                     => String
                     -> [DarcsFlag]
                     -> Repository 'RW p wU wR
                     -> Fork (PatchSet p)
                             (FL (PatchInfoAnd p))
                             (FL (PatchInfoAnd p)) Origin wR wZ
                     -> IO ()
standardApplyPatches :: forall (p :: * -> * -> *) wU wR wZ.
(RepoPatch p, ApplyState p ~ Tree) =>
String
-> [DarcsFlag]
-> Repository 'RW p wU wR
-> Fork
     (PatchSet p)
     (FL (PatchInfoAnd p))
     (FL (PatchInfoAnd p))
     Origin
     wR
     wZ
-> IO ()
standardApplyPatches String
cmdName [DarcsFlag]
opts Repository 'RW p wU wR
repository patches :: Fork
  (PatchSet p)
  (FL (PatchInfoAnd p))
  (FL (PatchInfoAnd p))
  Origin
  wR
  wZ
patches@(Fork PatchSet p Origin wU
_ FL (PatchInfoAnd p) wU wR
_ FL (PatchInfoAnd p) wU wZ
to_be_applied) = do
    !Bool
no_patches <- Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FL (PatchInfoAnd p) wU wZ -> Bool
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL (PatchInfoAnd p) wU wZ
to_be_applied)
    String -> [DarcsFlag] -> FL (PatchInfoAnd p) wU wZ -> IO ()
forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyState p ~ Tree) =>
String -> [DarcsFlag] -> FL (PatchInfoAnd p) wX wY -> IO ()
applyPatchesStart String
cmdName [DarcsFlag]
opts FL (PatchInfoAnd p) wU wZ
to_be_applied
    Sealed FL (PrimOf p) wU wX
pw <- String
-> [DarcsFlag]
-> Repository 'RW p wU wR
-> Fork
     (PatchSet p)
     (FL (PatchInfoAnd p))
     (FL (PatchInfoAnd p))
     Origin
     wR
     wZ
-> IO (Sealed (FL (PrimOf p) wU))
forall (p :: * -> * -> *) wU wR wZ.
(RepoPatch p, ApplyState p ~ Tree) =>
String
-> [DarcsFlag]
-> Repository 'RW p wU wR
-> Fork
     (PatchSet p)
     (FL (PatchInfoAnd p))
     (FL (PatchInfoAnd p))
     Origin
     wR
     wZ
-> IO (Sealed (FL (PrimOf p) wU))
mergeAndTest String
cmdName [DarcsFlag]
opts Repository 'RW p wU wR
repository Fork
  (PatchSet p)
  (FL (PatchInfoAnd p))
  (FL (PatchInfoAnd p))
  Origin
  wR
  wZ
patches
    String
-> [DarcsFlag]
-> Repository 'RW p wU wR
-> FL (PrimOf p) wU wX
-> Bool
-> IO ()
forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
String
-> [DarcsFlag]
-> Repository 'RW p wU wR
-> FL (PrimOf p) wU wY
-> Bool
-> IO ()
applyPatchesFinish String
cmdName [DarcsFlag]
opts Repository 'RW p wU wR
repository FL (PrimOf p) wU wX
pw (Bool -> Bool
not Bool
no_patches)

mergeAndTest :: (RepoPatch p, ApplyState p ~ Tree)
             => String
             -> [DarcsFlag]
             -> Repository 'RW p wU wR
             -> Fork (PatchSet p)
                     (FL (PatchInfoAnd p))
                     (FL (PatchInfoAnd p)) Origin wR wZ
             -> IO (Sealed (FL (PrimOf p) wU))
mergeAndTest :: forall (p :: * -> * -> *) wU wR wZ.
(RepoPatch p, ApplyState p ~ Tree) =>
String
-> [DarcsFlag]
-> Repository 'RW p wU wR
-> Fork
     (PatchSet p)
     (FL (PatchInfoAnd p))
     (FL (PatchInfoAnd p))
     Origin
     wR
     wZ
-> IO (Sealed (FL (PrimOf p) wU))
mergeAndTest String
cmdName [DarcsFlag]
opts Repository 'RW p wU wR
repository Fork
  (PatchSet p)
  (FL (PatchInfoAnd p))
  (FL (PatchInfoAnd p))
  Origin
  wR
  wZ
patches = do
    Sealed (FL (PrimOf p) wU)
pw <- Repository 'RW p wU wR
-> String
-> AllowConflicts
-> WantGuiPause
-> Reorder
-> DiffOpts
-> Fork
     (PatchSet p)
     (FL (PatchInfoAnd p))
     (FL (PatchInfoAnd p))
     Origin
     wR
     wZ
-> IO (Sealed (FL (PrimOf p) wU))
forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR
-> String
-> AllowConflicts
-> WantGuiPause
-> Reorder
-> DiffOpts
-> Fork
     (PatchSet p)
     (FL (PatchInfoAnd p))
     (FL (PatchInfoAnd p))
     Origin
     wR
     wY
-> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches Repository 'RW p wU wR
repository String
cmdName
                         ([DarcsFlag] -> AllowConflicts
allowConflicts [DarcsFlag]
opts)
                         ([DarcsFlag] -> WantGuiPause
wantGuiPause [DarcsFlag]
opts)
                         (PrimOptSpec DarcsOptDescr DarcsFlag a Reorder
PrimDarcsOption Reorder
reorder PrimDarcsOption Reorder -> [DarcsFlag] -> Reorder
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) ([DarcsFlag] -> DiffOpts
diffingOpts [DarcsFlag]
opts)
                         Fork
  (PatchSet p)
  (FL (PatchInfoAnd p))
  (FL (PatchInfoAnd p))
  Origin
  wR
  wZ
patches
    Tree IO
tree <- Repository 'RW p wU wR -> IO (Tree IO)
forall (rt :: AccessType) (p :: * -> * -> *) wU wR.
Repository rt p wU wR -> IO (Tree IO)
readPristine Repository 'RW p wU wR
repository
    Tree IO -> [DarcsFlag] -> String -> String -> Maybe String -> IO ()
testTentativeAndMaybeExit Tree IO
tree [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
    Sealed (FL (PrimOf p) wU) -> IO (Sealed (FL (PrimOf p) wU))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Sealed (FL (PrimOf p) wU)
pw

applyPatchesStart :: (RepoPatch p, ApplyState p ~ Tree)
                  => String -> [DarcsFlag] -> FL (PatchInfoAnd p) wX wY -> IO ()
applyPatchesStart :: forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyState p ~ Tree) =>
String -> [DarcsFlag] -> FL (PatchInfoAnd p) wX wY -> IO ()
applyPatchesStart String
cmdName [DarcsFlag]
opts FL (PatchInfoAnd p) wX wY
to_be_applied = do
    String
-> Verbosity
-> WithSummary
-> DryRun
-> XmlOutput
-> Bool
-> FL (PatchInfoAnd p) wX wY
-> IO ()
forall (p :: * -> * -> *) wX wY.
RepoPatch p =>
String
-> Verbosity
-> WithSummary
-> DryRun
-> XmlOutput
-> Bool
-> FL (PatchInfoAnd p) wX wY
-> IO ()
printDryRunMessageAndExit String
cmdName
        (PrimOptSpec DarcsOptDescr DarcsFlag a Verbosity
PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
        (PrimOptSpec DarcsOptDescr DarcsFlag a WithSummary
PrimDarcsOption WithSummary
O.withSummary PrimDarcsOption WithSummary -> [DarcsFlag] -> WithSummary
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
        (PrimOptSpec DarcsOptDescr DarcsFlag a DryRun
PrimDarcsOption DryRun
dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
        (PrimOptSpec DarcsOptDescr DarcsFlag a XmlOutput
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 p) wX wY
to_be_applied
    if FL (PatchInfoAnd p) wX wY -> Bool
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL (PatchInfoAnd 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 p wW wZ -> Doc)
-> FL (PatchInfoAnd p) wX wY -> [Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL PatchInfoAnd p wW wZ -> Doc
forall wW wZ. PatchInfoAnd p wW wZ -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
description FL (PatchInfoAnd p) wX wY
to_be_applied
        FL (PatchInfoAnd p) wX wY -> IO ()
forall (p :: * -> * -> *) wX wY.
RepoPatch p =>
FL (PatchInfoAnd p) wX wY -> IO ()
setEnvDarcsPatches FL (PatchInfoAnd p) wX wY
to_be_applied

applyPatchesFinish :: (RepoPatch p, ApplyState p ~ Tree)
                   => String
                   -> [DarcsFlag]
                   -> Repository 'RW p wU wR
                   -> FL (PrimOf p) wU wY
                   -> Bool
                   -> IO ()
applyPatchesFinish :: forall (p :: * -> * -> *) wU wR wY.
(RepoPatch p, ApplyState p ~ Tree) =>
String
-> [DarcsFlag]
-> Repository 'RW p wU wR
-> FL (PrimOf p) wU wY
-> Bool
-> IO ()
applyPatchesFinish String
cmdName [DarcsFlag]
opts Repository 'RW p 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 'RO p wU wR
_repository <- Repository 'RW p wU wR -> DryRun -> IO (Repository 'RO p wU wR)
forall (p :: * -> * -> *) wU wR.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository 'RW p wU wR -> DryRun -> IO (Repository 'RO p wU wR)
finalizeRepositoryChanges Repository 'RW p wU wR
_repository (PrimOptSpec DarcsOptDescr DarcsFlag a DryRun
PrimDarcsOption DryRun
O.dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
        IO (Repository 'RO p wY wR) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Repository 'RO p wY wR) -> IO ())
-> IO (Repository 'RO p wY wR) -> IO ()
forall a b. (a -> b) -> a -> b
$ Repository 'RO p wU wR
-> Verbosity -> FL (PrimOf p) wU wY -> IO (Repository 'RO p wY wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wU wR
-> Verbosity -> FL (PrimOf p) wU wY -> IO (Repository rt p wY wR)
applyToWorking Repository 'RO p wU wR
_repository (PrimOptSpec DarcsOptDescr DarcsFlag a Verbosity
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 (PrimOptSpec DarcsOptDescr DarcsFlag a SetScriptsExecutable
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
    case (Bool
any_applied, PrimOptSpec DarcsOptDescr DarcsFlag a Reorder
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