1-- Copyright (C) 2002-2003 David Roundy 2-- 3-- This program is free software; you can redistribute it and/or modify 4-- it under the terms of the GNU General Public License as published by 5-- the Free Software Foundation; either version 2, or (at your option) 6-- any later version. 7-- 8-- This program is distributed in the hope that it will be useful, 9-- but WITHOUT ANY WARRANTY; without even the implied warranty of 10-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11-- GNU General Public License for more details. 12-- 13-- You should have received a copy of the GNU General Public License 14-- along with this program; see the file COPYING. If not, write to 15-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 16-- Boston, MA 02110-1301, USA. 17 18{-# LANGUAGE OverloadedStrings #-} 19 20module Darcs.UI.Commands.Record 21 ( record 22 , commit 23 ) where 24 25import Darcs.Prelude 26import Data.Foldable ( traverse_ ) 27 28import Control.Exception ( handleJust ) 29import Control.Monad ( when, unless, void ) 30import Data.Char ( ord ) 31import System.Exit ( exitFailure, exitSuccess, ExitCode(..) ) 32import System.Directory ( removeFile ) 33 34import Darcs.Patch.PatchInfoAnd ( n2pia ) 35import Darcs.Repository 36 ( Repository 37 , withRepoLock 38 , RepoJob(..) 39 , tentativelyAddPatch 40 , finalizeRepositoryChanges 41 , invalidateIndex 42 , readPendingAndWorking 43 , readRecorded 44 ) 45import Darcs.Repository.Pending ( tentativelyRemoveFromPW ) 46 47import Darcs.Patch ( IsRepoType, RepoPatch, PrimOf, sortCoalesceFL ) 48import Darcs.Patch.Named ( infopatch, adddeps ) 49import Darcs.Patch.Witnesses.Ordered 50 ( FL(..), (:>)(..), nullFL, (+>+) ) 51import Darcs.Patch.Info ( PatchInfo, patchinfo ) 52import Darcs.Patch.Apply( ApplyState ) 53import Darcs.Patch.Split ( primSplitter ) 54import Darcs.UI.SelectChanges 55 ( WhichChanges(..) 56 , selectionConfigPrim 57 , runInvertibleSelection 58 , askAboutDepends 59 ) 60import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) ) 61import Darcs.Util.Path ( AnchoredPath, displayPath, AbsolutePath ) 62import Darcs.UI.Commands 63 ( DarcsCommand(..), withStdOpts 64 , nodefaults 65 , commandAlias 66 , setEnvDarcsFiles 67 , setEnvDarcsPatches 68 , amInHashedRepository 69 ) 70import Darcs.UI.Commands.Util ( announceFiles, filterExistingPaths, 71 testTentativeAndMaybeExit ) 72import Darcs.UI.Completion ( modifiedFileArgs ) 73import Darcs.UI.Flags 74 ( DarcsFlag 75 , fileHelpAuthor 76 , getAuthor 77 , getDate 78 , diffOpts 79 , scanKnown 80 , pathSetFromArgs 81 ) 82import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, oparse, defaultFlags ) 83import Darcs.UI.PatchHeader ( getLog ) 84import qualified Darcs.UI.Options.All as O 85import Darcs.Repository.Flags ( UpdatePending (..), DryRun(NoDryRun), ScanKnown(..) ) 86import Darcs.Util.Exception ( clarifyErrors ) 87import Darcs.Util.Prompt ( promptYorn ) 88import Darcs.Util.Progress ( debugMessage ) 89import Darcs.Util.Global ( darcsLastMessage ) 90import Darcs.Patch.Progress ( progressFL ) 91import Darcs.Util.Printer 92 ( Doc 93 , ($+$) 94 , (<+>) 95 , formatWords 96 , pathlist 97 , putDocLn 98 , text 99 , vcat 100 , vsep 101 ) 102import Darcs.Util.Tree( Tree ) 103 104recordHelp :: Doc 105recordHelp = 106 vsep (map formatWords 107 [ [ "The `darcs record` command is used to create a patch from changes in" 108 , "the working tree. If you specify a set of files and directories," 109 , "changes to other files will be skipped." 110 ] 111 , [ "Every patch has a name, an optional description, an author and a date." 112 ] 113 , [ "Darcs will launch a text editor (see `darcs help environment`) after the" 114 , "interactive selection, to let you enter the patch name (first line) and" 115 , "the patch description (subsequent lines)." 116 ] 117 , [ "You can supply the patch name in advance with the `-m` option, in which" 118 , "case no text editor is launched, unless you use `--edit-long-comment`." 119 ] 120 , [ "The patch description is an optional block of free-form text. It is" 121 , "used to supply additional information that doesn't fit in the patch" 122 , "name. For example, it might include a rationale of WHY the change was" 123 , "necessary." 124 ] 125 , [ "A technical difference between patch name and patch description, is" 126 , "that matching with the flag `-p` is only done on patch names." 127 ] 128 , [ "Finally, the `--logfile` option allows you to supply a file that already" 129 , "contains the patch name and description. This is useful if a previous" 130 , "record failed and left a `_darcs/patch_description.txt` file." 131 ] 132 , fileHelpAuthor 133 , [ "If you want to manually define any explicit dependencies for your patch," 134 , "you can use the `--ask-deps` flag. Some dependencies may be automatically" 135 , "inferred from the patch's content and cannot be removed. A patch with" 136 , "specific dependencies can be empty." 137 ] 138 , [ "The patch date is generated automatically. It can only be spoofed by" 139 , "using the `--pipe` option." 140 ] 141 , [ "If you run record with the `--pipe` option, you will be prompted for" 142 , "the patch date, author, and the long comment. The long comment will extend" 143 , "until the end of file or stdin is reached. This interface is intended for" 144 , "scripting darcs, in particular for writing repository conversion scripts." 145 , "The prompts are intended mostly as a useful guide (since scripts won't" 146 , "need them), to help you understand the input format. Here's an example of" 147 , "what the `--pipe` prompts look like:" 148 ] 149 ]) 150 $+$ vcat 151 [ " What is the date? Mon Nov 15 13:38:01 EST 2004" 152 , " Who is the author? David Roundy" 153 , " What is the log? One or more comment lines" 154 ] 155 $+$ vsep (map formatWords 156 [ [ "If a test command has been defined with `darcs setpref`, attempting to" 157 , "record a patch will cause the test command to be run in a clean copy" 158 , "of the working tree (that is, including only recorded changes). If" 159 , "the test fails, you will be offered to abort the record operation." 160 ] 161 , [ "The `--set-scripts-executable` option causes scripts to be made" 162 , "executable in the clean copy of the working tree, prior to running the" 163 , "test. See `darcs clone` for an explanation of the script heuristic." 164 ] 165 , [ "If your test command is tediously slow (e.g. `make all`) and you are" 166 , "recording several patches in a row, you may wish to use `--no-test` to" 167 , "skip all but the final test." 168 ] 169 , [ "To see some context (unchanged lines) around each change, use the" 170 , "`--unified` option." 171 ] 172 ]) 173 174recordBasicOpts :: DarcsOption a 175 (Maybe String 176 -> Maybe String 177 -> O.TestChanges 178 -> Maybe Bool 179 -> Bool 180 -> Bool 181 -> Maybe O.AskLongComment 182 -> O.LookFor 183 -> Maybe String 184 -> O.WithContext 185 -> O.DiffAlgorithm 186 -> a) 187recordBasicOpts 188 = O.patchname 189 ^ O.author 190 ^ O.testChanges 191 ^ O.interactive 192 ^ O.pipe 193 ^ O.askDeps 194 ^ O.askLongComment 195 ^ O.lookfor 196 ^ O.repoDir 197 ^ O.withContext 198 ^ O.diffAlgorithm 199 200recordAdvancedOpts :: DarcsOption a 201 (O.Logfile -> O.Compression -> O.UseIndex -> O.UMask -> O.SetScriptsExecutable -> O.IncludeBoring -> a) 202recordAdvancedOpts = O.logfile ^ O.compress ^ O.useIndex ^ O.umask ^ O.setScriptsExecutable ^ O.includeBoring 203 204data RecordConfig = RecordConfig 205 { patchname :: Maybe String 206 , author :: Maybe String 207 , testChanges :: O.TestChanges 208 , interactive :: Maybe Bool 209 , pipe :: Bool 210 , askDeps :: Bool 211 , askLongComment :: Maybe O.AskLongComment 212 , lookfor :: O.LookFor 213 , _workingRepoDir :: Maybe String 214 , withContext :: O.WithContext 215 , diffAlgorithm :: O.DiffAlgorithm 216 , verbosity :: O.Verbosity 217 , logfile :: O.Logfile 218 , compress :: O.Compression 219 , useIndex :: O.UseIndex 220 , umask :: O.UMask 221 , sse :: O.SetScriptsExecutable 222 , includeBoring :: O.IncludeBoring 223 , useCache :: O.UseCache 224 } 225 226recordConfig :: [DarcsFlag] -> RecordConfig 227recordConfig = oparse (recordBasicOpts ^ O.verbosity ^ recordAdvancedOpts ^ O.useCache) RecordConfig 228 229record :: DarcsCommand 230record = DarcsCommand 231 { commandProgramName = "darcs" 232 , commandName = "record" 233 , commandHelp = recordHelp 234 , commandDescription = "Create a patch from unrecorded changes." 235 , commandExtraArgs = -1 236 , commandExtraArgHelp = ["[FILE or DIRECTORY]..."] 237 , commandCommand = recordCmd 238 , commandPrereq = amInHashedRepository 239 , commandCompleteArgs = modifiedFileArgs 240 , commandArgdefaults = nodefaults 241 , commandAdvancedOptions = odesc recordAdvancedOpts 242 , commandBasicOptions = odesc recordBasicOpts 243 , commandDefaults = defaultFlags recordOpts 244 , commandCheckOptions = ocheck recordOpts 245 } 246 where 247 recordOpts = recordBasicOpts `withStdOpts` recordAdvancedOpts 248 249-- | commit is an alias for record 250commit :: DarcsCommand 251commit = commandAlias "commit" Nothing record 252 253reportNonExisting :: ScanKnown -> ([AnchoredPath], [AnchoredPath]) -> IO () 254reportNonExisting scan (paths_only_in_working, _) = do 255 unless (scan /= ScanKnown || null paths_only_in_working) $ putDocLn $ 256 "These paths are not yet in the repository and will be added:" <+> 257 pathlist (map displayPath paths_only_in_working) 258 259recordCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () 260recordCmd fps flags args = do 261 let cfg = recordConfig flags 262 checkNameIsNotOption (patchname cfg) (isInteractive cfg) 263 withRepoLock NoDryRun (useCache cfg) YesUpdatePending (umask cfg) $ RepoJob $ \(repository :: Repository rt p wR wU wR) -> do 264 let scan = scanKnown (O.adds (lookfor cfg)) (includeBoring cfg) 265 existing_files <- do 266 files <- pathSetFromArgs fps args 267 files' <- 268 traverse 269 (filterExistingPaths 270 repository (verbosity cfg) (useIndex cfg) scan (O.moves (lookfor cfg))) 271 files 272 when (verbosity cfg /= O.Quiet) $ 273 traverse_ (reportNonExisting scan) files' 274 let files'' = fmap snd files' 275 when (files'' == Just []) $ 276 fail "None of the files you specified exist." 277 return files'' 278 announceFiles (verbosity cfg) existing_files "Recording changes in" 279 debugMessage "About to get the unrecorded changes." 280 changes <- readPendingAndWorking (diffingOpts cfg) 281 (O.moves (lookfor cfg)) (O.replaces (lookfor cfg)) 282 repository existing_files 283 debugMessage "I've got unrecorded changes." 284 case changes of 285 NilFL :> NilFL | not (askDeps cfg) -> do 286 -- We need to grab any input waiting for us, since we 287 -- might break scripts expecting to send it to us; we 288 -- don't care what that input is, though. 289 void (getDate (pipe cfg)) 290 putStrLn "No changes!" 291 exitFailure 292 _ -> doRecord repository cfg existing_files changes 293 294-- | Check user specified patch name is not accidentally a command line flag 295checkNameIsNotOption :: Maybe String -> Bool -> IO () 296checkNameIsNotOption Nothing _ = return () 297checkNameIsNotOption _ False = return () 298checkNameIsNotOption (Just name) True = 299 when (length name == 1 || (length name == 2 && head name == '-')) $ do 300 confirmed <- promptYorn $ "You specified " ++ show name ++ " as the patch name. Is that really what you want?" 301 unless confirmed $ putStrLn "Okay, aborting the record." >> exitFailure 302 303doRecord :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) 304 => Repository rt p wR wU wR -> RecordConfig -> Maybe [AnchoredPath] 305 -> (FL (PrimOf p) :> FL (PrimOf p)) wR wU -> IO () 306doRecord repository cfg files pw@(pending :> working) = do 307 date <- getDate (pipe cfg) 308 my_author <- getAuthor (author cfg) (pipe cfg) 309 debugMessage "I'm slurping the repository." 310 pristine <- readRecorded repository 311 debugMessage "About to select changes..." 312 (chs :> _ ) <- runInvertibleSelection (sortCoalesceFL $ pending +>+ working) $ 313 selectionConfigPrim 314 First "record" (patchSelOpts cfg) 315 (Just (primSplitter (diffAlgorithm cfg))) 316 files (Just pristine) 317 when (not (askDeps cfg) && nullFL chs) $ 318 do putStrLn "Ok, if you don't want to record anything, that's fine!" 319 exitSuccess 320 handleJust onlySuccessfulExits (\_ -> return ()) $ 321 do deps <- if askDeps cfg 322 then askAboutDepends repository chs (patchSelOpts cfg) [] 323 else return [] 324 when (askDeps cfg) $ debugMessage "I've asked about dependencies." 325 if nullFL chs && null deps 326 then putStrLn "Ok, if you don't want to record anything, that's fine!" 327 else do setEnvDarcsFiles chs 328 (name, my_log, logf) <- getLog (patchname cfg) (pipe cfg) (logfile cfg) (askLongComment cfg) Nothing chs 329 debugMessage ("Patch name as received from getLog: " ++ show (map ord name)) 330 doActualRecord repository cfg name date my_author my_log logf deps chs pw 331 332doActualRecord :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) 333 => Repository rt p wR wU wR 334 -> RecordConfig 335 -> String -> String -> String 336 -> [String] -> Maybe String 337 -> [PatchInfo] -> FL (PrimOf p) wR wX 338 -> (FL (PrimOf p) :> FL (PrimOf p)) wR wU -> IO () 339doActualRecord _repository cfg name date my_author my_log logf deps chs 340 (pending :> working) = do 341 debugMessage "Writing the patch file..." 342 myinfo <- patchinfo date name my_author my_log 343 let mypatch = infopatch myinfo $ progressFL "Writing changes:" chs 344 let pia = n2pia $ adddeps mypatch deps 345 _repository <- 346 tentativelyAddPatch _repository (compress cfg) (verbosity cfg) 347 NoUpdatePending pia 348 invalidateIndex _repository 349 debugMessage "Applying to pristine..." 350 testTentativeAndMaybeExit _repository (verbosity cfg) (testChanges cfg) 351 (sse cfg) (isInteractive cfg) ("you have a bad patch: '" ++ name ++ "'") 352 "record it" (Just failuremessage) 353 tentativelyRemoveFromPW _repository chs pending working 354 _repository <- 355 finalizeRepositoryChanges _repository YesUpdatePending (compress cfg) 356 `clarifyErrors` failuremessage 357 debugMessage "Syncing timestamps..." 358 removeLogFile logf 359 unless (verbosity cfg == O.Quiet) $ 360 putDocLn $ text $ "Finished recording patch '" ++ name ++ "'" 361 setEnvDarcsPatches (pia :>: NilFL) 362 where 363 removeLogFile :: Maybe String -> IO () 364 removeLogFile Nothing = return () 365 removeLogFile (Just lf) 366 | lf == darcsLastMessage = return () 367 | otherwise = removeFile lf 368 failuremessage = 369 "Failed to record patch '" ++ name ++ "'" ++ 370 case logf of 371 Just lf -> "\nLogfile left in " ++ lf ++ "." 372 Nothing -> "" 373 374onlySuccessfulExits :: ExitCode -> Maybe () 375onlySuccessfulExits ExitSuccess = Just () 376onlySuccessfulExits _ = Nothing 377 378patchSelOpts :: RecordConfig -> S.PatchSelectionOptions 379patchSelOpts cfg = S.PatchSelectionOptions 380 { S.verbosity = verbosity cfg 381 , S.matchFlags = [] 382 , S.interactive = isInteractive cfg 383 , S.selectDeps = O.PromptDeps -- option not supported, use default 384 , S.withSummary = O.NoSummary -- option not supported, use default 385 , S.withContext = withContext cfg 386 } 387 388diffingOpts :: RecordConfig -> (O.UseIndex, O.ScanKnown, O.DiffAlgorithm) 389diffingOpts cfg = diffOpts (useIndex cfg) (O.adds (lookfor cfg)) O.NoIncludeBoring (diffAlgorithm cfg) 390 391isInteractive :: RecordConfig -> Bool 392isInteractive = maybe True id . interactive 393