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