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