module Darcs.UI.Commands.Record
( record
, commit
, getLog
, recordConfig, RecordConfig(..)
) where
import Prelude hiding ( (^), catch )
import Control.Applicative ( (<$>) )
import Control.Exception ( handleJust, catch, IOException )
import Control.Monad ( when, unless, void )
import System.IO ( stdin )
import Data.List ( sort, isPrefixOf )
import Data.Char ( ord )
import System.Exit ( exitFailure, exitSuccess, ExitCode(..) )
import System.Directory ( removeFile )
import qualified Data.ByteString as B ( hPut )
import Darcs.Repository.Lock
( readLocaleFile
, writeLocaleFile
, appendToFile
)
import Darcs.Patch.PatchInfoAnd ( n2pia )
import Darcs.Repository
( Repository
, withRepoLock
, RepoJob(..)
, tentativelyAddPatch
, finalizeRepositoryChanges
, invalidateIndex
, unrecordedChangesWithPatches
, readRecorded
, listRegisteredFiles
)
import Darcs.Patch
( RepoPatch, Patchy, PrimOf, PrimPatch
, namepatch, summaryFL, adddeps, fromPrims )
import Darcs.Patch.Witnesses.Sealed
import Darcs.Patch.Witnesses.Ordered
( FL(..), (:>)(..), nullFL )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )
import Darcs.Patch.Info ( PatchInfo )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Split ( primSplitter )
import Darcs.UI.External ( editFile )
import Darcs.UI.SelectChanges
( selectChanges
, WhichChanges(..)
, selectionContextPrim
, runSelection
, askAboutDepends
)
import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )
import Darcs.Util.Path ( FilePathLike, SubPath, toFilePath, AbsolutePath )
import Darcs.UI.Commands
( DarcsCommand(..), withStdOpts
, nodefaults
, commandStub
, setEnvDarcsFiles
, setEnvDarcsPatches
, amInHashedRepository
)
import Darcs.UI.Commands.Util ( announceFiles, filterExistingFiles,
testTentativeAndMaybeExit )
import Darcs.UI.Flags
( DarcsFlag
, fileHelpAuthor
, getAuthor
, getDate
, diffOpts
, fixSubPaths
)
import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, oparse, defaultFlags )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Flags ( UpdateWorking (..), DryRun(NoDryRun) )
import Darcs.Repository.Util ( getMovesPs, getReplaces )
import Darcs.Util.Exception ( clarifyErrors )
import Darcs.Util.Prompt ( askUser, promptYorn )
import Darcs.Util.Progress ( debugMessage )
import Darcs.Util.Global ( darcsLastMessage )
import Darcs.Patch.Progress ( progressFL )
import Darcs.Util.Printer ( putDocLn, hPutDocLn, text, ($$), prefixLines, RenderMode(..) )
import Darcs.Util.ByteString ( encodeLocale )
import qualified Darcs.Util.Ratified as Ratified ( hGetContents )
import Storage.Hashed.Tree( Tree )
recordDescription :: String
recordDescription = "Create a patch from unrecorded changes."
recordHelp :: String
recordHelp =
"The `darcs record` command is used to create a patch from changes in\n" ++
"the working tree. If you specify a set of files and directories,\n" ++
"changes to other files will be skipped.\n" ++
"\n" ++ recordHelp' ++
"\n" ++ recordHelp''
recordBasicOpts :: DarcsOption a
(Maybe String
-> Maybe String
-> O.TestChanges
-> Maybe Bool
-> Bool
-> Bool
-> Maybe O.AskLongComment
-> O.LookFor
-> Maybe String
-> O.WithContext
-> O.DiffAlgorithm
-> a)
recordBasicOpts
= O.patchname
^ O.author
^ O.testChanges
^ O.interactive
^ O.pipe
^ O.askdeps
^ O.askLongComment
^ O.lookfor
^ O.workingRepoDir
^ O.withContext
^ O.diffAlgorithm
recordAdvancedOpts :: DarcsOption a
(O.Logfile -> O.Compression -> O.UseIndex -> O.UMask -> O.SetScriptsExecutable -> a)
recordAdvancedOpts = O.logfile ^ O.compress ^ O.useIndex ^ O.umask ^ O.setScriptsExecutable
recordOpts :: DarcsOption a
(Maybe String
-> Maybe String
-> O.TestChanges
-> Maybe Bool
-> Bool
-> Bool
-> Maybe O.AskLongComment
-> O.LookFor
-> Maybe String
-> O.WithContext
-> O.DiffAlgorithm
-> Maybe O.StdCmdAction
-> Bool
-> Bool
-> O.Verbosity
-> Bool
-> O.Logfile
-> O.Compression
-> O.UseIndex
-> O.UMask
-> O.SetScriptsExecutable
-> O.UseCache
-> Maybe String
-> Bool
-> Maybe String
-> Bool
-> a)
recordOpts = recordBasicOpts `withStdOpts` recordAdvancedOpts
data RecordConfig = RecordConfig
{ patchname :: Maybe String
, author :: Maybe String
, testChanges :: O.TestChanges
, interactive :: Maybe Bool
, pipe :: Bool
, askDeps :: Bool
, askLongComment :: Maybe O.AskLongComment
, lookfor :: O.LookFor
, _workingRepoDir :: Maybe String
, withContext :: O.WithContext
, diffAlgorithm :: O.DiffAlgorithm
, verbosity :: O.Verbosity
, logfile :: O.Logfile
, compress :: O.Compression
, useIndex :: O.UseIndex
, umask :: O.UMask
, sse :: O.SetScriptsExecutable
, useCache :: O.UseCache
}
recordConfig :: [DarcsFlag] -> RecordConfig
recordConfig = oparse (recordBasicOpts ^ O.verbosity ^ recordAdvancedOpts ^ O.useCache) RecordConfig
record :: DarcsCommand RecordConfig
record = DarcsCommand
{ commandProgramName = "darcs"
, commandName = "record"
, commandHelp = recordHelp
, commandDescription = recordDescription
, commandExtraArgs = 1
, commandExtraArgHelp = ["[FILE or DIRECTORY]..."]
, commandCommand = recordCmd
, commandPrereq = amInHashedRepository
, commandGetArgPossibilities = listRegisteredFiles
, commandArgdefaults = nodefaults
, commandAdvancedOptions = odesc recordAdvancedOpts
, commandBasicOptions = odesc recordBasicOpts
, commandDefaults = defaultFlags recordOpts
, commandCheckOptions = ocheck recordOpts
, commandParseOptions = recordConfig
}
commitDescription :: String
commitDescription = "Redirect the user to record, push or send."
commitHelp :: String
commitHelp =
"This command does not do anything.\n"++
"If you want to save changes locally, use the `darcs record` command.\n"++
"If you want to save a recorded patch to another repository, use the\n"++
"`darcs push` or `darcs send` commands instead.\n"
commit :: DarcsCommand RecordConfig
commit = commandStub "commit" commitHelp commitDescription record
recordCmd :: (AbsolutePath, AbsolutePath) -> RecordConfig -> [String] -> IO ()
recordCmd fps cfg args = do
checkNameIsNotOption (patchname cfg) (isInteractive True cfg)
withRepoLock NoDryRun (useCache cfg) YesUpdateWorking (umask cfg) $ RepoJob $ \(repository :: Repository p wR wU wR) -> do
files <- if null args then return Nothing
else Just . sort <$> fixSubPaths fps args
when (files == Just []) $ fail "No valid arguments were given."
announceFiles files "Recording changes in"
existing_files <- maybe (return Nothing)
(fmap Just . filterExistingFiles repository (O.adds (lookfor cfg))) files
when (existing_files == Just []) $
fail "None of the files you specified exist!"
debugMessage "About to get the unrecorded changes."
Sealed replacePs <- if O.replaces (lookfor cfg) == O.YesLookForReplaces
then getReplaces (diffingOpts cfg) repository files
else return (Sealed NilFL)
movesPs <- if O.moves (lookfor cfg) == O.YesLookForMoves
then getMovesPs repository files
else return NilFL
changes <- unrecordedChangesWithPatches (diffingOpts cfg) repository files
movesPs (unsafeCoerceP replacePs :: FL (PrimOf p) wR wR)
debugMessage "I've got unrecorded changes."
case changes of
NilFL | not (askDeps cfg) -> do
void (getDate (pipe cfg))
putStrLn "No changes!"
exitFailure
_ -> doRecord repository cfg existing_files changes
checkNameIsNotOption :: Maybe String -> Bool -> IO ()
checkNameIsNotOption Nothing _ = return ()
checkNameIsNotOption _ False = return ()
checkNameIsNotOption (Just name) True =
when (length name == 1 || (length name == 2 && head name == '-')) $ do
confirmed <- promptYorn $ "You specified " ++ show name ++ " as the patch name. Is that really what you want?"
unless confirmed $ putStrLn "Okay, aborting the record." >> exitFailure
doRecord :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
=> Repository p wR wU wR -> RecordConfig -> Maybe [SubPath] -> FL (PrimOf p) wR wX -> IO ()
doRecord repository cfg files ps = do
date <- getDate (pipe cfg)
my_author <- getAuthor (author cfg) (pipe cfg)
debugMessage "I'm slurping the repository."
debugMessage "About to select changes..."
pristine <- readRecorded repository
(chs :> _ ) <- runSelection (selectChanges ps) $
selectionContextPrim First "record" (patchSelOpts cfg) (Just primSplitter)
(map toFilePath <$> files)
(Just pristine)
when (is_empty_but_not_askdeps chs) $
do putStrLn "Ok, if you don't want to record anything, that's fine!"
exitSuccess
handleJust onlySuccessfulExits (\_ -> return ()) $
do deps <- if askDeps cfg
then askAboutDepends repository chs (patchSelOpts cfg) []
else return []
when (askDeps cfg) $ debugMessage "I've asked about dependencies."
if nullFL chs && null deps
then putStrLn "Ok, if you don't want to record anything, that's fine!"
else do setEnvDarcsFiles chs
(name, my_log, logf) <- getLog (patchname cfg) (pipe cfg) (logfile cfg) (askLongComment cfg) Nothing chs
debugMessage ("Patch name as received from getLog: " ++ show (map ord name))
doActualRecord repository cfg name date my_author my_log logf deps chs
where is_empty_but_not_askdeps l
| askDeps cfg = False
| otherwise = nullFL l
doActualRecord :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository p wR wU wR
-> RecordConfig
-> String -> String -> String
-> [String] -> Maybe String
-> [PatchInfo] -> FL (PrimOf p) wR wX -> IO ()
doActualRecord repository cfg name date my_author my_log logf deps chs =
do debugMessage "Writing the patch file..."
mypatch <- namepatch date name my_author my_log $
fromPrims $ progressFL "Writing changes:" chs
let pia = n2pia $ adddeps mypatch deps
_ <- tentativelyAddPatch repository (compress cfg) (verbosity cfg) YesUpdateWorking
$ pia
invalidateIndex repository
debugMessage "Applying to pristine..."
testTentativeAndMaybeExit repository
(verbosity cfg)
(testChanges cfg)
(sse cfg)
(isInteractive True cfg)
("you have a bad patch: '" ++ name ++ "'")
"record it" (Just failuremessage)
finalizeRepositoryChanges repository YesUpdateWorking (compress cfg)
`clarifyErrors` failuremessage
debugMessage "Syncing timestamps..."
removeLogFile logf
unless (verbosity cfg == O.Quiet) $
putDocLn $ text $ "Finished recording patch '" ++ name ++ "'"
setEnvDarcsPatches (pia :>: NilFL)
where
removeLogFile :: Maybe String -> IO ()
removeLogFile Nothing = return ()
removeLogFile (Just lf) | lf == darcsLastMessage = return ()
| otherwise = removeFile lf
failuremessage = "Failed to record patch '"++name++"'" ++
case logf of Just lf -> "\nLogfile left in "++lf++"."
Nothing -> ""
recordHelp' :: String
recordHelp' = unlines
[ "Every patch has a name, an optional description, an author and a date."
, ""
, "Darcs will launch a text editor (see `darcs help environment`) after the"
, "interactive selection, to let you enter the patch name (first line) and"
, "the patch description (subsequent lines)."
, ""
, "The patch name should be a short sentence that concisely describes the"
, "patch, such as \"Add error handling to main event loop.\" You can"
, "supply it in advance with the `-m` option, in which case no text editor"
, "is launched, unless you use the `--edit-long-comment` option."
, ""
, "The patch description is an optional block of free-form text. It is"
, "used to supply additional information that doesn't fit in the patch"
, "name. For example, it might include a rationale of WHY the change was"
, "necessary."
, ""
, "A technical difference between patch name and patch description, is"
, "that matching with the flag `-p` is only done on patch names."
, ""
, "Finally, the `--logfile` option allows you to supply a file that"
, "already contains the patch name and patch description. This is"
, "useful if a previous record failed and left a `darcs-record-0` file."
, ""
, unlines fileHelpAuthor
, ""
, "If you want to manually define any extra dependencies for your patch,"
, "you can use the `--ask-deps` flag, and darcs will ask you for the patch's"
, "dependencies. Some dependencies may be automatically inferred from the"
, "patch's content and cannot be removed. "
, "A patch with specific dependencies can be empty."
, ""
, "The patch date is generated automatically. It can only be spoofed by"
, "using the `--pipe` option."
, ""
, "If you run record with the `--pipe` option, you will be prompted for"
, "the patch date, author, and the long comment. The long comment will extend"
, "until the end of file or stdin is reached (ctrl-D on Unixy systems, ctrl-Z"
, "on systems running a Microsoft OS)."
, ""
, "This interface is intended for scripting darcs, in particular for writing"
, "repository conversion scripts. The prompts are intended mostly as a useful"
, "guide (since scripts won't need them), to help you understand the format in"
, "which to provide the input. Here's an example of what the `--pipe`"
, "prompts look like:"
, ""
, " What is the date? Mon Nov 15 13:38:01 EST 2004"
, " Who is the author? David Roundy"
, " What is the log? One or more comment lines"
]
data PName = FlagPatchName String | PriorPatchName String | NoPatchName
getLog :: forall prim wX wY . (Patchy prim, PrimPatch prim)
=> Maybe String
-> Bool
-> O.Logfile
-> Maybe O.AskLongComment
-> Maybe (String, [String])
-> FL prim wX wY
-> IO (String, [String], Maybe String)
getLog m_name has_pipe log_file ask_long m_old chs = go has_pipe log_file ask_long where
go True _ _ = do
p <- case patchname_specified of
FlagPatchName p -> return p
PriorPatchName p -> return p
NoPatchName -> prompt_patchname False
putStrLn "What is the log?"
thelog <- lines `fmap` Ratified.hGetContents stdin
return (p, thelog, Nothing)
go _ (O.Logfile { O._logfile = Just f }) _ = do
mlp <- lines `fmap` readLocaleFile f `catch` (\(_ :: IOException) -> return [])
firstname <- case (patchname_specified, mlp) of
(FlagPatchName p, []) -> return p
(_, p:_) -> if badName p
then prompt_patchname True
else return p
(PriorPatchName p, []) -> return p
(NoPatchName, []) -> prompt_patchname True
append_info f firstname
when (ask_long == Just O.YesEditLongComment) (void $ editFile f)
(name, thelog) <- read_long_comment f firstname
return (name, thelog, if O._rmlogfile log_file then Just $ toFilePath f else Nothing)
go _ _ (Just O.YesEditLongComment) =
case patchname_specified of
FlagPatchName p -> actually_get_log p
PriorPatchName p -> actually_get_log p
NoPatchName -> actually_get_log ""
go _ _ (Just O.NoEditLongComment) =
case patchname_specified of
FlagPatchName p -> return (p, default_log, Nothing)
PriorPatchName p -> return (p, default_log, Nothing)
NoPatchName -> do p <- prompt_patchname True
return (p, [], Nothing)
go _ _ (Just O.PromptLongComment) =
case patchname_specified of
FlagPatchName p -> prompt_long_comment p
PriorPatchName p -> prompt_long_comment p
NoPatchName -> prompt_patchname True >>= prompt_long_comment
go _ _ Nothing =
case patchname_specified of
FlagPatchName p -> return (p, default_log, Nothing)
PriorPatchName "" -> actually_get_log ""
PriorPatchName p -> return (p, default_log, Nothing)
NoPatchName -> actually_get_log ""
patchname_specified = case (m_name, m_old) of
(Just name, _) | badName name -> NoPatchName
| otherwise -> FlagPatchName name
(Nothing, Just (name,_)) -> PriorPatchName name
(Nothing, Nothing) -> NoPatchName
badName "" = True
badName n = "TAG" `isPrefixOf` n
default_log = case m_old of
Nothing -> []
Just (_,l) -> l
prompt_patchname retry =
do n <- askUser "What is the patch name? "
if badName n
then if retry then prompt_patchname retry
else fail "Bad patch name!"
else return n
prompt_long_comment oldname =
do y <- promptYorn "Do you want to add a long comment?"
if y then actually_get_log oldname
else return (oldname, [], Nothing)
actually_get_log p = do let logf = darcsLastMessage
writeLocaleFile logf $ unlines $ p : default_log
append_info logf p
_ <- editFile logf
(name,long) <- read_long_comment logf p
if badName name
then do putStrLn "WARNING: empty or incorrect patch name!"
pn <- prompt_patchname True
return (pn, long, Nothing)
else return (name,long,Just logf)
read_long_comment :: FilePathLike p => p -> String -> IO (String, [String])
read_long_comment f oldname =
do f' <- readLocaleFile f
let t = filter (not.("#" `isPrefixOf`)) $ (lines.filter (/='\r')) f'
case t of [] -> return (oldname, [])
(n:ls) -> return (n, ls)
append_info f oldname =
do fc <- readLocaleFile f
appendToFile f $ \h ->
do case fc of
_ | null (lines fc) -> B.hPut h (encodeLocale (oldname ++ "\n"))
| last fc /= '\n' -> B.hPut h (encodeLocale "\n")
| otherwise -> return ()
hPutDocLn Encode h
$ text "# Please enter the patch name in the first line, and"
$$ text "# optionally, a long description in the following lines."
$$ text "#"
$$ text "# Lines starting with '#' will be ignored."
$$ text "#"
$$ text "#"
$$ text "# This patch contains the following changes:"
$$ text "#"
$$ prefixLines (text "#") (summaryFL chs)
onlySuccessfulExits :: ExitCode -> Maybe ()
onlySuccessfulExits ExitSuccess = Just ()
onlySuccessfulExits _ = Nothing
recordHelp'' :: String
recordHelp'' =
"If a test command has been defined with `darcs setpref`, attempting to\n" ++
"record a patch will cause the test command to be run in a clean copy\n" ++
"of the working tree (that is, including only recorded changes). If\n" ++
"the test fails, you will be offered to abort the record operation.\n" ++
"\n" ++
"The `--set-scripts-executable` option causes scripts to be made\n" ++
"executable in the clean copy of the working tree, prior to running the\n" ++
"test. See `darcs get` for an explanation of the script heuristic.\n" ++
"\n" ++
"If your test command is tediously slow (e.g. `make all`) and you are\n" ++
"recording several patches in a row, you may wish to use `--no-test` to\n" ++
"skip all but the final test.\n" ++
"\n" ++
"To see some context (unchanged lines) around each change, use the\n" ++
"`--unified` option.\n"
patchSelOpts :: RecordConfig -> S.PatchSelectionOptions
patchSelOpts cfg = S.PatchSelectionOptions
{ S.verbosity = verbosity cfg
, S.matchFlags = []
, S.diffAlgorithm = diffAlgorithm cfg
, S.interactive = isInteractive True cfg
, S.selectDeps = O.PromptDeps
, S.summary = O.NoSummary
, S.withContext = withContext cfg
}
diffingOpts :: RecordConfig -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm)
diffingOpts cfg = diffOpts (useIndex cfg) (O.adds (lookfor cfg)) False (diffAlgorithm cfg)
isInteractive :: Bool -> RecordConfig -> Bool
isInteractive def = maybe def id . interactive