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
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 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 (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 (p :: * -> * -> *). PatchProxy p
PatchProxy)
applyPatches :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU wZ.
(ApplierRepoTypeConstraint StandardPatchApplier rt, IsRepoType rt,
RepoPatch p, ApplyState p ~ Tree) =>
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 = 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 :: 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 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
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 <- 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 forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) ([DarcsFlag] -> WantGuiPause
wantGuiPause [DarcsFlag]
opts)
(PrimDarcsOption Compression
compress forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimDarcsOption Verbosity
verbosity forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
(PrimDarcsOption Reorder
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
forall t. t -> IO ()
invalidateIndex Repository rt p wR wU wR
_repository
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 forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
(PrimDarcsOption TestChanges
testChanges forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
(PrimDarcsOption SetScriptsExecutable
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 forall a. [a] -> [a] -> [a]
++ String
" them") forall a. Maybe a
Nothing
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 (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 :: 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) wX wY
to_be_applied = do
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 forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
(PrimDarcsOption WithSummary
O.withSummary forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
(PrimDarcsOption DryRun
dryRun forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
(PrimDarcsOption XmlOutput
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 forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL (PatchInfoAnd rt p) wX wY
to_be_applied then
String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"You don't want to " forall a. [a] -> [a] -> [a]
++ String
cmdName forall a. [a] -> [a] -> [a]
++ String
" any patches, and that's fine with me!"
else do
[DarcsFlag] -> Doc -> IO ()
putVerbose [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ String -> Doc
text forall a b. (a -> b) -> a -> b
$ String
"Will " forall a. [a] -> [a] -> [a]
++ String
cmdName forall a. [a] -> [a] -> [a]
++ String
" the following patches:"
[DarcsFlag] -> Doc -> IO ()
putVerbose [DarcsFlag]
opts forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
vcat forall a b. (a -> b) -> a -> b
$ forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
description FL (PatchInfoAnd rt p) wX wY
to_be_applied
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 :: 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 wY
pw Bool
any_applied = do
forall a. IO a -> IO a
withSignalsBlocked forall a b. (a -> b) -> a -> b
$ do
Repository rt p wR wU wR
_repository <-
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 forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ 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 forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) FL (PrimOf p) wU wY
pw
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PrimDarcsOption SetScriptsExecutable
setScriptsExecutable forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts forall a. Eq a => a -> a -> Bool
== SetScriptsExecutable
O.YesSetScriptsExecutable) forall a b. (a -> b) -> a -> b
$
forall (p :: * -> * -> *) wX wY. PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches FL (PrimOf p) wU wY
pw
forall (m :: * -> *) a. Monad m => a -> m a
return ()
case (Bool
any_applied, PrimDarcsOption Reorder
reorder forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts forall a. Eq a => a -> a -> Bool
== Reorder
O.Reorder) of
(Bool
True,Bool
True) -> [DarcsFlag] -> String -> IO ()
putFinished [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ String
"reordering"
(Bool
False,Bool
True) -> [DarcsFlag] -> String -> IO ()
putFinished [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ String -> String
presentParticiple String
cmdName forall a. [a] -> [a] -> [a]
++ String
" and reordering"
(Bool, Bool)
_ -> [DarcsFlag] -> String -> IO ()
putFinished [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ String -> String
presentParticiple String
cmdName