1--  Copyright (C) 2002-2003,2005 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.MarkConflicts ( markconflicts ) where
21
22import Darcs.Prelude
23
24import System.Exit ( exitSuccess )
25import Data.List.Ordered ( nubSort, isect )
26import Control.Monad ( when, unless, void )
27
28import Darcs.Util.Prompt ( promptYorn )
29import Darcs.Util.SignalHandler ( withSignalsBlocked )
30import Darcs.Util.Path ( AbsolutePath, AnchoredPath, anchorPath )
31import Darcs.Util.Printer
32    ( Doc, pathlist, putDocLnWith, text, redText, debugDocLn, vsep, (<+>), ($$) )
33import Darcs.Util.Printer.Color ( fancyPrinters )
34
35import Darcs.UI.Commands
36    ( DarcsCommand(..)
37    , withStdOpts
38    , nodefaults
39    , amInHashedRepository
40    , putInfo
41    , putFinished
42    )
43import Darcs.UI.Commands.Util ( filterExistingPaths )
44import Darcs.UI.Completion ( knownFileArgs )
45import Darcs.UI.Flags
46    ( DarcsFlag, diffingOpts, verbosity, dryRun, umask
47    , useCache, pathSetFromArgs )
48import Darcs.UI.Options ( (^), odesc, ocheck, defaultFlags, (?) )
49import qualified Darcs.UI.Options.All as O
50
51import Darcs.Repository.Flags ( UpdatePending (..) )
52import Darcs.Repository
53    ( withRepoLock
54    , RepoJob(..)
55    , addToPending
56    , applyToWorking
57    , readRepo
58    , unrecordedChanges )
59
60import Darcs.Patch ( invert, listTouchedFiles, effectOnPaths )
61import Darcs.Patch.Show
62import Darcs.Patch.TouchesFiles ( chooseTouching )
63import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL )
64import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )
65import Darcs.Repository.Resolution
66    ( StandardResolution(..)
67    , patchsetConflictResolutions
68    , warnUnmangled
69    )
70
71-- * The mark-conflicts command
72
73markconflictsDescription :: String
74markconflictsDescription =
75 "Mark unresolved conflicts in working tree, for manual resolution."
76
77markconflictsHelp :: Doc
78markconflictsHelp = text $ unlines
79 ["Darcs requires human guidance to unify changes to the same part of a"
80 ,"source file.  When a conflict first occurs, darcs will add the"
81 ,"initial state and both choices to the working tree, delimited by the"
82 ,"markers `v v v`, `=====`,  `* * *` and `^ ^ ^`, as follows:"
83 ,""
84 ,"    v v v v v v v"
85 ,"    Initial state."
86 ,"    ============="
87 ,"    First choice."
88 ,"    *************"
89 ,"    Second choice."
90 ,"    ^ ^ ^ ^ ^ ^ ^"
91 ,""
92 ,"However, you might revert or manually delete these markers without"
93 ,"actually resolving the conflict.  In this case, `darcs mark-conflicts`"
94 ,"is useful to show where are the unresolved conflicts.  It is also"
95 ,"useful if `darcs apply` or `darcs pull` is called with"
96 ,"`--allow-conflicts`, where conflicts aren't marked initially."
97 ,""
98 ,"Unless you use the `--dry-run` flag, any unrecorded changes to the"
99 ,"affected files WILL be lost forever when you run this command!"
100 ,"You will be prompted for confirmation before this takes place."
101 ]
102
103markconflicts :: DarcsCommand
104markconflicts = DarcsCommand
105    { commandProgramName = "darcs"
106    , commandName = "mark-conflicts"
107    , commandHelp = markconflictsHelp
108    , commandDescription = markconflictsDescription
109    , commandExtraArgs = -1
110    , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]
111    , commandCommand = markconflictsCmd
112    , commandPrereq = amInHashedRepository
113    , commandCompleteArgs = knownFileArgs
114    , commandArgdefaults = nodefaults
115    , commandAdvancedOptions = odesc markconflictsAdvancedOpts
116    , commandBasicOptions = odesc markconflictsBasicOpts
117    , commandDefaults = defaultFlags markconflictsOpts
118    , commandCheckOptions = ocheck markconflictsOpts
119    }
120  where
121    markconflictsBasicOpts
122      = O.useIndex
123      ^ O.repoDir
124      ^ O.diffAlgorithm
125      ^ O.dryRunXml
126    markconflictsAdvancedOpts = O.umask
127    markconflictsOpts = markconflictsBasicOpts `withStdOpts` markconflictsAdvancedOpts
128
129markconflictsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
130markconflictsCmd fps opts args = do
131  paths <- maybeToOnly <$> pathSetFromArgs fps args
132  debugDocLn $ "::: paths =" <+>  (text . show) paths
133  withRepoLock (dryRun ? opts) (useCache ? opts) YesUpdatePending (umask ? opts) $
134    RepoJob $ \_repository -> do
135
136{-
137    What we do here:
138    * read the unrecorded changes (all of them)
139    * extract functions representing path rename effects from unrecorded
140    * convert argument paths to pre-pending
141    * read conflict resolutions that touch pre-pending argument paths
142    * affected paths = intersection of paths touched by resolutions
143                       and pre-pending argument paths
144    * for these paths, revert pending changes
145    * apply the (filtered, see above) conflict resolutions
146
147    Technical side-note:
148    Ghc can't handle pattern bindings for existentials. So 'let' is out,
149    one has to use 'case expr of var ->' or 'do var <- return expr'.
150    Case is clearer but do-notation does not increase indentation depth.
151    So we use case for small-scope bindings and <-/return when the scope
152    is a long do block.
153-}
154
155    let (useidx, scan, _) = diffingOpts opts
156        verb = verbosity ? opts
157    classified_paths <-
158      traverse (filterExistingPaths _repository verb useidx scan O.NoLookForMoves) paths
159
160    unrecorded <- unrecordedChanges (diffingOpts opts)
161      O.NoLookForMoves O.NoLookForReplaces
162      _repository (fromOnly Everything)
163
164    let forward_renames = effectOnPaths unrecorded
165        backward_renames = effectOnPaths (invert unrecorded)
166        existing_paths = fmap snd classified_paths
167        pre_pending_paths = fmap backward_renames existing_paths
168    debugDocLn $ "::: pre_pending_paths =" <+> (text . show) pre_pending_paths
169
170    r <- readRepo _repository
171    Sealed res <- case patchsetConflictResolutions r of
172      conflicts -> do
173        -- FIXME this should warn only about unmangled conflicts
174        -- involving the file paths we care about
175        warnUnmangled conflicts
176        Sealed mangled_res <- return $ mangled conflicts
177        let raw_res_paths = pathSet $ listTouchedFiles mangled_res
178        debugDocLn $ "::: raw_res_paths =" <+>  (text . show) raw_res_paths
179        return $ chooseTouching (fromOnly pre_pending_paths) mangled_res
180    let res_paths = pathSet $ listTouchedFiles res
181    debugDocLn $ "::: res_paths =" <+>  (text . show) res_paths
182
183    let affected_paths = res_paths `isectPathSet` pre_pending_paths
184    debugDocLn $ "::: affected_paths =" <+>  (text . show) affected_paths
185
186    when (affected_paths == Only []) $ do
187      putInfo opts "No conflicts to mark."
188      exitSuccess
189
190    to_revert <- unrecordedChanges (diffingOpts opts)
191      O.NoLookForMoves O.NoLookForReplaces
192      _repository (fromOnly affected_paths)
193
194    let post_pending_affected_paths = forward_renames <$> affected_paths
195    putInfo opts $ "Marking conflicts in:" <+> showPathSet post_pending_affected_paths <> "."
196
197    debugDocLn $ "::: to_revert =" $$ vsep (mapFL displayPatch to_revert)
198    debugDocLn $ "::: res = " $$ vsep (mapFL displayPatch res)
199    when (O.yes (dryRun ? opts)) $ do
200        putInfo opts $ "Conflicts will not be marked: this is a dry run."
201        exitSuccess
202
203    _repository <- case to_revert of
204      NilFL -> return _repository
205      _ -> do
206        -- TODO:
207        -- (1) create backups for all files where we revert changes
208        -- (2) try to add the reverted stuff to the unrevert bundle
209        -- after (1) and (2) is done we can soften the warning below
210        putDocLnWith fancyPrinters $
211          "Warning: This will revert all unrecorded changes in:"
212          <+> showPathSet post_pending_affected_paths <> "."
213          $$ redText "These changes will be LOST."
214        confirmed <- promptYorn "Are you sure? "
215        unless confirmed exitSuccess
216
217{-      -- copied from Revert.hs, see comment (2) above
218        debugMessage "About to write the unrevert file."
219        case commute (norevert:>p) of
220          Just (p':>_) -> writeUnrevert repository p' recorded NilFL
221          Nothing -> writeUnrevert repository (norevert+>+p) recorded NilFL
222        debugMessage "About to apply to the working tree."
223-}
224
225        let to_add = invert to_revert
226        addToPending _repository (O.useIndex ? opts) to_add
227        applyToWorking _repository (verbosity ? opts) to_add
228    withSignalsBlocked $
229      do addToPending _repository (O.useIndex ? opts) res
230         void $ applyToWorking _repository (verbosity ? opts) res
231    putFinished opts "marking conflicts"
232
233-- * Generic 'PathSet' support
234
235{- $SupportCode
236
237What follows is generic support code for working with argument path lists
238that are used to restrict operations to a subset of the working or pristine
239tree. The rest of Darcs uses two types for this:
240
241 * @'Maybe' ['SubPath']@
242
243 * @'Maybe' ['FilePath']@
244
245The problem with both is the contra-intuitive name 'Nothing', which here
246stands for 'Everything'. To make the intended use clearer, we use the 'Only'
247type instead (which is is isomorphic to 'Maybe') and the synonym 'PathSet'
248defined below.
249
250These abstractions should get their own module (or become integrated into
251Darcs.Util.Path) if and when someone decides to reuse it elsewhere. The
252functionality provided is intentionally minimal and light-weight.
253-}
254
255-- | 'Only' is isomorphic to 'Maybe' but with the opposite semantics.
256--
257-- About the name: I like the data constructor names, they are pretty
258-- suggestive. The data type name is up for grabs; a possible alternative
259-- is @AtMost@.
260data Only a = Everything | Only a deriving (Eq, Ord, Show)
261
262instance Functor Only where
263  fmap _ Everything = Everything
264  fmap f (Only x) = Only (f x)
265
266instance Foldable Only where
267  foldMap _ Everything = mempty
268  foldMap f (Only x) = f x
269
270instance Traversable Only where
271  traverse _ Everything = pure Everything
272  traverse f (Only x) = Only <$> f x
273
274-- | This is mostly for conversion to legacy APIs
275fromOnly :: Only a -> Maybe a
276fromOnly Everything = Nothing
277fromOnly (Only x) = Just x
278
279maybeToOnly :: Maybe a -> Only a
280maybeToOnly Nothing = Everything
281maybeToOnly (Just x) = Only x
282
283{- | A set of repository paths. 'Everything' means every path in the repo,
284it usually originates from an empty list of path arguments. The list of
285'AnchoredPath's is always kept in sorted order with no duplicates.
286
287It uses lists because the number of elements is expected to be small.
288-}
289type PathSet a = Only [a]
290
291-- | Intersection of two 'PathSet's
292isectPathSet :: Ord a => PathSet a -> PathSet a -> PathSet a
293isectPathSet Everything ys = ys
294isectPathSet xs Everything = xs
295isectPathSet (Only xs) (Only ys) = Only (isect xs ys)
296
297{-
298-- | Union of two 'PathSet's
299union :: PathSet -> PathSet -> PathSet
300union Everything ys = Everything
301union xs Everything = Everything
302union (Only xs) (Only ys) = Only (union xs ys)
303-}
304
305pathSet :: Ord a => [a] -> PathSet a
306pathSet = Only . nubSort
307
308-- | Convert a 'PathSet' to a 'Doc'. Uses the English module
309-- to generate a nicely readable list of file names.
310showPathSet :: PathSet AnchoredPath -> Doc
311showPathSet Everything = text "all paths"
312showPathSet (Only xs) = pathlist (map (anchorPath "") xs)
313