--  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 Darcs.Prelude

import Control.Monad ( when )
import System.IO ( hPutStr, stderr )

import Darcs.Patch ( RepoPatch )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Depends ( getUncovered )
import Darcs.Patch.Info ( patchinfo )
import Darcs.Patch.Named ( adddeps, infopatch )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia )
import Darcs.Patch.Set ( appendPSFL, emptyPatchSet, patchSet2FL, patchSetTags )
import Darcs.Patch.Witnesses.Ordered ( (:>)(..), FL(..) )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal )

import Darcs.Repository
    ( AccessType(..)
    , RepoJob(..)
    , Repository
    , finalizeRepositoryChanges
    , readPatches
    , tentativelyAddPatch
    , withRepoLock
    )
import Darcs.Repository.Flags ( UpdatePending(..) )

import Darcs.UI.Commands
    ( DarcsCommand(..)
    , amInHashedRepository
    , nodefaults
    , putFinished
    , withStdOpts
    )
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.Flags
    ( DarcsFlag
    , author
    , getAuthor
    , getDate
    , umask
    , useCache
    , verbosity
    )
import Darcs.UI.Options ( (?), (^) )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.PatchHeader ( getLog )
import Darcs.UI.SelectChanges
    ( SelectionConfig(allowSkipAll)
    , WhichChanges(..)
    , runSelection
    , selectionConfig
    )
import qualified Darcs.UI.SelectChanges as S

import Darcs.Util.Path ( AbsolutePath )
import Darcs.Util.Printer ( Doc, formatWords, vsep )
import Darcs.Util.Tree ( Tree )


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

tagHelp :: Doc
tagHelp :: Doc
tagHelp =
  [Doc] -> Doc
vsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ([String] -> Doc) -> [[String]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> Doc
formatWords
  [ [ String
"The `darcs tag` command names the current repository state, so that it"
    , String
"can easily be referred to later. It does so by recording a special kind"
    , String
"of patch that makes no changes and which explicitly depends on all"
    , String
"patches currently existing in the repository (except for those which"
    , String
"are depended upon by other tags already in the repository). In the"
    , String
"common case of a sequential series of tags, this means that the tag"
    , String
"depends on all patches since the last tag, plus that tag itself."
    ]
  , [ String
"Every *important* state should be"
    , String
"tagged; in particular it is good practice to tag each stable release"
    , String
"with a number or codename.  Advice on release numbering can be found"
    , String
"at <http://producingoss.com/en/development-cycle.html>."
    ]
  , [ String
"To reproduce the state of a repository `R` as at tag `t`, use the"
    , String
"command `darcs clone --tag t R`. Note however that tags are matched"
    , String
"as regular expressions, like with `--patch`. To make sure you get the"
    , String
"right tag it may be better to use `darcs clone --tag '^t$'`."
    , String
"The command `darcs show tags` lists all tags in the current repository."
    ]
  , [ String
"Tagging also provides significant performance benefits: when Darcs"
    , String
"reaches a tag that depends on all preceding patches, it can often"
    , String
"stop processing. A tag in such a position is called \"clean\". For"
    , String
"instance, operations like push and pull need to examine only patches"
    , String
"that come after the latest shared clean tag."
    ]
  , [ String
"Like normal patches, a tag has a name, an author, a timestamp and an"
    , String
"optional long description, but it does not change the working tree."
    , String
"A tag can have any name, but it is generally best to pick a naming"
    , String
"scheme and stick to it."
    ]
  , [ String
"By default a tag names the entire repository state at the time the tag"
    , String
"is created. If the --ask-deps option is used, the patches to include"
    , String
"as part of the tag can be explicitly selected."
    ]
  , [ String
"The `darcs tag` command accepts the `--pipe` option, which behaves as"
    , String
"described in `darcs record`."
    ]
  ]

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
    , commandOptions :: CommandOptions
commandOptions = CommandOptions
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 :: PrimOptSpec DarcsOptDescr DarcsFlag a UMask
tagAdvancedOpts = PrimOptSpec DarcsOptDescr DarcsFlag a UMask
PrimDarcsOption UMask
O.umask
    tagOpts :: CommandOptions
tagOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> a)
tagBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe String
   -> Maybe String
   -> Bool
   -> Maybe AskLongComment
   -> Bool
   -> Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     (UMask
      -> UseCache
      -> UseIndex
      -> HooksConfig
      -> Bool
      -> Bool
      -> [DarcsFlag])
-> CommandOptions
forall b c.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     b
-> CommandOptions
`withStdOpts` DarcsOption
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (UMask
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
PrimDarcsOption UMask
tagAdvancedOpts

tagCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
tagCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
tagCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
opts [String]
args =
  UseCache -> UMask -> RepoJob 'RW () -> IO ()
forall a. UseCache -> UMask -> RepoJob 'RW a -> IO a
withRepoLock (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob 'RW () -> IO ()) -> RepoJob 'RW () -> IO ()
forall a b. (a -> b) -> a -> b
$ TreePatchJob 'RW () -> RepoJob 'RW ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RW () -> RepoJob 'RW ())
-> TreePatchJob 'RW () -> RepoJob 'RW ()
forall a b. (a -> b) -> a -> b
$ \(Repository 'RW p wU wR
repository :: Repository 'RW p wU wR) -> do
    date <- Bool -> IO String
getDate Bool
hasPipe
    the_author <- getAuthor (author ? opts) hasPipe
    patches <- readPatches repository
    tags <- return $ patchSetTags patches
    Sealed chosenPatches <-
        if O.askDeps ? opts
            then mapSeal (appendPSFL emptyPatchSet) <$> askAboutTagDepends opts (patchSet2FL patches)
            else return $ Sealed patches
    let deps = PatchSet p Origin wX -> [PatchInfo]
forall (p :: * -> * -> *) wStart wX.
PatchSet p wStart wX -> [PatchInfo]
getUncovered PatchSet p Origin wX
chosenPatches
    (name, long_comment)  <- get_name_log tags
    myinfo <- patchinfo date name the_author long_comment
    let mypatch = PatchInfo -> FL (PrimOf p) wY wY -> Named p wY wY
forall (p :: * -> * -> *) wX wY.
FromPrim p =>
PatchInfo -> FL (PrimOf p) wX wY -> Named p wX wY
infopatch PatchInfo
myinfo FL (PrimOf p) wY wY
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL
    _ <- tentativelyAddPatch repository YesUpdatePending
             $ n2pia $ adddeps mypatch deps
    _ <- finalizeRepositoryChanges repository (O.dryRun ? opts)
    putFinished opts $ "tagging '"++name++"'"
  where
    get_name_log :: [String] -> IO (String, [String])
    get_name_log :: [String] -> IO (String, [String])
get_name_log [String]
tags = do
      (name, comment, _) <-
        Maybe String
-> Bool
-> Logfile
-> Maybe AskLongComment
-> Maybe (String, [String])
-> Doc
-> IO (String, [String], Maybe String)
getLog
          (case PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe String)
PrimDarcsOption (Maybe String)
O.patchname PrimDarcsOption (Maybe String) -> [DarcsFlag] -> Maybe String
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts of
             Maybe String
Nothing
                | [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
args -> Maybe String
forall a. Maybe a
Nothing
                | Bool
otherwise -> String -> Maybe String
forall a. a -> Maybe a
Just ([String] -> String
unwords [String]
args)
             Just String
s -> String -> Maybe String
forall a. a -> Maybe a
Just String
s)
          Bool
hasPipe (PrimOptSpec DarcsOptDescr DarcsFlag a Logfile
PrimDarcsOption Logfile
O.logfile PrimDarcsOption Logfile -> [DarcsFlag] -> Logfile
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe AskLongComment)
PrimDarcsOption (Maybe AskLongComment)
O.askLongComment PrimDarcsOption (Maybe AskLongComment)
-> [DarcsFlag] -> Maybe AskLongComment
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) Maybe (String, [String])
forall a. Maybe a
Nothing Doc
forall a. Monoid a => a
mempty
      when (length name < 2) $
        hPutStr stderr $
        "Do you really want to tag '" ++
        name ++ "'? If not type: darcs obliterate --last=1\n"
      when (name `elem` tags) $
        putStrLn $ "WARNING: The tag " ++ "\"" ++ name ++ "\"" ++ " already exists."
      return ("TAG " ++ name, comment)
    hasPipe :: Bool
hasPipe = PrimOptSpec DarcsOptDescr DarcsFlag a Bool
PrimDarcsOption Bool
O.pipe PrimDarcsOption Bool -> [DarcsFlag] -> Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts

askAboutTagDepends
     :: forall p wX wY . (RepoPatch p, ApplyState p ~ Tree)
     => [DarcsFlag]
     -> FL (PatchInfoAnd p) wX wY
     -> IO (Sealed (FL (PatchInfoAnd p) wX))
askAboutTagDepends :: forall (p :: * -> * -> *) wX wY.
(RepoPatch p, ApplyState p ~ Tree) =>
[DarcsFlag]
-> FL (PatchInfoAnd p) wX wY
-> IO (Sealed (FL (PatchInfoAnd p) wX))
askAboutTagDepends [DarcsFlag]
flags FL (PatchInfoAnd p) wX wY
ps = do
  let opts :: PatchSelectionOptions
opts = S.PatchSelectionOptions
             { verbosity :: Verbosity
S.verbosity = 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]
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
             }
  (deps:>_) <- FL (PatchInfoAnd p) wX wY
-> SelectionConfig (PatchInfoAnd p)
-> IO ((:>) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX 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 p) wX wY
ps (SelectionConfig (PatchInfoAnd p)
 -> IO ((:>) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX wY))
-> SelectionConfig (PatchInfoAnd p)
-> IO ((:>) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX wY)
forall a b. (a -> b) -> a -> b
$
                     ((WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter (PatchInfoAnd p))
-> Maybe [AnchoredPath]
-> SelectionConfig (PatchInfoAnd p)
forall (p :: * -> * -> *).
Matchable p =>
WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter p)
-> Maybe [AnchoredPath]
-> SelectionConfig p
selectionConfig WhichChanges
FirstReversed String
"depend on" PatchSelectionOptions
opts Maybe (Splitter (PatchInfoAnd p))
forall a. Maybe a
Nothing Maybe [AnchoredPath]
forall a. Maybe a
Nothing)
                          { allowSkipAll = False })
  return $ Sealed deps