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 RecordWildCards #-} 19module Darcs.UI.SelectChanges 20 ( -- * Working with changes 21 WhichChanges(..) 22 , viewChanges 23 , withSelectedPatchFromList 24 , runSelection 25 , runInvertibleSelection 26 , selectionConfigPrim 27 , selectionConfigGeneric 28 , selectionConfig 29 , SelectionConfig(allowSkipAll) 30 -- * Interactive selection utils 31 , PatchSelectionOptions(..) 32 , InteractiveSelectionM 33 , InteractiveSelectionState(..) 34 , initialSelectionState 35 -- ** Navigating the patchset 36 , currentPatch 37 , skipMundane 38 , skipOne 39 , backOne 40 , backAll 41 -- ** Decisions 42 , decide 43 , decideWholeFile 44 -- ** Prompts and queries 45 , isSingleFile 46 , currentFile 47 , promptUser 48 , prompt 49 , KeyPress(..) 50 , keysFor 51 , helpFor 52 , askAboutDepends 53 ) where 54 55import Darcs.Prelude 56 57import Control.Monad ( liftM, unless, when, (>=>) ) 58import Control.Monad.Identity ( Identity (..) ) 59import Control.Monad.Reader 60 ( ReaderT 61 , asks 62 , runReaderT 63 ) 64import Control.Monad.State 65 ( StateT, execStateT, gets 66 , modify, runStateT, state 67 ) 68import Control.Monad.Trans ( liftIO ) 69import Data.List ( intercalate, union ) 70import Data.Maybe ( isJust ) 71import System.Exit ( exitSuccess ) 72 73import Darcs.Patch 74 ( IsRepoType, RepoPatch, PrimOf 75 , commuteFL, invert 76 , listTouchedFiles 77 ) 78import qualified Darcs.Patch ( thing, things ) 79import Darcs.Patch.Apply ( ApplyState ) 80import Darcs.Patch.Choices 81 ( PatchChoices, Slot (..), LabelledPatch 82 , forceFirst, forceLast, forceMatchingFirst 83 , forceMatchingLast, getChoices 84 , makeEverythingLater, makeEverythingSooner 85 , forceMiddle, patchChoices 86 , patchSlot 87 , refineChoices, selectAllMiddles 88 , separateFirstFromMiddleLast 89 , substitute, label, unLabel 90 , labelPatches 91 ) 92import Darcs.Patch.Commute ( Commute ) 93import Darcs.Patch.Depends ( contextPatches ) 94import Darcs.Patch.Ident ( Ident(..), PatchId ) 95import Darcs.Patch.Info ( PatchInfo ) 96import Darcs.Patch.Inspect ( PatchInspect ) 97import Darcs.Patch.Invert ( Invert ) 98import Darcs.Patch.Invertible 99import Darcs.Patch.Match 100 ( Matchable 101 , MatchableRP 102 , haveNonrangeMatch 103 , matchAPatch 104 ) 105import Darcs.Patch.Named ( adddeps, anonymous ) 106import Darcs.Patch.PatchInfoAnd ( n2pia ) 107import Darcs.Patch.Permutations ( commuteWhatWeCanRL ) 108import Darcs.Patch.Show ( ShowPatch, ShowContextPatch ) 109import Darcs.Patch.Split ( Splitter(..) ) 110import Darcs.Patch.TouchesFiles ( selectNotTouching, deselectNotTouching ) 111import Darcs.Patch.Witnesses.Ordered 112 ( (:>) (..), (:||:) (..), FL (..) 113 , RL (..), filterFL, lengthFL, mapFL 114 , mapFL_FL, spanFL, spanFL_M 115 , (+>+), (+<<+) 116 , reverseFL, reverseRL 117 ) 118import Darcs.Patch.Witnesses.Sealed 119 ( FlippedSeal (..), Sealed2 (..) 120 , flipSeal, seal2, unseal2 121 ) 122import Darcs.Patch.Witnesses.WZipper 123 ( FZipper (..), focus, jokers, left, right 124 , rightmost, toEnd, toStart 125 ) 126import Darcs.Repository ( Repository, repoLocation, readTentativeRepo ) 127import Darcs.UI.External ( editText ) 128import Darcs.UI.Options.All 129 ( Verbosity(..), WithSummary(..) 130 , WithContext(..), SelectDeps(..), MatchFlag ) 131import Darcs.UI.PrintPatch 132 ( printContent 133 , printContentWithPager 134 , printFriendly 135 , printSummary 136 , showFriendly 137 ) 138import Darcs.Util.English ( Noun (..), englishNum, capitalize ) 139import Darcs.Util.Path ( AnchoredPath ) 140import Darcs.Util.Printer ( putDocLnWith, greenText, vcat ) 141import Darcs.Util.Printer.Color ( fancyPrinters ) 142import Darcs.Util.Prompt ( PromptConfig (..), askUser, promptChar ) 143import Darcs.Util.Tree ( Tree ) 144 145 146-- | When asking about patches, we either ask about them in 147-- oldest-first or newest first (with respect to the current ordering 148-- of the repository), and we either want an initial segment or a 149-- final segment of the poset of patches. 150-- 151-- 'First': ask for an initial 152-- segment, first patches first (default for all pull-like commands) 153-- 154-- 'FirstReversed': ask for an initial segment, last patches first 155-- (used to ask about dependencies in record, and for pull-like 156-- commands with the @--reverse@ flag). 157-- 158-- 'LastReversed': ask for a final segment, last patches first. (default 159-- for unpull-like commands, except for selecting *primitive* patches in 160-- rollback) 161-- 162-- 'Last': ask for a final segment, first patches first. (used for selecting 163-- primitive patches in rollback, and for unpull-like commands with the 164-- @--reverse@ flag 165-- 166-- IOW: First = initial segment 167-- Last = final segment 168-- Reversed = start with the newest patch instead of oldest 169-- As usual, terminology is not, ahem, very intuitive. 170data WhichChanges = Last | LastReversed | First | FirstReversed deriving (Eq, Show) 171 172-- | A 'WhichChanges' is 'backward' if the segment of patches we ask for 173-- is at the opposite end of where we start to present them. 174backward :: WhichChanges -> Bool 175backward w = w == Last || w == FirstReversed 176 177-- | A 'WhichChanges' is reversed if the order in which patches are presented 178-- is latest (or newest) patch first. 179reversed :: WhichChanges -> Bool 180reversed w = w == LastReversed || w == FirstReversed 181 182-- | The type of the function we use to filter patches when @--match@ is 183-- given. 184data MatchCriterion p = MatchCriterion 185 { mcHasNonrange :: Bool 186 , mcFunction :: forall wA wB. p wA wB -> Bool 187 } 188 189data PatchSelectionOptions = PatchSelectionOptions 190 { verbosity :: Verbosity 191 , matchFlags :: [MatchFlag] 192 , interactive :: Bool 193 , selectDeps :: SelectDeps 194 , withSummary :: WithSummary 195 , withContext :: WithContext 196 } 197 198-- | All the static settings for selecting patches. 199data SelectionConfig p = 200 PSC { opts :: PatchSelectionOptions 201 , splitter :: Maybe (Splitter p) 202 , files :: Maybe [AnchoredPath] 203 , matchCriterion :: MatchCriterion p 204 , jobname :: String 205 , allowSkipAll :: Bool 206 , pristine :: Maybe (Tree IO) 207 , whichChanges :: WhichChanges 208 } 209 210-- | A 'SelectionConfig' for selecting 'Prim' patches. 211selectionConfigPrim :: WhichChanges 212 -> String 213 -> PatchSelectionOptions 214 -> Maybe (Splitter prim) 215 -> Maybe [AnchoredPath] 216 -> Maybe (Tree IO) 217 -> SelectionConfig prim 218selectionConfigPrim whch jn o spl fs p = 219 PSC { opts = o 220 , splitter = spl 221 , files = fs 222 , matchCriterion = triv 223 , jobname = jn 224 , allowSkipAll = True 225 , pristine = p 226 , whichChanges = whch 227 } 228 229-- | A 'SelectionConfig' for selecting full ('Matchable') patches 230selectionConfig :: Matchable p 231 => WhichChanges 232 -> String 233 -> PatchSelectionOptions 234 -> Maybe (Splitter p) 235 -> Maybe [AnchoredPath] 236 -> SelectionConfig p 237selectionConfig whch jn o spl fs = 238 PSC { opts = o 239 , splitter = spl 240 , files = fs 241 , matchCriterion = iswanted seal2 (matchFlags o) 242 , jobname = jn 243 , allowSkipAll = True 244 , pristine = Nothing 245 , whichChanges = whch 246 } 247 248-- | A generic 'SelectionConfig'. 249selectionConfigGeneric :: Matchable p 250 => (forall wX wY . q wX wY -> Sealed2 p) 251 -> WhichChanges 252 -> String 253 -> PatchSelectionOptions 254 -> Maybe [AnchoredPath] 255 -> SelectionConfig q 256selectionConfigGeneric extract whch jn o fs = 257 PSC { opts = o 258 , splitter = Nothing 259 , files = fs 260 , matchCriterion = iswanted extract (matchFlags o) 261 , jobname = jn 262 , allowSkipAll = True 263 , pristine = Nothing 264 , whichChanges = whch 265 } 266 267-- | The dynamic parameters for interactive selection of patches. 268data InteractiveSelectionState p wX wY = 269 ISC { total :: Int -- ^ total number of patches 270 , current :: Int -- ^ number of already-seen patches 271 , lps :: FZipper (LabelledPatch p) wX wY -- ^ the patches we offer 272 , choices :: PatchChoices p wX wY -- ^ the user's choices 273 } 274 275type PatchSelectionM p a = ReaderT (SelectionConfig p) a 276 277type InteractiveSelectionM p wX wY a = 278 StateT (InteractiveSelectionState p wX wY) 279 (PatchSelectionM p IO) a 280 281-- Common match criteria 282 283-- | For commands without @--match@, 'triv' matches all patches 284triv :: MatchCriterion p 285triv = MatchCriterion { mcHasNonrange = False, mcFunction = \ _ -> True } 286 287-- | 'iswanted' selects patches according to the given match flags 288iswanted :: Matchable p 289 => (forall wX wY . q wX wY -> Sealed2 p) 290 -> [MatchFlag] 291 -> MatchCriterion q 292iswanted extract mflags = MatchCriterion 293 { mcHasNonrange = haveNonrangeMatch mflags 294 , mcFunction = unseal2 (matchAPatch mflags) . extract 295 } 296 297-- | Run a 'PatchSelection' action in the given 'SelectionConfig', 298-- without assuming that patches are invertible. 299runSelection :: ( MatchableRP p, ShowPatch p, ShowContextPatch p 300 , ApplyState p ~ Tree, ApplyState p ~ ApplyState (PrimOf p) 301 ) 302 => FL p wX wY 303 -> SelectionConfig p 304 -> IO ((FL p :> FL p) wX wY) 305runSelection _ PSC { splitter = Just _ } = 306 -- a Splitter makes sense for prim patches only and these are invertible anyway 307 error "cannot use runSelection with Splitter" 308runSelection ps PSC { matchCriterion = mc, .. } = do 309 unwrapOutput <$> runInvertibleSelection (wrapInput ps) ictx 310 where 311 convertMC :: MatchCriterion p -> MatchCriterion (Invertible p) 312 convertMC MatchCriterion { mcFunction = mcf, .. } = 313 MatchCriterion { mcFunction = withInvertible mcf, .. } 314 ictx = PSC { matchCriterion = convertMC mc, splitter = Nothing, .. } 315 wrapInput = mapFL_FL mkInvertible 316 unwrapOutput (xs :> ys) = 317 mapFL_FL fromPositiveInvertible xs :> mapFL_FL fromPositiveInvertible ys 318 319-- | Run a 'PatchSelection' action in the given 'SelectionConfig', 320-- assuming patches are invertible. 321runInvertibleSelection :: forall p wX wY . 322 ( Invert p, MatchableRP p, ShowPatch p 323 , ShowContextPatch p, ApplyState p ~ Tree 324 ) 325 => FL p wX wY 326 -> SelectionConfig p 327 -> IO ((FL p :> FL p) wX wY) 328runInvertibleSelection ps psc = runReaderT (selection ps) psc where 329 selection 330 | reversed whch = fmap invert . doit . invert 331 | otherwise = doit 332 -- efficiency note: we should first filterUnwanted to apply matchers, 333 -- as this often requires to read only metadata; then filterNotTouching 334 -- applies path restrictions which needs to read patch contents 335 doit = 336 fmap (canonizeAfterSplitter . selectedPatches) . 337 selectChanges . filterNotTouching . filterUnwanted . patchChoices 338 339 -- configuration 340 whch = whichChanges psc 341 fs = files psc 342 os = opts psc 343 crit = matchCriterion psc 344 mspl = splitter psc 345 346 -- after selecting with a splitter, the results may not be canonical 347 canonizeAfterSplitter :: (FL p :> FL p) wA wB -> (FL p :> FL p) wA wB 348 canonizeAfterSplitter (x :> y) = 349 let canonizeIfNeeded = maybe id canonizeSplit mspl 350 in canonizeIfNeeded x :> canonizeIfNeeded y 351 352 -- retrieve the results of patch selection 353 selectedPatches :: PatchChoices p wA wB -> (FL p :> FL p) wA wB 354 selectedPatches pc 355 | backward whch = 356 case getChoices pc of 357 fc :> mc :> lc -> mapFL_FL unLabel (fc +>+ mc) :> mapFL_FL unLabel lc 358 | otherwise = 359 case separateFirstFromMiddleLast pc of 360 xs :> ys -> mapFL_FL unLabel xs :> mapFL_FL unLabel ys 361 362 selectChanges :: PatchChoices p wA wB 363 -> PatchSelectionM p IO (PatchChoices p wA wB) 364 selectChanges 365 | interactive os = refineChoices textSelect 366 | otherwise = return . promote 367 368 promote 369 | backward whch = makeEverythingLater 370 | otherwise = makeEverythingSooner 371 demote 372 | backward whch = makeEverythingSooner 373 | otherwise = makeEverythingLater 374 375 filterNotTouching 376 | backward whch = selectNotTouching fs 377 | otherwise = deselectNotTouching fs 378 379 -- when using @--match@, remove unmatched patches 380 -- not depended upon by matched patches 381 filterUnwanted :: PatchChoices p wA wB -> PatchChoices p wA wB 382 filterUnwanted 383 | mcHasNonrange crit = 384 case selectDeps os of 385 NoDeps -> deselectUnwanted 386 _ -> demote . selectWanted 387 | otherwise = id 388 389 selectWanted 390 | backward whch = forceMatchingLast iswanted_ 391 | otherwise = forceMatchingFirst iswanted_ 392 deselectUnwanted 393 | backward whch = forceMatchingFirst (not . iswanted_) 394 | otherwise = forceMatchingLast (not . iswanted_) 395 iswanted_ = mcFunction crit . unLabel 396 397 {- end of runInvertibleSelection -} 398 399-- | The equivalent of 'runSelection' for the @darcs log@ command 400viewChanges :: (ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree) 401 => PatchSelectionOptions -> [Sealed2 p] -> IO () 402viewChanges ps_opts = textView ps_opts Nothing 0 [] 403 404-- | The type of the answers to a "shall I [wiggle] that [foo]?" question 405-- They are found in a [[KeyPress]] bunch, each list representing a set of 406-- answers which belong together 407data KeyPress = KeyPress { kp :: Char 408 , kpHelp :: String } 409 410-- | Generates the help for a set of basic and advanced 'KeyPress' groups. 411helpFor :: String -> [[KeyPress]] -> [[KeyPress]] -> String 412helpFor jn basicKeypresses advancedKeyPresses = 413 unlines $ [ "How to use "++jn++":" ] 414 ++ intercalate [""] (map (map help) keypresses) 415 ++ [ "" 416 , "?: show this help" 417 , "" 418 , "<Space>: accept the current default (which is capitalized)" 419 ] 420 where help i = kp i:(": "++kpHelp i) 421 keypresses = basicKeypresses ++ advancedKeyPresses 422 423-- | The keys used by a list of 'keyPress' groups. 424keysFor :: [[KeyPress]] -> [Char] 425keysFor = concatMap (map kp) 426 427-- | The function for selecting a patch to amend record. Read at your own risks. 428withSelectedPatchFromList 429 :: (Commute p, Matchable p, ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree) 430 => String -- name of calling command (always "amend" as of now) 431 -> RL p wO wR 432 -> PatchSelectionOptions 433 -> (forall wA . (FL p :> p) wA wR -> IO ()) 434 -> IO () 435withSelectedPatchFromList jn patches o job = do 436 sp <- wspfr jn (matchAPatch $ matchFlags o) patches NilFL 437 case sp of 438 Just (FlippedSeal (skipped :> selected')) -> job (skipped :> selected') 439 Nothing -> 440 putStrLn $ "Cancelling " ++ jn ++ " since no patch was selected." 441 442data SkippedReason = SkippedAutomatically | SkippedManually 443 444data WithSkipped p wX wY = WithSkipped 445 { _skippedReason :: SkippedReason 446 , skippedPatch :: p wX wY 447 } 448 449-- | This ensures that the selected patch commutes freely with the skipped 450-- patches, including pending and also that the skipped sequences has an 451-- ending context that matches the recorded state, z, of the repository. 452wspfr :: forall p wX wY wU. 453 (Commute p, Matchable p, ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree) 454 => String 455 -> (forall wA wB . p wA wB -> Bool) 456 -> RL p wX wY 457 -> FL (WithSkipped p) wY wU 458 -> IO (Maybe (FlippedSeal (FL p :> p) wU)) 459wspfr _ _ NilRL _ = return Nothing 460wspfr jn matches remaining@(pps:<:p) skipped 461 | not $ matches p = wspfr jn matches pps 462 (WithSkipped SkippedAutomatically p :>: skipped) 463 | otherwise = 464 case commuteFL (p :> mapFL_FL skippedPatch skipped) of 465 Nothing -> do putStrLn "\nSkipping depended-upon patch:" 466 defaultPrintFriendly p 467 wspfr jn matches pps (WithSkipped SkippedAutomatically p :>: skipped) 468 469 Just (skipped' :> p') -> do 470 defaultPrintFriendly p 471 let repeatThis = do 472 yorn <- promptChar 473 PromptConfig { pPrompt = prompt' 474 , pBasicCharacters = keysFor basicOptions 475 , pAdvancedCharacters = keysFor advancedOptions 476 , pDefault = Just 'n' 477 , pHelp = "?h" } 478 case yorn of 479 'y' -> return $ Just $ flipSeal $ skipped' :> p' 480 'n' -> nextPatch 481 'j' -> nextPatch 482 'k' -> previousPatch remaining skipped 483 'v' -> printContent p >> repeatThis 484 'p' -> printContentWithPager p >> repeatThis 485 'x' -> do printSummary p 486 repeatThis 487 'r' -> defaultPrintFriendly p >> repeatThis 488 'q' -> do putStrLn $ (capitalize jn) ++ " cancelled." 489 exitSuccess 490 _ -> do putStrLn $ helpFor jn basicOptions advancedOptions 491 repeatThis 492 repeatThis 493 where prompt' = "Shall I " ++ jn ++ " this patch?" 494 nextPatch = wspfr jn matches pps (WithSkipped SkippedManually p:>:skipped) 495 previousPatch :: RL p wX wQ 496 -> FL (WithSkipped p) wQ wU 497 -> IO (Maybe (FlippedSeal 498 (FL p :> p) wU)) 499 previousPatch remaining' NilFL = wspfr jn matches remaining' NilFL 500 previousPatch remaining' (WithSkipped sk prev :>: skipped'') = 501 case sk of 502 SkippedManually -> wspfr jn matches (remaining' :<: prev) skipped'' 503 SkippedAutomatically -> previousPatch (remaining' :<: prev) skipped'' 504 basicOptions = 505 [[ KeyPress 'y' (jn ++ " this patch") 506 , KeyPress 'n' ("don't " ++ jn ++ " it") 507 , KeyPress 'j' "skip to next patch" 508 , KeyPress 'k' "back up to previous patch" 509 ]] 510 advancedOptions = 511 [[ KeyPress 'v' "view this patch in full" 512 , KeyPress 'p' "view this patch in full with pager" 513 , KeyPress 'x' "view a summary of this patch" 514 , KeyPress 'r' "view this patch" 515 , KeyPress 'q' ("cancel " ++ jn) 516 ]] 517 defaultPrintFriendly = 518 printFriendly Nothing NormalVerbosity NoSummary NoContext 519 520-- | Runs a function on the underlying @PatchChoices@ object 521liftChoices :: StateT (PatchChoices p wX wY) Identity a 522 -> InteractiveSelectionM p wX wY a 523liftChoices act = do 524 ch <- gets choices 525 let (result, _) = runIdentity $ runStateT act ch 526 modify $ \isc -> isc {choices = ch} -- Should this be ch or the result of runState? 527 return result 528 529-- | @justDone n@ notes that @n@ patches have just been processed 530justDone :: Int -> InteractiveSelectionM p wX wY () 531justDone n = modify $ \isc -> isc{ current = current isc + n} 532 533initialSelectionState :: FL (LabelledPatch p) wX wY 534 -> PatchChoices p wX wY 535 -> InteractiveSelectionState p wX wY 536initialSelectionState lps pcs = 537 ISC { total = lengthFL lps 538 , current = 0 539 , lps = FZipper NilRL lps 540 , choices = pcs 541 } 542 543-- | The actual interactive selection process. 544textSelect :: ( Commute p, Invert p, ShowPatch p, ShowContextPatch p 545 , PatchInspect p, ApplyState p ~ Tree ) 546 => FL (LabelledPatch p) wX wY 547 -> PatchChoices p wX wY 548 -> PatchSelectionM p IO (PatchChoices p wX wY) 549textSelect lps' pcs = 550 choices <$> 551 execStateT (skipMundane >> printCurrent >> textSelectIfAny) 552 (initialSelectionState lps' pcs) 553 where 554 textSelectIfAny = do 555 z <- gets lps 556 unless (rightmost z) $ textSelect' 557 558textSelect' :: ( Commute p, Invert p, ShowPatch p, ShowContextPatch p 559 , PatchInspect p, ApplyState p ~ Tree ) 560 => InteractiveSelectionM p wX wY () 561textSelect' = do 562 z <- gets lps 563 done <- if not $ rightmost z 564 then textSelectOne 565 else lastQuestion 566 unless done $ textSelect' 567 568optionsBasic :: String -> String -> [KeyPress] 569optionsBasic jn aThing = 570 [ KeyPress 'y' (jn++" this "++aThing) 571 , KeyPress 'n' ("don't "++jn++" it") 572 , KeyPress 'w' "wait and decide later, defaulting to no" ] 573 574optionsFile :: String -> [KeyPress] 575optionsFile jn = 576 [ KeyPress 's' ("don't "++jn++" the rest of the changes to this file") 577 , KeyPress 'f' (jn++" the rest of the changes to this file") ] 578 579optionsView :: String -> String -> [KeyPress] 580optionsView aThing someThings = 581 [ KeyPress 'v' ("view this "++aThing++" in full") 582 , KeyPress 'p' ("view this "++aThing++" in full with pager") 583 , KeyPress 'r' ("view this "++aThing) 584 , KeyPress 'l' ("list all selected "++someThings) ] 585 586optionsSummary :: String -> [KeyPress] 587optionsSummary aThing = 588 [ KeyPress 'x' ("view a summary of this "++aThing) ] 589 590optionsQuit :: String -> Bool -> String -> [KeyPress] 591optionsQuit jn allowsa someThings = 592 [ KeyPress 'd' (jn++" selected "++someThings++ 593 ", skipping all the remaining "++someThings) 594 | allowsa ] 595 ++ 596 [ KeyPress 'a' (jn++" all the remaining "++someThings) 597 , KeyPress 'q' ("cancel "++jn) ] 598 599optionsNav :: String -> Bool -> [KeyPress] 600optionsNav aThing isLast= 601 [ KeyPress 'j' ("skip to next "++ aThing) | not isLast ] 602 ++ 603 [ KeyPress 'k' ("back up to previous "++ aThing) 604 , KeyPress 'g' ("start over from the first "++aThing)] 605 606optionsSplit :: Maybe (Splitter a) -> String -> [KeyPress] 607optionsSplit split aThing 608 | Just _ <- split 609 = [ KeyPress 'e' ("interactively edit this "++ aThing) ] 610 | otherwise = [] 611 612optionsLast :: String -> String -> ([[KeyPress]], [[KeyPress]]) 613optionsLast jn aThing = 614 (optionsNav aThing True: 615 [[ KeyPress 'y' "confirm this operation" 616 , KeyPress 'q' ("cancel " ++ jn) ] 617 , [ KeyPress 'l' "list all selected" ] 618 ] 619 ,[[KeyPress 'a' "confirm this operation" 620 , KeyPress 'd' "confirm this operation" 621 , KeyPress 'n' ("cancel " ++ jn) ]]) 622 623options :: (ShowPatch p) 624 => Bool 625 -> InteractiveSelectionM p wX wY ([[KeyPress]],[[KeyPress]]) 626options single = do 627 split <- asks splitter 628 jn <- asks jobname 629 allowsa <- asks allowSkipAll 630 aThing <- thing 631 someThings <- things 632 o <- asks opts 633 return ([optionsBasic jn aThing] 634 ,[optionsSplit split aThing] 635 ++ [optionsFile jn | single] 636 ++ [optionsView aThing someThings ++ 637 if withSummary o == YesSummary 638 then [] 639 else optionsSummary aThing] 640 ++ [optionsQuit jn allowsa someThings] 641 ++ [optionsNav aThing False] 642 ) 643 644-- | Returns a 'Sealed2' version of the patch we are asking the user 645-- about. 646currentPatch :: InteractiveSelectionM p wX wY (Maybe (Sealed2 (LabelledPatch p))) 647currentPatch = focus <$> gets lps 648 649-- | Returns the patches we have yet to ask the user about. 650todo :: InteractiveSelectionM p wX wY (FlippedSeal (FL (LabelledPatch p)) wY) 651todo = jokers <$> gets lps 652 653-- | Modify the underlying @PatchChoices@ by some function 654modifyChoices :: (PatchChoices p wX wY -> PatchChoices p wX wY) 655 -> InteractiveSelectionM p wX wY () 656modifyChoices f = modify $ \isc -> isc{choices = f $ choices isc} 657 658-- | returns @Just f@ if the 'currentPatch' only modifies @f@, 659-- @Nothing@ otherwise. 660currentFile :: (PatchInspect p) 661 => InteractiveSelectionM p wX wY (Maybe AnchoredPath) 662currentFile = do 663 c <- currentPatch 664 return $ case c of 665 Nothing -> Nothing 666 Just (Sealed2 lp) -> 667 case listTouchedFiles lp of 668 [f] -> Just f 669 _ -> Nothing 670 671-- | @decide True@ selects the current patch, and @decide False@ deselects 672-- it. 673decide :: Commute p 674 => Bool 675 -> LabelledPatch p wT wU 676 -> InteractiveSelectionM p wX wY () 677decide takeOrDrop lp = do 678 whch <- asks whichChanges 679 if backward whch == takeOrDrop -- we go backward xor we are dropping 680 then modifyChoices $ forceLast (label lp) 681 else modifyChoices $ forceFirst (label lp) 682 683-- | like 'decide', but for all patches touching @file@ 684decideWholeFile :: (Commute p, PatchInspect p) 685 => AnchoredPath -> Bool -> InteractiveSelectionM p wX wY () 686decideWholeFile path takeOrDrop = 687 do 688 FlippedSeal lps_todo <- todo 689 let patches_to_skip = 690 filterFL (\lp' -> listTouchedFiles lp' == [path]) lps_todo 691 mapM_ (unseal2 $ decide takeOrDrop) patches_to_skip 692 693-- | Undecide the current patch. 694postponeNext :: Commute p => InteractiveSelectionM p wX wY () 695postponeNext = 696 do 697 Just (Sealed2 lp) <- currentPatch 698 modifyChoices $ forceMiddle (label lp) 699 700-- | Focus the next patch. 701skipOne :: InteractiveSelectionM p wX wY () 702skipOne = modify so 703 where so x = x{lps = right (lps x), current = current x +1} 704 705-- | Focus the previous patch. 706backOne :: InteractiveSelectionM p wX wY () 707backOne = modify so 708 where so isc = isc{lps = left (lps isc), current = max (current isc-1) 0} 709 710-- | Split the current patch (presumably a hunk), and add the replace it 711-- with its parts. 712splitCurrent :: Splitter p 713 -> InteractiveSelectionM p wX wY () 714splitCurrent s = do 715 FZipper lps_done (lp:>:lps_todo) <- gets lps 716 case applySplitter s (unLabel lp) of 717 Nothing -> return () 718 Just (text, parse) -> 719 do 720 newText <- liftIO $ editText "darcs-patch-edit" text 721 case parse newText of 722 Nothing -> return () 723 Just ps -> do 724 lps_new <- liftIO $ return $ labelPatches (Just (label lp)) ps 725 modify $ \isc -> isc { total = total isc + lengthFL lps_new - 1 726 , lps = FZipper lps_done 727 (lps_new +>+ lps_todo) 728 , choices = substitute 729 (seal2 (lp :||: lps_new)) 730 (choices isc) 731 } 732 733-- | Print the list of the selected patches. We currently choose to display 734-- them in "commuted" form, that is, in the order in which they have been 735-- selected and with deselected patches moved out of the way. 736printSelected :: (Commute p, ShowPatch p) => InteractiveSelectionM p wX wY () 737printSelected = do 738 someThings <- things 739 o <- asks opts 740 w <- asks whichChanges 741 let showFL = vcat . mapFL (showFriendly (verbosity o) (withSummary o) . unLabel) 742 (first_chs :> _ :> last_chs) <- getChoices <$> gets choices 743 liftIO $ putDocLnWith fancyPrinters $ vcat 744 [ greenText $ "---- selected "++someThings++" ----" 745 , if backward w then showFL last_chs else showFL first_chs 746 , greenText $ "---- end of selected "++someThings++" ----" 747 ] 748 749-- | Skips all remaining patches. 750skipAll :: InteractiveSelectionM p wX wY () 751skipAll = modify $ \isc -> isc {lps = toEnd $ lps isc} 752 753backAll :: InteractiveSelectionM p wX wY () 754backAll = modify $ \isc -> isc {lps = toStart $ lps isc 755 ,current = 0} 756 757isSingleFile :: PatchInspect p => p wX wY -> Bool 758isSingleFile p = length (listTouchedFiles p) == 1 759 760askConfirmation :: InteractiveSelectionM p wX wY () 761askConfirmation = do 762 jn <- asks jobname 763 liftIO $ when (jn `elem` ["unpull", "unrecord", "obliterate"]) $ do 764 yorn <- askUser $ "Really " ++ jn ++ " all undecided patches? " 765 case yorn of 766 ('y':_) -> return () 767 _ -> exitSuccess 768 769-- | The singular form of the noun for items of type @p@. 770thing :: (ShowPatch p) => InteractiveSelectionM p wX wY String 771thing = (Darcs.Patch.thing . helper) `liftM` gets choices 772 where 773 helper :: PatchChoices p wA wB -> p wA wB 774 helper = undefined 775 776-- | The plural form of the noun for items of type @p@. 777things :: (ShowPatch p) => InteractiveSelectionM p wX wY String 778things = (Darcs.Patch.things . helper) `liftM` gets choices 779 where 780 helper :: PatchChoices p wA wB -> p wA wB 781 helper = undefined 782 783-- | The question to ask about one patch. 784prompt :: (ShowPatch p) => InteractiveSelectionM p wX wY String 785prompt = do 786 jn <- asks jobname 787 aThing <- thing 788 n <- gets current 789 n_max <- gets total 790 return $ "Shall I "++jn++" this "++aThing++"? " 791 ++ "(" ++ show (n+1) ++ "/" ++ show n_max ++ ") " 792 793-- | Asks the user about one patch, returns their answer. 794promptUser :: (ShowPatch p) 795 => Bool -> Char -> InteractiveSelectionM p wX wY Char 796promptUser single def = do 797 thePrompt <- prompt 798 (basicOptions,advancedOptions) <- options single 799 liftIO $ promptChar PromptConfig { pPrompt = thePrompt 800 , pBasicCharacters = keysFor basicOptions 801 , pAdvancedCharacters = keysFor advancedOptions 802 , pDefault = Just def 803 , pHelp = "?h" 804 } 805 806-- | Ask the user what to do with the next patch. 807textSelectOne :: ( Commute p, ShowPatch p, ShowContextPatch p, PatchInspect p 808 , ApplyState p ~ Tree ) 809 => InteractiveSelectionM p wX wY Bool 810textSelectOne = do 811 c <- currentPatch 812 case c of 813 Nothing -> return False 814 Just (Sealed2 lp) -> 815 do 816 jn <- asks jobname 817 spl <- asks splitter 818 whichch <- asks whichChanges 819 let singleFile = isSingleFile (unLabel lp) 820 p = unLabel lp 821 (basicOptions,advancedOptions) <- options singleFile 822 theSlot <- liftChoices $ state $ patchSlot lp 823 let the_default = getDefault (backward whichch) theSlot 824 yorn <- promptUser singleFile the_default 825 let nextPatch = skipMundane >> printCurrent 826 case yorn of 827 'y' -> decide True lp >> skipOne >> nextPatch 828 >> return False 829 'n' -> decide False lp >> skipOne >> nextPatch 830 >> return False 831 'w' -> postponeNext >> skipOne >> nextPatch 832 >> return False 833 'e' | (Just s) <- spl -> splitCurrent s >> printCurrent 834 >> return False 835 's' -> currentFile >>= maybe 836 (return ()) 837 (\f -> decideWholeFile f False) >> nextPatch 838 >> return False 839 'f' -> currentFile >>= maybe 840 (return ()) 841 (\f -> decideWholeFile f True) >> nextPatch 842 >> return False 843 'v' -> liftIO $ printContent p >> return False 844 'p' -> liftIO $ printContentWithPager p >> return False 845 'r' -> printCurrent >> return False 846 'l' -> printSelected >> printCurrent >> return False 847 'x' -> liftIO $ printSummary p >> return False 848 'd' -> skipAll >> return True 849 'g' -> backAll >> printCurrent >> return False 850 'a' -> 851 do 852 askConfirmation 853 modifyChoices $ selectAllMiddles (backward whichch) 854 skipAll 855 return True 856 'q' -> liftIO $ 857 do putStrLn $ capitalize jn ++ " cancelled." 858 exitSuccess 859 'j' -> skipOne >> printCurrent >> return False 860 'k' -> backOne >> printCurrent >> return False 861 _ -> do 862 liftIO . putStrLn $ helpFor jn basicOptions advancedOptions 863 return False 864 865lastQuestion :: (Commute p, ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree) 866 => InteractiveSelectionM p wX wY Bool 867lastQuestion = do 868 jn <- asks jobname 869 theThings <-things 870 aThing <- thing 871 let (basicOptions, advancedOptions) = optionsLast jn aThing 872 yorn <- liftIO . promptChar $ 873 PromptConfig { pPrompt = "Do you want to "++capitalize jn++ 874 " these "++theThings++"?" 875 , pBasicCharacters = "yglqk" 876 , pAdvancedCharacters = "dan" 877 , pDefault = Just 'y' 878 , pHelp = "?h"} 879 case yorn of c | c `elem` "yda" -> return True 880 | c `elem` "qn" -> liftIO $ 881 do putStrLn $ jn ++" cancelled." 882 exitSuccess 883 'g' -> backAll >> printCurrent >> return False 884 'l' -> printSelected >> return False 885 'k' -> backOne >> printCurrent >> return False 886 _ -> do 887 liftIO . putStrLn $ helpFor "this confirmation prompt" 888 basicOptions advancedOptions 889 return False 890 891-- | Shows the current patch as it should be seen by the user. 892printCurrent :: (ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree) 893 => InteractiveSelectionM p wX wY () 894printCurrent = do 895 o <- asks opts 896 pr <- asks pristine 897 c <- currentPatch 898 case c of 899 Nothing -> return () 900 Just (Sealed2 lp) -> 901 liftIO $ printFriendly pr (verbosity o) (withSummary o) (withContext o) $ unLabel lp 902 903-- | The interactive part of @darcs changes@ 904textView :: (ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree) 905 => PatchSelectionOptions -> Maybe Int -> Int 906 -> [Sealed2 p] -> [Sealed2 p] 907 -> IO () 908textView _ _ _ _ [] = return () 909textView o n_max n 910 ps_done ps_todo@(p:ps_todo') = do 911 defaultPrintFriendly p 912 repeatThis -- prompt the user 913 where 914 defaultPrintFriendly = 915 unseal2 (printFriendly Nothing (verbosity o) (withSummary o) (withContext o)) 916 prev_patch :: IO () 917 prev_patch = case ps_done of 918 [] -> repeatThis 919 (p':ps_done') -> 920 textView o 921 n_max (n-1) ps_done' (p':ps_todo) 922 next_patch :: IO () 923 next_patch = case ps_todo' of 924 [] -> -- May as well work out the length now we have all 925 -- the patches in memory 926 textView o n_max 927 n ps_done [] 928 _ -> textView o n_max 929 (n+1) (p:ps_done) ps_todo' 930 first_patch = textView o n_max 0 [] (ps_done++ps_todo) 931 options_yn = 932 [ KeyPress 'y' "view this patch and go to the next" 933 , KeyPress 'n' "skip to the next patch" ] 934 optionsView' = 935 [ KeyPress 'v' "view this patch in full" 936 , KeyPress 'p' "view this patch in full with pager" 937 , KeyPress 'r' "view this patch" ] 938 optionsSummary' = 939 [ KeyPress 'x' "view a summary of this patch" ] 940 optionsNav' = 941 [ KeyPress 'q' "quit view changes" 942 , KeyPress 'k' "back up to previous patch" 943 , KeyPress 'j' "skip to next patch" 944 , KeyPress 'g' "start over from the first patch" 945 , KeyPress 'c' "count total patch number" ] 946 basicOptions = [ options_yn ] 947 advancedOptions = 948 (optionsView' ++ 949 if withSummary o == YesSummary then [] else optionsSummary') 950 : [ optionsNav' ] 951 prompt' = "Shall I view this patch? " 952 ++ "(" ++ show (n+1) ++ "/" ++ maybe "?" show n_max ++ ")" 953 repeatThis :: IO () 954 repeatThis = do 955 yorn <- promptChar (PromptConfig prompt' (keysFor basicOptions) (keysFor advancedOptions) (Just 'n') "?h") 956 case yorn of 957 'y' -> unseal2 printContent p >> next_patch 958 'n' -> next_patch 959 'v' -> unseal2 printContent p >> repeatThis 960 'p' -> unseal2 printContentWithPager p >> repeatThis 961 'r' -> do defaultPrintFriendly p 962 repeatThis 963 'x' -> do unseal2 printSummary p 964 repeatThis 965 'q' -> exitSuccess 966 'k' -> prev_patch 967 'j' -> next_patch 968 'g' -> first_patch 969 'c' -> textView o 970 count_n_max n ps_done ps_todo 971 _ -> do putStrLn $ helpFor "view changes" basicOptions advancedOptions 972 repeatThis 973 count_n_max | isJust n_max = n_max 974 | otherwise = Just $ length ps_done + length ps_todo 975 976-- | Skips patches we should not ask the user about 977skipMundane :: (Commute p, ShowPatch p) 978 => InteractiveSelectionM p wX wY () 979skipMundane = do 980 (FZipper lps_done lps_todo) <- gets lps 981 o <- asks opts 982 crit <- asks matchCriterion 983 jn <- asks jobname 984 (skipped :> unskipped) <- liftChoices $ spanFL_M 985 (state . patchSlot >=> return . decided) 986 lps_todo 987 let numSkipped = lengthFL skipped 988 when (numSkipped > 0) . liftIO $ show_skipped o jn numSkipped skipped 989 let boringThenInteresting = 990 if selectDeps o == AutoDeps 991 then spanFL (not . mcFunction crit . unLabel) unskipped 992 else NilFL :> unskipped 993 case boringThenInteresting of 994 boring :> interesting -> 995 do 996 justDone $ lengthFL boring + numSkipped 997 modify $ \isc -> isc {lps = FZipper (lps_done +<<+ skipped +<<+ boring) 998 interesting} 999 where 1000 show_skipped o jn n ps = do putStrLn $ _nevermind_ jn ++ _these_ n ++ "." 1001 when (verbosity o == Verbose) $ 1002 showskippedpatch ps 1003 _nevermind_ jn = "Will not ask whether to " ++ jn ++ " " 1004 _these_ n = show n ++ " already decided " ++ _elem_ n "" 1005 _elem_ n = englishNum n (Noun "patch") 1006 showskippedpatch :: ShowPatch p => FL (LabelledPatch p) wY wT -> IO () 1007 showskippedpatch = 1008 putDocLnWith fancyPrinters . vcat . mapFL (showFriendly NormalVerbosity NoSummary . unLabel) 1009 1010decided :: Slot -> Bool 1011decided InMiddle = False 1012decided _ = True 1013 1014-- | The action bound to space, depending on the current status of the 1015-- patch. 1016getDefault :: Bool -> Slot -> Char 1017getDefault _ InMiddle = 'w' 1018getDefault True InFirst = 'n' 1019getDefault True InLast = 'y' 1020getDefault False InFirst = 'y' 1021getDefault False InLast = 'n' 1022 1023askAboutDepends :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) 1024 => Repository rt p wR wU wT -> FL (PrimOf p) wT wY 1025 -> PatchSelectionOptions 1026 -> [PatchInfo] -> IO [PatchInfo] 1027askAboutDepends repository pa' ps_opts olddeps = do 1028 -- Ideally we'd just default the olddeps to yes but still ask about them. 1029 -- SelectChanges doesn't currently (17/12/09) offer a way to do this so would 1030 -- have to have this support added first. 1031 pset <- readTentativeRepo repository (repoLocation repository) 1032 -- Let the user select only from patches after the last clean tag. 1033 -- We do this for efficiency, otherwise independentPatchIds can 1034 -- take a /very/ long time to finish. The limitation this imposes 1035 -- is a bit arbitrary from a user perspective. Note however that 1036 -- contextPatches at least gives us this latest clean tag to select. 1037 _ :> untagged <- return $ contextPatches pset 1038 -- Note: using anonymous here seems to be safe since we don't store any patches 1039 -- and only return a list of PatchInfo 1040 pa <- n2pia . flip adddeps olddeps <$> anonymous pa' 1041 -- get rid of all (implicit and explicit) dependencies of pa 1042 _ :> _ :> non_deps <- return $ commuteWhatWeCanRL (untagged :> pa) 1043 candidates :> _ <- 1044 runSelection (reverseRL non_deps) $ 1045 selectionConfig FirstReversed "depend on" ps_opts 1046 { matchFlags = [], interactive = True } Nothing Nothing 1047 return $ olddeps `union` independentPatchIds (reverseFL candidates) 1048 1049-- | From an 'RL' of patches select the identities of those that are 1050-- not depended upon by later patches. 1051independentPatchIds :: (Commute p, Ident p) => RL p wX wY -> [PatchId p] 1052independentPatchIds NilRL = [] 1053independentPatchIds (ps :<: p) = 1054 case commuteWhatWeCanRL (ps :> p) of 1055 _ :> _ :> non_deps -> 1056 ident p : independentPatchIds non_deps 1057