-- Copyright (C) 2002-2003 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. {-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Commands.Record ( record , commit ) where import Darcs.Prelude import Control.Exception ( handleJust ) import Control.Monad ( unless, void, when ) import Data.Char ( ord ) import Data.Foldable ( traverse_ ) import System.Directory ( removeFile ) import System.Exit ( ExitCode(..), exitFailure, exitSuccess ) import Darcs.Patch ( PrimOf, RepoPatch, canonizeFL, summaryFL ) import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.Depends ( contextPatches ) import Darcs.Patch.Info ( PatchInfo, patchinfo ) import Darcs.Patch.Named ( adddeps, infopatch ) import Darcs.Patch.PatchInfoAnd ( n2pia ) import Darcs.Patch.Progress ( progressFL ) import Darcs.Patch.Split ( primSplitter ) import Darcs.Patch.Witnesses.Ordered ( (:>)(..), FL(..), nullFL, (+>+) ) import Darcs.Repository ( RepoJob(..) , Repository , AccessType(..) , finalizeRepositoryChanges , readPendingAndWorking , readPristine , readPatches , tentativelyAddPatch , tentativelyRemoveFromPW , withRepoLock ) import Darcs.Repository.Flags ( UpdatePending(..) ) import Darcs.UI.Commands ( DarcsCommand(..) , amInHashedRepository , commandAlias , nodefaults , setEnvDarcsFiles , setEnvDarcsPatches , withStdOpts ) import Darcs.UI.Commands.Util ( announceFiles , filterExistingPaths , testTentativeAndMaybeExit ) import Darcs.UI.Completion ( modifiedFileArgs ) import Darcs.UI.Flags ( DarcsFlag , diffingOpts , fileHelpAuthor , getAuthor , getDate , pathSetFromArgs ) import Darcs.UI.Options ( Config, (?), (^) ) import qualified Darcs.UI.Options.All as O import Darcs.UI.PatchHeader ( getLog ) import Darcs.UI.SelectChanges ( WhichChanges(..) , askAboutDepends , runInvertibleSelection , selectionConfigPrim ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) ) import Darcs.Util.Exception ( clarifyErrors ) import Darcs.Util.Global ( darcsLastMessage ) import Darcs.Util.Path ( AbsolutePath, AnchoredPath, displayPath ) import Darcs.Util.Printer ( Doc , formatWords , pathlist , putDocLn , text , vcat , vsep , ($+$) , (<+>) ) import Darcs.Util.Progress ( debugMessage ) import Darcs.Util.Prompt ( promptYorn ) import Darcs.Util.Tree ( Tree ) recordHelp :: Doc recordHelp = vsep (map formatWords [ [ "The `darcs record` command is used to create a patch from changes in" , "the working tree. If you specify a set of files and directories," , "changes to other files will be skipped." ] , [ "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)." ] , [ "You can supply the patch name in advance with the `-m` option, in which" , "case no text editor is launched, unless you use `--edit-long-comment`." ] , [ "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 description. This is useful if a previous" , "record failed and left a `_darcs/patch_description.txt` file." ] , fileHelpAuthor , [ "If you want to manually define any explicit dependencies for your patch," , "you can use the `--ask-deps` flag. 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. 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 input format. Here's an example of" , "what the `--pipe` prompts look like:" ] ]) $+$ vcat [ " 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" ] $+$ vsep (map formatWords [ [ "If a test command has been defined with `darcs setpref`, attempting to" , "record a patch will cause the test command to be run in a clean copy" , "of the working tree (that is, including only recorded changes). If" , "the test fails, you will be offered to abort the record operation." ] , [ "The `--set-scripts-executable` option causes scripts to be made" , "executable in the clean copy of the working tree, prior to running the" , "test. See `darcs clone` for an explanation of the script heuristic." ] , [ "If your test command is tediously slow (e.g. `make all`) and you are" , "recording several patches in a row, you may wish to use `--no-test` to" , "skip all but the final test." ] , [ "To see some context (unchanged lines) around each change, use the" , "`--unified` option." ] ]) record :: DarcsCommand record = DarcsCommand { commandProgramName = "darcs" , commandName = "record" , commandHelp = recordHelp , commandDescription = "Create a patch from unrecorded changes." , commandExtraArgs = -1 , commandExtraArgHelp = ["[FILE or DIRECTORY]..."] , commandCommand = recordCmd , commandPrereq = amInHashedRepository , commandCompleteArgs = modifiedFileArgs , commandArgdefaults = nodefaults , commandOptions = allOpts } where basicOpts = O.patchname ^ O.author ^ O.testChanges ^ O.interactive ^ O.pipe ^ O.askDeps ^ O.askLongComment ^ O.lookforadds ^ O.lookforreplaces ^ O.lookformoves ^ O.repoDir ^ O.diffAlgorithm advancedOpts = O.logfile ^ O.umask ^ O.setScriptsExecutable allOpts = basicOpts `withStdOpts` advancedOpts -- | commit is an alias for record commit :: DarcsCommand commit = commandAlias "commit" Nothing record reportNonExisting :: O.LookForAdds -> ([AnchoredPath], [AnchoredPath]) -> IO () reportNonExisting lfa (paths_only_in_working, _) = do unless (lfa /= O.NoLookForAdds || null paths_only_in_working) $ putDocLn $ "These paths are not yet in the repository and will be added:" <+> pathlist (map displayPath paths_only_in_working) recordCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () recordCmd fps cfg args = do checkNameIsNotOption (O.patchname ? cfg) (isInteractive cfg) withRepoLock (O.useCache ? cfg) (O.umask ? cfg) $ RepoJob $ \(repository :: Repository 'RW p wU wR) -> do existing_files <- do files <- pathSetFromArgs fps args files' <- traverse (filterExistingPaths repository (O.verbosity ? cfg) (diffingOpts cfg)) files when (O.verbosity ? cfg /= O.Quiet) $ traverse_ (reportNonExisting (O.lookforadds ? cfg)) files' let files'' = fmap snd files' when (files'' == Just []) $ fail "None of the files you specified exist." return files'' announceFiles (O.verbosity ? cfg) existing_files "Recording changes in" debugMessage "About to get the unrecorded changes." changes <- readPendingAndWorking (diffingOpts cfg) repository existing_files case changes of NilFL :> NilFL | not (O.askDeps ? cfg) -> do -- We need to grab any input waiting for us, since we -- might break scripts expecting to send it to us; we -- don't care what that input is, though. void (getDate (O.pipe ? cfg)) putStrLn "No changes!" exitFailure _ -> doRecord repository cfg existing_files changes -- | Check user specified patch name is not accidentally a command line flag checkNameIsNotOption :: Maybe String -> Bool -> IO () checkNameIsNotOption Nothing _ = return () checkNameIsNotOption _ False = return () checkNameIsNotOption (Just name) True = case name of [_] -> warnPatchName ('-':_) -> warnPatchName _ -> return () where warnPatchName = 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) => Repository 'RW p wU wR -> Config -> Maybe [AnchoredPath] -> (FL (PrimOf p) :> FL (PrimOf p)) wR wU -> IO () doRecord repository cfg files pw@(pending :> working) = do debugMessage "I've got unrecorded changes." date <- getDate (O.pipe ? cfg) my_author <- getAuthor (O.author ? cfg) (O.pipe ? cfg) debugMessage "I'm slurping the repository." debugMessage "About to select changes..." let da = O.diffAlgorithm ? cfg (chs :> _ ) <- runInvertibleSelection (canonizeFL da $ pending +>+ working) $ selectionConfigPrim First "record" (patchSelOpts cfg) (Just (primSplitter (O.diffAlgorithm ? cfg))) files when (not (O.askDeps ? cfg) && nullFL chs) $ do putStrLn "Ok, if you don't want to record anything, that's fine!" exitSuccess handleJust onlySuccessfulExits (\_ -> return ()) $ do deps <- if O.askDeps ? cfg then do _ :> patches <- contextPatches <$> readPatches repository askAboutDepends patches chs (patchSelOpts cfg) [] else return [] when (O.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 (O.patchname ? cfg) (O.pipe ? cfg) (O.logfile ? cfg) (O.askLongComment ? cfg) Nothing (summaryFL chs) debugMessage ("Patch name as received from getLog: " ++ show (map ord name)) doActualRecord repository cfg name date my_author my_log logf deps chs pw doActualRecord :: (RepoPatch p, ApplyState p ~ Tree) => Repository 'RW p wU wR -> Config -> String -> String -> String -> [String] -> Maybe String -> [PatchInfo] -> FL (PrimOf p) wR wX -> (FL (PrimOf p) :> FL (PrimOf p)) wR wU -> IO () doActualRecord _repository cfg name date my_author my_log logf deps chs (pending :> working) = do debugMessage "Writing the patch file..." myinfo <- patchinfo date name my_author my_log let mypatch = infopatch myinfo $ progressFL "Writing changes" chs let pia = n2pia $ adddeps mypatch deps _repository <- tentativelyAddPatch _repository NoUpdatePending pia tp <- readPristine _repository testTentativeAndMaybeExit tp cfg ("you have a bad patch: '" ++ name ++ "'") "record it" (Just failuremessage) tentativelyRemoveFromPW _repository chs pending working _repository <- finalizeRepositoryChanges _repository (O.dryRun ? cfg) `clarifyErrors` failuremessage debugMessage "Syncing timestamps..." removeLogFile logf unless (O.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 -> "" onlySuccessfulExits :: ExitCode -> Maybe () onlySuccessfulExits ExitSuccess = Just () onlySuccessfulExits _ = Nothing patchSelOpts :: Config -> S.PatchSelectionOptions patchSelOpts cfg = S.PatchSelectionOptions { S.verbosity = O.verbosity ? cfg , S.matchFlags = [] , S.interactive = isInteractive cfg , S.selectDeps = O.PromptDeps -- option not supported, use default , S.withSummary = O.NoSummary -- option not supported, use default } isInteractive :: Config -> Bool isInteractive cfg = maybe True id (O.interactive ? cfg)