module Darcs.UI.Commands.Tag ( tag ) where
import Darcs.Prelude
import Control.Monad ( when )
import System.IO ( hPutStr, stderr )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Info ( patchinfo )
import Darcs.Patch.Depends ( getUncovered )
import Darcs.Patch
( PrimPatch, PrimOf
, RepoPatch
)
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia )
import Darcs.Patch.Named ( infopatch, adddeps )
import Darcs.Patch.Set
( emptyPatchSet, appendPSFL, patchSet2FL, patchSetTags )
import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..) )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal )
import Darcs.Repository
( withRepoLock, Repository, RepoJob(..), readRepo
, tentativelyAddPatch, finalizeRepositoryChanges,
)
import Darcs.Repository.Flags ( UpdatePending(..), DryRun(NoDryRun) )
import Darcs.UI.Commands
( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository, putFinished )
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Flags
( DarcsFlag, getDate, compress, verbosity, useCache, umask, getAuthor, author )
import Darcs.UI.Options
( (^), odesc, ocheck, defaultFlags, parseFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.PatchHeader ( getLog )
import Darcs.UI.SelectChanges
( WhichChanges(..)
, selectionConfig
, runSelection
, SelectionConfig(allowSkipAll)
)
import qualified Darcs.UI.SelectChanges as S
import Darcs.Util.Path ( AbsolutePath )
import Darcs.Util.Printer ( Doc, text )
import Darcs.Util.Tree( Tree )
tagDescription :: String
tagDescription :: String
tagDescription = String
"Name the current repository state for future reference."
tagHelp :: Doc
tagHelp :: Doc
tagHelp = String -> Doc
text forall a b. (a -> b) -> a -> b
$
String
"The `darcs tag` command names the current repository state, so that it\n" forall a. [a] -> [a] -> [a]
++
String
"can easily be referred to later. Every *important* state should be\n" forall a. [a] -> [a] -> [a]
++
String
"tagged; in particular it is good practice to tag each stable release\n" forall a. [a] -> [a] -> [a]
++
String
"with a number or codename. Advice on release numbering can be found\n" forall a. [a] -> [a] -> [a]
++
String
"at <http://producingoss.com/en/development-cycle.html>.\n" forall a. [a] -> [a] -> [a]
++
String
"\n" forall a. [a] -> [a] -> [a]
++
String
"To reproduce the state of a repository `R` as at tag `t`, use the\n" forall a. [a] -> [a] -> [a]
++
String
"command `darcs clone --tag t R`. The command `darcs show tags` lists\n" forall a. [a] -> [a] -> [a]
++
String
"all tags in the current repository.\n" forall a. [a] -> [a] -> [a]
++
String
"\n" forall a. [a] -> [a] -> [a]
++
String
"Tagging also provides significant performance benefits: when Darcs\n" forall a. [a] -> [a] -> [a]
++
String
"reaches a shared tag that depends on all antecedent patches, it can\n" forall a. [a] -> [a] -> [a]
++
String
"simply stop processing.\n" forall a. [a] -> [a] -> [a]
++
String
"\n" forall a. [a] -> [a] -> [a]
++
String
"Like normal patches, a tag has a name, an author, a timestamp and an\n" forall a. [a] -> [a] -> [a]
++
String
"optional long description, but it does not change the working tree.\n" forall a. [a] -> [a] -> [a]
++
String
"A tag can have any name, but it is generally best to pick a naming\n" forall a. [a] -> [a] -> [a]
++
String
"scheme and stick to it.\n" forall a. [a] -> [a] -> [a]
++
String
"\n" forall a. [a] -> [a] -> [a]
++
String
"By default a tag names the entire repository state at the time the tag\n" forall a. [a] -> [a] -> [a]
++
String
"is created. If the --ask-deps option is used, the patches to include\n" forall a. [a] -> [a] -> [a]
++
String
"as part of the tag can be explicitly selected.\n" forall a. [a] -> [a] -> [a]
++
String
"\n" forall a. [a] -> [a] -> [a]
++
String
"The `darcs tag` command accepts the `--pipe` option, which behaves as\n" forall a. [a] -> [a] -> [a]
++
String
"described in `darcs record`.\n"
tag :: DarcsCommand
tag :: DarcsCommand
tag = DarcsCommand
{ commandProgramName :: String
commandProgramName = String
"darcs"
, commandName :: String
commandName = String
"tag"
, commandHelp :: Doc
commandHelp = Doc
tagHelp
, commandDescription :: String
commandDescription = String
tagDescription
, commandExtraArgs :: Int
commandExtraArgs = -Int
1
, commandExtraArgHelp :: [String]
commandExtraArgHelp = [String
"[TAGNAME]"]
, commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
tagCmd
, commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInHashedRepository
, commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs
, commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
, commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
OptSpec DarcsOptDescr DarcsFlag a (Compression -> UMask -> a)
tagAdvancedOpts
, commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe String
-> Maybe String
-> Bool
-> Maybe AskLongComment
-> Bool
-> Maybe String
-> a)
tagBasicOpts
, commandDefaults :: [DarcsFlag]
commandDefaults = forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags forall {a}.
DarcsOption
a
(Maybe String
-> Maybe String
-> Bool
-> Maybe AskLongComment
-> Bool
-> Maybe String
-> Maybe StdCmdAction
-> Verbosity
-> Compression
-> UMask
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
tagOpts
, commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck forall {a}.
DarcsOption
a
(Maybe String
-> Maybe String
-> Bool
-> Maybe AskLongComment
-> Bool
-> Maybe String
-> Maybe StdCmdAction
-> Verbosity
-> Compression
-> UMask
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
tagOpts
}
where
tagBasicOpts :: OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe String
-> Maybe String
-> Bool
-> Maybe AskLongComment
-> Bool
-> Maybe String
-> a)
tagBasicOpts
= PrimDarcsOption (Maybe String)
O.patchname
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption (Maybe String)
O.author
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption Bool
O.pipe
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption (Maybe AskLongComment)
O.askLongComment
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption Bool
O.askDeps
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption (Maybe String)
O.repoDir
tagAdvancedOpts :: OptSpec DarcsOptDescr DarcsFlag a (Compression -> UMask -> a)
tagAdvancedOpts = PrimDarcsOption Compression
O.compress forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ PrimDarcsOption UMask
O.umask
tagOpts :: DarcsOption
a
(Maybe String
-> Maybe String
-> Bool
-> Maybe AskLongComment
-> Bool
-> Maybe String
-> Maybe StdCmdAction
-> Verbosity
-> Compression
-> UMask
-> UseCache
-> HooksConfig
-> Bool
-> Bool
-> Bool
-> a)
tagOpts = forall {a}.
OptSpec
DarcsOptDescr
DarcsFlag
a
(Maybe String
-> Maybe String
-> Bool
-> Maybe AskLongComment
-> Bool
-> Maybe String
-> a)
tagBasicOpts forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
(UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` forall {a}.
OptSpec DarcsOptDescr DarcsFlag a (Compression -> UMask -> a)
tagAdvancedOpts
tagCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
tagCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
tagCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
args =
forall a.
DryRun -> UseCache -> UpdatePending -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdatePending
YesUpdatePending (PrimDarcsOption UMask
umask forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) forall a b. (a -> b) -> a -> b
$ 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 a b. (a -> b) -> a -> b
$ \(Repository rt p wR wU wR
repository :: Repository rt p wR wU wR) -> do
String
date <- Bool -> IO String
getDate ([DarcsFlag] -> Bool
hasPipe [DarcsFlag]
opts)
String
the_author <- Maybe String -> Bool -> IO String
getAuthor (PrimDarcsOption (Maybe String)
author forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) ([DarcsFlag] -> Bool
hasPipe [DarcsFlag]
opts)
PatchSet rt p Origin wR
patches <- forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wR
repository
[String]
tags <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
PatchSet rt p wX wY -> [String]
patchSetTags PatchSet rt p Origin wR
patches
Sealed PatchSet rt p Origin wX
chosenPatches <-
if PrimDarcsOption Bool
O.askDeps forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts
then forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal (forall (rt :: RepoType) (p :: * -> * -> *) wStart wX wY.
PatchSet rt p wStart wX
-> FL (PatchInfoAnd rt p) wX wY -> PatchSet rt p wStart wY
appendPSFL forall (rt :: RepoType) (p :: * -> * -> *).
PatchSet rt p Origin Origin
emptyPatchSet) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> FL (PatchInfoAnd rt p) wX wY
-> IO (Sealed (FL (PatchInfoAnd rt p) wX))
askAboutTagDepends [DarcsFlag]
opts (forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX
patchSet2FL PatchSet rt p Origin wR
patches)
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (a :: * -> *) wX. a wX -> Sealed a
Sealed PatchSet rt p Origin wR
patches
let deps :: [PatchInfo]
deps = forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> [PatchInfo]
getUncovered PatchSet rt p Origin wX
chosenPatches
(String
name, [String]
long_comment) <- forall (prim :: * -> * -> *) wA.
PrimPatch prim =>
FL prim wA wA -> [String] -> [String] -> IO (String, [String])
get_name_log (forall (a :: * -> * -> *) wX. FL a wX wX
NilFL :: FL (PrimOf p) wA wA) [String]
args [String]
tags
PatchInfo
myinfo <- String -> String -> String -> [String] -> IO PatchInfo
patchinfo String
date String
name String
the_author [String]
long_comment
let mypatch :: Named p wY wY
mypatch = forall (p :: * -> * -> *) wX wY.
FromPrim p =>
PatchInfo -> FL (PrimOf p) wX wY -> Named p wX wY
infopatch PatchInfo
myinfo forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
Repository rt p wR wU wR
_ <- forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> Compression
-> Verbosity
-> UpdatePending
-> PatchInfoAnd rt p wT wY
-> IO (Repository rt p wR wU wY)
tentativelyAddPatch Repository rt p wR wU wR
repository (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) UpdatePending
YesUpdatePending
forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY (rt :: RepoType).
(Ident p, PatchId p ~ PatchInfo) =>
p wX wY -> PatchInfoAndG rt p wX wY
n2pia forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) wX wY.
Named p wX wY -> [PatchInfo] -> Named p wX wY
adddeps forall {wY}. Named p wY wY
mypatch [PatchInfo]
deps
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 forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
[DarcsFlag] -> String -> IO ()
putFinished [DarcsFlag]
opts forall a b. (a -> b) -> a -> b
$ String
"tagging '"forall a. [a] -> [a] -> [a]
++String
nameforall a. [a] -> [a] -> [a]
++String
"'"
where get_name_log ::(PrimPatch prim) => FL prim wA wA -> [String] -> [String] -> IO (String, [String])
get_name_log :: forall (prim :: * -> * -> *) wA.
PrimPatch prim =>
FL prim wA wA -> [String] -> [String] -> IO (String, [String])
get_name_log FL prim wA wA
nilFL [String]
a [String]
tags
= do (String
name, [String]
comment, Maybe String
_) <- forall (prim :: * -> * -> *) wX wY.
PrimPatch prim =>
Maybe String
-> Bool
-> Logfile
-> Maybe AskLongComment
-> Maybe (String, [String])
-> FL prim wX wY
-> IO (String, [String], Maybe String)
getLog
(case forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption (Maybe String)
O.patchname [DarcsFlag]
opts of
Maybe String
Nothing -> forall a. a -> Maybe a
Just ([String] -> String
unwords [String]
a)
Just String
s -> forall a. a -> Maybe a
Just String
s)
([DarcsFlag] -> Bool
hasPipe [DarcsFlag]
opts)
(forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption Logfile
O.logfile [DarcsFlag]
opts)
(forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption (Maybe AskLongComment)
O.askLongComment [DarcsFlag]
opts)
forall a. Maybe a
Nothing FL prim wA wA
nilFL
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name forall a. Ord a => a -> a -> Bool
< Int
2) forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStr Handle
stderr forall a b. (a -> b) -> a -> b
$
String
"Do you really want to tag '"
forall a. [a] -> [a] -> [a]
++String
nameforall a. [a] -> [a] -> [a]
++String
"'? If not type: darcs obliterate --last=1\n"
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
tags) forall a b. (a -> b) -> a -> b
$
String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"WARNING: The tag " forall a. [a] -> [a] -> [a]
++
String
"\"" forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
"\"" forall a. [a] -> [a] -> [a]
++
String
" already exists."
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"TAG " forall a. [a] -> [a] -> [a]
++ String
name, [String]
comment)
askAboutTagDepends
:: forall rt p wX wY . (RepoPatch p, ApplyState p ~ Tree)
=> [DarcsFlag]
-> FL (PatchInfoAnd rt p) wX wY
-> IO (Sealed (FL (PatchInfoAnd rt p) wX))
askAboutTagDepends :: forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> FL (PatchInfoAnd rt p) wX wY
-> IO (Sealed (FL (PatchInfoAnd rt p) wX))
askAboutTagDepends [DarcsFlag]
flags FL (PatchInfoAnd rt p) wX wY
ps = do
let opts :: PatchSelectionOptions
opts = S.PatchSelectionOptions
{ verbosity :: Verbosity
S.verbosity = PrimDarcsOption Verbosity
verbosity forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
flags
, matchFlags :: [MatchFlag]
S.matchFlags = []
, interactive :: Bool
S.interactive = Bool
True
, selectDeps :: SelectDeps
S.selectDeps = SelectDeps
O.PromptDeps
, withSummary :: WithSummary
S.withSummary = WithSummary
O.NoSummary
, withContext :: WithContext
S.withContext = WithContext
O.NoContext
}
(FL (PatchInfoAnd rt p) wX wZ
deps:>FL (PatchInfoAnd rt p) wZ wY
_) <- forall (p :: * -> * -> *) wX wY.
(MatchableRP p, ShowPatch p, ShowContextPatch p,
ApplyState p ~ Tree, ApplyState p ~ ApplyState (PrimOf p)) =>
FL p wX wY -> SelectionConfig p -> IO ((:>) (FL p) (FL p) wX wY)
runSelection FL (PatchInfoAnd rt p) wX wY
ps forall a b. (a -> b) -> a -> b
$
((forall (p :: * -> * -> *).
Matchable p =>
WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter p)
-> Maybe [AnchoredPath]
-> SelectionConfig p
selectionConfig WhichChanges
FirstReversed String
"depend on" PatchSelectionOptions
opts forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
{ allowSkipAll :: Bool
allowSkipAll = Bool
False })
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL (PatchInfoAnd rt p) wX wZ
deps
hasPipe :: [DarcsFlag] -> Bool
hasPipe :: [DarcsFlag] -> Bool
hasPipe = forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption Bool
O.pipe