--  Copyright (C) 2003-2004 David Roundy
--
--  This program is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2, or (at your option)
--  any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program; see the file COPYING.  If not, write to
--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
--  Boston, MA 02110-1301, USA.

module Darcs.UI.Commands.Tag ( tag ) where

import Prelude ()
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
    , IsRepoType, RepoPatch
    )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully )
import Darcs.Patch.Named.Wrapped
    ( infopatch, adddeps, runInternalChecker, namedInternalChecker )
import Darcs.Patch.Set
    ( PatchSet(..), emptyPatchSet, appendPSFL, patchSet2FL )
import Darcs.Patch.Witnesses.Ordered ( FL(..), filterOutRLRL, (:>)(..) )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal )

import Darcs.Repository
    ( withRepoLock, Repository, RepoJob(..), readRepo
    , tentativelyAddPatch, finalizeRepositoryChanges,
    )
import Darcs.Repository.Flags ( UpdateWorking(..), DryRun(NoDryRun) )

import Darcs.UI.Commands
    ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )
import Darcs.UI.Commands.Util ( repoTags )
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Flags
    ( DarcsFlag, getDate, compress, verbosity, useCache, umask, getAuthor, author )
import Darcs.UI.Options
    ( (^), odesc, ocheck, onormalise, defaultFlags, parseFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.PatchHeader ( getLog )
import Darcs.UI.SelectChanges
    ( WhichChanges(..)
    , selectionContext
    , runSelection
    , PatchSelectionContext(allowSkipAll)
    )
import qualified Darcs.UI.SelectChanges as S

import Darcs.Util.Path ( AbsolutePath )
import Darcs.Util.Tree( Tree )


tagDescription :: String
tagDescription :: String
tagDescription = "Name the current repository state for future reference."

tagHelp :: String
tagHelp :: String
tagHelp =
 "The `darcs tag` command names the current repository state, so that it\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "can easily be referred to later.  Every *important* state should be\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "tagged; in particular it is good practice to tag each stable release\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "with a number or codename.  Advice on release numbering can be found\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "at <http://producingoss.com/en/development-cycle.html>.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "To reproduce the state of a repository `R` as at tag `t`, use the\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "command `darcs clone --tag t R`.  The command `darcs show tags` lists\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "all tags in the current repository.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "Tagging also provides significant performance benefits: when Darcs\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "reaches a shared tag that depends on all antecedent patches, it can\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "simply stop processing.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "Like normal patches, a tag has a name, an author, a timestamp and an\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "optional long description, but it does not change the working tree.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "A tag can have any name, but it is generally best to pick a naming\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "scheme and stick to it.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "By default a tag names the entire repository state at the time the tag\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "is created. If the --ask-deps option is used, the patches to include\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "as part of the tag can be explicitly selected.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "The `darcs tag` command accepts the `--pipe` option, which behaves as\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 "described in `darcs record`.\n"

tag :: DarcsCommand [DarcsFlag]
tag :: DarcsCommand [DarcsFlag]
tag = DarcsCommand :: forall parsedFlags.
String
-> String
-> String
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> parsedFlags -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> ([DarcsFlag] -> parsedFlags)
-> DarcsCommand parsedFlags
DarcsCommand
    { commandProgramName :: String
commandProgramName = "darcs"
    , commandName :: String
commandName = "tag"
    , commandHelp :: String
commandHelp = String
tagHelp
    , commandDescription :: String
commandDescription = String
tagDescription
    , commandExtraArgs :: Int
commandExtraArgs = -1
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = ["[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 = OptSpec DarcsOptDescr DarcsFlag Any (Compression -> UMask -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (Compression -> UMask -> Any)
forall a.
OptSpec DarcsOptDescr DarcsFlag a (Compression -> UMask -> a)
tagAdvancedOpts
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> Any)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> a)
tagBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> Compression
   -> UMask
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> Compression
   -> UMask
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> Compression
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
tagOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> Compression
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> Compression
   -> UMask
   -> UseCache
   -> HooksConfig
   -> Any)
forall a.
DarcsOption
  a
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> Compression
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
tagOpts
    , commandParseOptions :: [DarcsFlag] -> [DarcsFlag]
commandParseOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> Compression
   -> UMask
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
-> [DarcsFlag] -> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f] -> [f]
onormalise OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> Compression
   -> UMask
   -> UseCache
   -> HooksConfig
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> Compression
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
tagOpts
    }
  where
    tagBasicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> a)
tagBasicOpts
      = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String
   -> Bool -> Maybe AskLongComment -> Bool -> Maybe String -> a)
  (Maybe String)
PrimDarcsOption (Maybe String)
O.patchname
      PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String
   -> Bool -> Maybe AskLongComment -> Bool -> Maybe String -> a)
  (Maybe String)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Bool -> Maybe AskLongComment -> Bool -> Maybe String -> a)
     (Maybe String
      -> Bool -> Maybe AskLongComment -> Bool -> Maybe String -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Bool -> Maybe AskLongComment -> Bool -> Maybe String -> a)
     (Maybe String
      -> Maybe String
      -> Bool
      -> Maybe AskLongComment
      -> Bool
      -> Maybe String
      -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (Bool -> Maybe AskLongComment -> Bool -> Maybe String -> a)
  (Maybe String
   -> Bool -> Maybe AskLongComment -> Bool -> Maybe String -> a)
PrimDarcsOption (Maybe String)
O.author
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (Bool -> Maybe AskLongComment -> Bool -> Maybe String -> a)
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe AskLongComment -> Bool -> Maybe String -> a)
     (Bool -> Maybe AskLongComment -> Bool -> Maybe String -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe AskLongComment -> Bool -> Maybe String -> a)
     (Maybe String
      -> Maybe String
      -> Bool
      -> Maybe AskLongComment
      -> Bool
      -> Maybe String
      -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe AskLongComment -> Bool -> Maybe String -> a)
  (Bool -> Maybe AskLongComment -> Bool -> Maybe String -> a)
PrimDarcsOption Bool
O.pipe
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe AskLongComment -> Bool -> Maybe String -> a)
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Bool -> Maybe String -> a)
     (Maybe AskLongComment -> Bool -> Maybe String -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Bool -> Maybe String -> a)
     (Maybe String
      -> Maybe String
      -> Bool
      -> Maybe AskLongComment
      -> Bool
      -> Maybe String
      -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (Bool -> Maybe String -> a)
  (Maybe AskLongComment -> Bool -> Maybe String -> a)
PrimDarcsOption (Maybe AskLongComment)
O.askLongComment
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (Bool -> Maybe String -> a)
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe String -> a)
     (Bool -> Maybe String -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe String -> a)
     (Maybe String
      -> Maybe String
      -> Bool
      -> Maybe AskLongComment
      -> Bool
      -> Maybe String
      -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> a)
  (Bool -> Maybe String -> a)
PrimDarcsOption Bool
O.askDeps
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> a)
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (Maybe String
      -> Maybe String
      -> Bool
      -> Maybe AskLongComment
      -> Bool
      -> Maybe String
      -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (Maybe String -> a)
PrimDarcsOption (Maybe String)
O.repoDir
    tagAdvancedOpts :: OptSpec DarcsOptDescr DarcsFlag a (Compression -> UMask -> a)
tagAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag (UMask -> a) Compression
PrimDarcsOption Compression
O.compress PrimOptSpec DarcsOptDescr DarcsFlag (UMask -> a) Compression
-> OptSpec DarcsOptDescr DarcsFlag a (UMask -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (Compression -> UMask -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (UMask -> a)
PrimDarcsOption UMask
O.umask
    tagOpts :: DarcsOption
  a
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> Compression
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
tagOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> Compression
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> Compression
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
forall a.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> a)
tagBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> Compression
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Bool
   -> Bool
   -> Verbosity
   -> Bool
   -> Compression
   -> UMask
   -> UseCache
   -> HooksConfig
   -> a)
-> DarcsOption
     (UseCache -> HooksConfig -> a)
     (Compression -> UMask -> UseCache -> HooksConfig -> a)
-> DarcsOption
     a
     (Maybe String
      -> Maybe String
      -> Bool
      -> Maybe AskLongComment
      -> Bool
      -> Maybe String
      -> Maybe StdCmdAction
      -> Bool
      -> Bool
      -> Verbosity
      -> Bool
      -> Compression
      -> UMask
      -> UseCache
      -> HooksConfig
      -> a)
forall b c a.
DarcsOption
  (Maybe StdCmdAction -> Bool -> Bool -> Verbosity -> Bool -> b) c
-> DarcsOption (UseCache -> HooksConfig -> a) b -> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> a)
  (Compression -> UMask -> UseCache -> HooksConfig -> a)
forall a.
OptSpec DarcsOptDescr DarcsFlag a (Compression -> UMask -> a)
tagAdvancedOpts

filterNonInternal :: IsRepoType rt => PatchSet rt p wX wY -> PatchSet rt p wX wY
filterNonInternal :: PatchSet rt p wX wY -> PatchSet rt p wX wY
filterNonInternal =
  case Maybe (InternalChecker (WrappedNamed rt p))
forall (rt :: RepoType) (p :: * -> * -> *).
IsRepoType rt =>
Maybe (InternalChecker (WrappedNamed rt p))
namedInternalChecker of
    Nothing -> PatchSet rt p wX wY -> PatchSet rt p wX wY
forall a. a -> a
id
    Just f :: InternalChecker (WrappedNamed rt p)
f -> \(PatchSet ts :: RL (Tagged rt p) wX wX
ts ps :: RL (PatchInfoAnd rt p) wX wY
ps) -> RL (Tagged rt p) wX wX
-> RL (PatchInfoAnd rt p) wX wY -> PatchSet rt p wX wY
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX wY.
RL (Tagged rt p) wStart wX
-> RL (PatchInfoAnd rt p) wX wY -> PatchSet rt p wStart wY
PatchSet RL (Tagged rt p) wX wX
ts ((forall wX wY. PatchInfoAnd rt p wX wY -> EqCheck wX wY)
-> RL (PatchInfoAnd rt p) wX wY -> RL (PatchInfoAnd rt p) wX wY
forall (p :: * -> * -> *) wW wZ.
(forall wX wY. p wX wY -> EqCheck wX wY)
-> RL p wW wZ -> RL p wW wZ
filterOutRLRL (InternalChecker (WrappedNamed rt p)
-> forall wX wY. WrappedNamed rt p wX wY -> EqCheck wX wY
forall (p :: * -> * -> *).
InternalChecker p -> forall wX wY. p wX wY -> EqCheck wX wY
runInternalChecker InternalChecker (WrappedNamed rt p)
f (WrappedNamed rt p wX wY -> EqCheck wX wY)
-> (PatchInfoAnd rt p wX wY -> WrappedNamed rt p wX wY)
-> PatchInfoAnd rt p wX wY
-> EqCheck wX wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd rt p wX wY -> WrappedNamed rt p wX wY
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> WrappedNamed rt p wA wB
hopefully) RL (PatchInfoAnd rt p) wX wY
ps)

tagCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
tagCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
tagCmd _ opts :: [DarcsFlag]
opts args :: [String]
args =
  DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob () -> IO ()
forall a.
DryRun -> UseCache -> UpdateWorking -> UMask -> RepoJob a -> IO a
withRepoLock DryRun
NoDryRun (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) UpdateWorking
YesUpdateWorking (PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$ (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 ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
  (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
  Repository rt p wR wU wR -> IO ())
 -> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
    (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
    Repository rt p wR wU wR -> IO ())
-> 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 PrimDarcsOption (Maybe String) -> [DarcsFlag] -> Maybe String
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 <- Repository rt p wR wU wR -> IO (PatchSet rt p Origin wR)
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 <- PatchSet rt p Origin wR -> IO [String]
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
PatchSet rt p wX wY -> IO [String]
repoTags PatchSet rt p Origin wR
patches
    let nonInternalPatches :: PatchSet rt p Origin wR
nonInternalPatches = PatchSet rt p Origin wR -> PatchSet rt p Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
IsRepoType rt =>
PatchSet rt p wX wY -> PatchSet rt p wX wY
filterNonInternal PatchSet rt p Origin wR
patches
    Sealed chosenPatches :: PatchSet rt p Origin wX
chosenPatches <-
        if PrimDarcsOption Bool
O.askDeps PrimDarcsOption Bool -> [DarcsFlag] -> Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts
            then (forall wX.
 FL (PatchInfoAnd rt p) Origin wX -> PatchSet rt p Origin wX)
-> Sealed (FL (PatchInfoAnd rt p) Origin)
-> Sealed (PatchSet rt p Origin)
forall (a :: * -> *) (b :: * -> *).
(forall wX. a wX -> b wX) -> Sealed a -> Sealed b
mapSeal (PatchSet rt p Origin Origin
-> FL (PatchInfoAnd rt p) Origin wX -> PatchSet rt p Origin wX
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX wY.
PatchSet rt p wStart wX
-> FL (PatchInfoAnd rt p) wX wY -> PatchSet rt p wStart wY
appendPSFL PatchSet rt p Origin Origin
forall (rt :: RepoType) (p :: * -> * -> *) wX. PatchSet rt p wX wX
emptyPatchSet) (Sealed (FL (PatchInfoAnd rt p) Origin)
 -> Sealed (PatchSet rt p Origin))
-> IO (Sealed (FL (PatchInfoAnd rt p) Origin))
-> IO (Sealed (PatchSet rt p Origin))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DarcsFlag]
-> FL (PatchInfoAnd rt p) Origin wR
-> IO (Sealed (FL (PatchInfoAnd rt p) Origin))
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> FL (PatchInfoAnd rt p) wX wY
-> IO (Sealed (FL (PatchInfoAnd rt p) wX))
askAboutTagDepends [DarcsFlag]
opts (PatchSet rt p Origin wR -> FL (PatchInfoAnd rt p) Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> FL (PatchInfoAnd rt p) wStart wX
patchSet2FL PatchSet rt p Origin wR
nonInternalPatches)
            else Sealed (PatchSet rt p Origin) -> IO (Sealed (PatchSet rt p Origin))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (PatchSet rt p Origin)
 -> IO (Sealed (PatchSet rt p Origin)))
-> Sealed (PatchSet rt p Origin)
-> IO (Sealed (PatchSet rt p Origin))
forall a b. (a -> b) -> a -> b
$ PatchSet rt p Origin wR -> Sealed (PatchSet rt p Origin)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed PatchSet rt p Origin wR
nonInternalPatches
    let deps :: [PatchInfo]
deps = PatchSet rt p Origin wX -> [PatchInfo]
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> [PatchInfo]
getUncovered PatchSet rt p Origin wX
chosenPatches
    (name :: String
name, long_comment :: [String]
long_comment)  <- FL (PrimOf p) Any Any
-> [String] -> [String] -> IO (String, [String])
forall (prim :: * -> * -> *) wA.
PrimPatch prim =>
FL prim wA wA -> [String] -> [String] -> IO (String, [String])
get_name_log (forall wA. FL (PrimOf p) wA wA
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 :: WrappedNamed rt p wY wY
mypatch = PatchInfo -> FL p wY wY -> WrappedNamed rt p wY wY
forall (p :: * -> * -> *) wX wY (rt :: RepoType).
PatchInfo -> FL p wX wY -> WrappedNamed rt p wX wY
infopatch PatchInfo
myinfo FL p wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
    Repository rt p wR wU wR
_ <- Repository rt p wR wU wR
-> Compression
-> Verbosity
-> UpdateWorking
-> PatchInfoAnd rt p wR wR
-> IO (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
-> UpdateWorking
-> PatchInfoAnd rt p wT wY
-> IO (Repository rt p wR wU wY)
tentativelyAddPatch Repository rt p wR wU wR
repository (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) UpdateWorking
YesUpdateWorking
             (PatchInfoAnd rt p wR wR -> IO (Repository rt p wR wU wR))
-> PatchInfoAnd rt p wR wR -> IO (Repository rt p wR wU wR)
forall a b. (a -> b) -> a -> b
$ WrappedNamed rt p wR wR -> PatchInfoAnd rt p wR wR
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
WrappedNamed rt p wX wY -> PatchInfoAnd rt p wX wY
n2pia (WrappedNamed rt p wR wR -> PatchInfoAnd rt p wR wR)
-> WrappedNamed rt p wR wR -> PatchInfoAnd rt p wR wR
forall a b. (a -> b) -> a -> b
$ WrappedNamed rt p wR wR -> [PatchInfo] -> WrappedNamed rt p wR wR
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
WrappedNamed rt p wX wY -> [PatchInfo] -> WrappedNamed rt p wX wY
adddeps WrappedNamed rt p wR wR
forall (rt :: RepoType) (p :: * -> * -> *) wY.
WrappedNamed rt p wY wY
mypatch [PatchInfo]
deps
    Repository rt p wR wU wR -> UpdateWorking -> Compression -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> UpdateWorking -> Compression -> IO ()
finalizeRepositoryChanges Repository rt p wR wU wR
repository UpdateWorking
YesUpdateWorking (PrimDarcsOption Compression
compress PrimDarcsOption Compression -> [DarcsFlag] -> Compression
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "Finished tagging patch '"String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++"'"
  where  get_name_log ::(PrimPatch prim) => FL prim wA wA -> [String] -> [String] -> IO (String, [String])
         get_name_log :: FL prim wA wA -> [String] -> [String] -> IO (String, [String])
get_name_log nilFL :: FL prim wA wA
nilFL a :: [String]
a tags :: [String]
tags
                          = do (name :: String
name, comment :: [String]
comment, _) <- Maybe String
-> Bool
-> Logfile
-> Maybe AskLongComment
-> Maybe (String, [String])
-> FL prim wA wA
-> IO (String, [String], 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 PrimDarcsOption (Maybe String) -> [DarcsFlag] -> Maybe String
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption (Maybe String)
O.patchname [DarcsFlag]
opts of
                                    Nothing -> String -> Maybe String
forall a. a -> Maybe a
Just ([String] -> String
unwords [String]
a)
                                    Just s :: String
s -> String -> Maybe String
forall a. a -> Maybe a
Just String
s)
                                  ([DarcsFlag] -> Bool
hasPipe [DarcsFlag]
opts)
                                  ((forall a. PrimOptSpec DarcsOptDescr DarcsFlag a Logfile)
-> [DarcsFlag] -> Logfile
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags forall a. PrimOptSpec DarcsOptDescr DarcsFlag a Logfile
O.logfile [DarcsFlag]
opts)
                                  (PrimDarcsOption (Maybe AskLongComment)
-> [DarcsFlag] -> Maybe AskLongComment
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption (Maybe AskLongComment)
O.askLongComment [DarcsFlag]
opts)
                                  Maybe (String, [String])
forall a. Maybe a
Nothing FL prim wA wA
nilFL
                               Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStr Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                                 "Do you really want to tag '"
                                 String -> String -> String
forall a. [a] -> [a] -> [a]
++String
nameString -> String -> String
forall a. [a] -> [a] -> [a]
++"'? If not type: darcs obliterate --last=1\n"
                               Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String
name String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
tags) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                                  String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "WARNING: The tag "  String -> String -> String
forall a. [a] -> [a] -> [a]
++ 
                                             "\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                                             " already exists."
                               (String, [String]) -> IO (String, [String])
forall (m :: * -> *) a. Monad m => a -> m a
return ("TAG " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name, [String]
comment)

-- This may be useful for developers, but users don't care about
-- internals:
--
-- A tagged version automatically depends on all patches in the
-- repository.  This allows you to later reproduce precisely that
-- version.  The tag does this by depending on all patches in the
-- repository, except for those which are depended upon by other tags
-- already in the repository.  In the common case of a sequential
-- series of tags, this means that the tag depends on all patches
-- since the last tag, plus that tag itself.

askAboutTagDepends
     :: forall rt p wX wY . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
     => [DarcsFlag]
     -> FL (PatchInfoAnd rt p) wX wY
     -> IO (Sealed (FL (PatchInfoAnd rt p) wX))
askAboutTagDepends :: [DarcsFlag]
-> FL (PatchInfoAnd rt p) wX wY
-> IO (Sealed (FL (PatchInfoAnd rt p) wX))
askAboutTagDepends flags :: [DarcsFlag]
flags ps :: FL (PatchInfoAnd rt p) wX wY
ps = do
  let opts :: PatchSelectionOptions
opts = PatchSelectionOptions :: Verbosity
-> [MatchFlag]
-> Bool
-> SelectDeps
-> Summary
-> WithContext
-> PatchSelectionOptions
S.PatchSelectionOptions
             { verbosity :: Verbosity
S.verbosity = PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> 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
             , summary :: Summary
S.summary = Summary
O.NoSummary
             , withContext :: WithContext
S.withContext = WithContext
O.NoContext
             }
  (deps :: FL (PatchInfoAnd rt p) wX wZ
deps:>_) <- FL (PatchInfoAnd rt p) wX wY
-> PatchSelectionContext (PatchInfoAnd rt p)
-> IO
     ((:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wX wY)
forall (p :: * -> * -> *) wX wY.
(Invert p, Commute p, Apply p, PatchInspect p, ShowPatch p,
 ShowContextPatch p, ApplyState p ~ Tree) =>
FL p wX wY
-> PatchSelectionContext p -> IO ((:>) (FL p) (FL p) wX wY)
runSelection FL (PatchInfoAnd rt p) wX wY
ps (PatchSelectionContext (PatchInfoAnd rt p)
 -> IO
      ((:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wX wY))
-> PatchSelectionContext (PatchInfoAnd rt p)
-> IO
     ((:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wX wY)
forall a b. (a -> b) -> a -> b
$
                     ((WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter (PatchInfoAnd rt p))
-> Maybe [String]
-> PatchSelectionContext (PatchInfoAnd rt p)
forall (rt :: RepoType) (p :: * -> * -> *).
(IsRepoType rt, RepoPatch p) =>
WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter (PatchInfoAnd rt p))
-> Maybe [String]
-> PatchSelectionContext (PatchInfoAnd rt p)
selectionContext WhichChanges
FirstReversed "depend on" PatchSelectionOptions
opts Maybe (Splitter (PatchInfoAnd rt p))
forall a. Maybe a
Nothing Maybe [String]
forall a. Maybe a
Nothing)
                          { allowSkipAll :: Bool
allowSkipAll = Bool
False })
  Sealed (FL (PatchInfoAnd rt p) wX)
-> IO (Sealed (FL (PatchInfoAnd rt p) wX))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (FL (PatchInfoAnd rt p) wX)
 -> IO (Sealed (FL (PatchInfoAnd rt p) wX)))
-> Sealed (FL (PatchInfoAnd rt p) wX)
-> IO (Sealed (FL (PatchInfoAnd rt p) wX))
forall a b. (a -> b) -> a -> b
$ FL (PatchInfoAnd rt p) wX wZ -> Sealed (FL (PatchInfoAnd rt p) wX)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL (PatchInfoAnd rt p) wX wZ
deps

hasPipe :: [DarcsFlag] -> Bool
hasPipe :: [DarcsFlag] -> Bool
hasPipe = PrimDarcsOption Bool -> [DarcsFlag] -> Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimDarcsOption Bool
O.pipe