% Copyright (C) 2002-2003 David Roundy % % This program is free software; you can redistribute it and/or modify % it under the terms of the GNU General Public License as published by % the Free Software Foundation; either version 2, or (at your option) % any later version. % % This program is distributed in the hope that it will be useful, % but WITHOUT ANY WARRANTY; without even the implied warranty of % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the % GNU General Public License for more details. % % You should have received a copy of the GNU General Public License % along with this program; see the file COPYING. If not, write to % the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, % Boston, MA 02110-1301, USA. \begin{code} {-# OPTIONS -fffi #-} module SelectChanges ( with_selected_changes, with_selected_changes_to_files, with_selected_last_changes_to_files, with_selected_changes_reversed, with_selected_last_changes_reversed, view_changes, #ifdef HAVEWX gui_change_selector, selected_patches, #endif with_selected_patch_from_repo, promptChar, ) where #ifdef HAVEWX import Graphics.UI.WX ( widget, floatLeft, staticText, command, on, set, checked, get, clientSize, bestSize, Layout, Window, CheckBox, ScrolledWindow, Prop((:=)), Widget, container, row, sz, checkBox, column, layout, rigid, scrolledWindow, scrollRate, fill, hspace, hglue, margin, close, button, frame, panel, start, closing, propagateEvent, ) import qualified Graphics.UI.WX ( text ) import Graphics.UI.WXCore ( windowSetSizeHints ) import Data.IORef import Patch ( patch_description ) import Printer ( renderString ) import Repository ( takeRepoGuiLock, releaseRepoGuiLock ) #endif import IO hiding ( bracket ) import System.IO ( hIsTerminalDevice ) import Control.Exception ( bracket ) import Maybe ( catMaybes ) import Char ( toUpper ) import Monad ( when ) import System ( exitWith, ExitCode(ExitSuccess) ) import Repository ( identifyRepository, read_repo, read_pending ) import Patch ( Patch, patch2patchinfo, is_similar, patch_summary, commute, join_patches, invert, null_patch, ) import PatchInfo ( PatchInfo, human_friendly ) import PatchChoices ( PatchChoices, patch_choices, patch_choices_tps, force_first, force_last, make_uncertain, is_patch_first, separate_first_middle_from_last, separate_first_from_middle_last, separate_middle_last_from_first, select_all_middles, separate_last_from_first_middle, force_matching_first, make_everything_later, TaggedPatch, tp_patch, ) import TouchesFiles ( deselect_not_touching, select_not_touching ) import PrintPatch ( printPatch, printPatchPager ) import SlurpDirectory ( Slurpy ) import Match ( have_nonrange_match, match_a_patch, doesnt_not_match ) import DarcsFlags ( DarcsFlag( DryRun, All, Summary #ifdef HAVEWX , Gui, SubGui #endif ) ) import DarcsUtils ( askUser ) import Printer ( text, prefix, ($$), (<>), errorDoc, putDocLn ) import RawMode ( get_raw_mode, set_raw_mode ) #include "impossible.h" \end{code} \begin{code} type WithPatches a = String -- ^ jobname -> [DarcsFlag] -- ^ opts -> Slurpy -- ^ directory -> [Patch] -- ^ patches to select among -> Maybe Int -- ^ number of patches (if known) -> (([Patch],[Patch]) -> IO a) -- ^ job -> IO a -- ^ result of running job -- | The only difference with 'WithPatches' is the [FilePath] argument type WithPatchesToFiles a = String -- ^ jobname -> [DarcsFlag] -- ^ opts -> Slurpy -- ^ directory -> [FilePath] -- ^ files -> [Patch] -- ^ patches to select among -> Maybe Int -- ^ number of patches (if known) -> (([Patch],[Patch]) -> IO a) -- ^ job -> IO a -- ^ result of running job with_selected_changes :: WithPatches a with_selected_changes_to_files :: WithPatchesToFiles a with_selected_last_changes_to_files :: WithPatchesToFiles a with_selected_changes_reversed :: WithPatches a with_selected_last_changes_reversed :: WithPatches a with_selected_changes = wasc False False False with_selected_changes_to_files = wasc_ False False False with_selected_last_changes_to_files = wasc_ True False False with_selected_changes_reversed = wasc True True False with_selected_last_changes_reversed = wasc False True False -- | wasc and wasc_ are just shorthand for with_any_selected_changes wasc :: Bool -> Bool -> Bool -> WithPatches a wasc_ :: Bool -> Bool -> Bool -> WithPatchesToFiles a wasc v l r j o s = wasc_ v l r j o s [] wasc_ = with_any_selected_changes with_any_selected_changes :: Bool -- ^ is last -> Bool -- ^ is reversed -> Bool -- ^ view only -> WithPatchesToFiles a with_selected_patch_from_repo :: String -> [DarcsFlag] -> Bool -> ((Patch,[Patch]) -> IO ()) -> IO () view_changes :: [DarcsFlag] -> Slurpy -> [FilePath] -> [Patch] -> Maybe Int -> IO () view_changes opts s fp ps m_ps_len = wasc_ False False True "view changes" opts s fp ps m_ps_len (\(_,_) -> return ()) \end{code} \begin{code} #ifdef HAVEWX gui_select :: Bool -> Bool -> String -> [DarcsFlag] -> [Patch] -> (([Patch],[Patch]) -> IO a) -> IO a gui_select islast isreversed jn opts rawPs job = do if SubGui `elem` opts then gs else start gs exitWith ExitSuccess -- Note that this exit is ignored if running under SubGui mode. Why do we exit? -- Because we need to return (IO a), and throwing an exception seems to be the -- only way to do this. where gs = do takeRepoGuiLock f <- frame [Graphics.UI.WX.text := cap_jn] let (ps, other_ps) = patches_to_consider islast isreversed [] opts rawPs (init_pc, init_tps) = patch_choices_tps ps pc <- newIORef init_pc p <- panel f [] scrolled <- gui_change_selector islast isreversed p pc init_tps quit <- button f [Graphics.UI.WX.text := "Cancel", on command := close f] bs <- get quit bestSize set quit [clientSize := bs] rec <- button f [Graphics.UI.WX.text := cap_jn, on command := do rpc <- readIORef pc job $ selected_patches islast isreversed other_ps rpc close f ] set rec [clientSize := bs] set f [layout := column 0 [fill $ container p $ fill $ widget scrolled, margin 5 $ row 5 [hglue, widget quit, widget rec,hspace 20]], clientSize := sz 600 400, -- this is window actual size on closing := releaseRepoGuiLock >> propagateEvent ] where cap_jn = (toUpper $ head jn) : tail jn gui_change_selector :: Bool -- is last -> Bool -- is inverted -> Window a -- parent window -> IORef PatchChoices -> [TaggedPatch] -> IO (ScrolledWindow ()) gui_change_selector islast isinverted w pc ps = do scrolled <- scrolledWindow w [scrollRate := sz 20 20] let pgui = boxpatch scrolled -- just to get the right patch description view = if isinverted then invert else id guibps <- mapM (pgui.view.tp_patch) ps set_callbacks islast pc $ zip (map fst guibps) ps set scrolled [layout := rigid $ column 0 $ map bps2l guibps] windowSetSizeHints scrolled (-1) (-1) (-1) (-1) (-1) (-1) set scrolled [clientSize := sz 40 20] -- this is minimum size return scrolled bps2l :: Widget w => (w, Layout) -> Layout bps2l (x,y) = row 0 [widget x, y] boxpatch :: Window a -> Patch -> IO (CheckBox (), Layout) boxpatch w p = do gp <- guipatch w p b <- checkBox w [] bs <- get b bestSize set b [clientSize := bs] return (b,gp) set_callbacks :: Bool -> IORef PatchChoices -> [(CheckBox (),TaggedPatch)] -> IO () set_callbacks islast pc cps = sequence_ $ map set_cmd cps where setstate rpc (cb,p) = set cb [checked := is_patch_first p rpc == Just (not islast)] update_state = do real_pc <- readIORef pc sequence_ $ map (setstate real_pc) cps force_yes = if islast then force_last else force_first force_no = if islast then force_first else force_last the_cmd (cb,p) = do am_checked <- get cb checked if am_checked then modifyIORef pc $ force_yes p else modifyIORef pc $ force_no p update_state set_cmd (cb,p) = set cb [on command := the_cmd (cb,p)] guipatch :: Window a -> Patch -> IO Layout guipatch w p = do st <- staticText w [Graphics.UI.WX.text := detab $ renderString $ patch_description p] return $ floatLeft $ widget st where detab = concatMap detabChar detabChar '\t' = take 8 $ repeat ' ' detabChar x = [x] #endif \end{code} \begin{code} with_selected_patch_from_repo jn opts ignore_pending job = do repository <- identifyRepository "." p_s <- read_repo repository pend <- if ignore_pending then return $ Just null_patch else read_pending repository sp <- without_buffering $ wspfr jn (doesnt_not_match opts) (concat p_s) [join_patches $ catMaybes [pend]] case sp of Just (selected, s_and_pend) -> case (last s_and_pend, init s_and_pend) of (pend',skipped) -> case commute (selected, pend') of Just (_, selected') -> job (selected', skipped) Nothing -> impossible Nothing -> do putStrLn $ "Cancelling "++jn++" since no patch was selected." exitWith $ ExitSuccess without_buffering :: IO a -> IO a without_buffering job = do bracket nobuf rebuf $ \_ -> job where nobuf = do is_term <- hIsTerminalDevice stdin bi <- hGetBuffering stdin raw <- get_raw_mode when is_term $ do hSetBuffering stdin NoBuffering `catch` \_ -> return () set_raw_mode True return (bi,raw) rebuf (bi,raw) = do is_term <- hIsTerminalDevice stdin #if SYS == windows buffers <- hGetBuffering stdin hSetBuffering stdin NoBuffering `catch` \_ -> return () drop_returns hSetBuffering stdin buffers `catch` \_ -> return () #else drop_returns #endif when is_term $ do hSetBuffering stdin bi `catch` \_ -> return () set_raw_mode raw drop_returns = do is_ready <- hReady stdin when is_ready $ do c <- hLookAhead stdin `catch` \_ -> return ' ' when (c == '\n') $ do getChar drop_returns wspfr :: String -> ((PatchInfo, Maybe Patch) -> Bool) -> [(PatchInfo, Maybe Patch)] -> [Patch] -> IO (Maybe (Patch, [Patch])) wspfr _ _ [] _ = return Nothing wspfr jn matches ((pinf, Just p):pps) skipped | not $ matches (pinf, Just p) = wspfr jn matches pps (p:skipped) | otherwise = case commute_by (skipped, p) of Nothing -> do putStr "\nSkipping depended-upon patch:" print_p [] p wspfr jn matches pps (p:skipped) Just (p', skipped') -> do print_p [] p let prompt = "Shall I "++jn++" this patch?" yorn <- promptCharFancy prompt "ynvpq" (Just 'n') True case yorn of 'y' -> return $ Just (p', skipped') 'n' -> wspfr jn matches pps (p:skipped) 'v' -> do printPatch p wspfr jn matches ((pinf, Just p):pps) skipped 'p' -> do printPatchPager p wspfr jn matches ((pinf, Just p):pps) skipped 'q' -> do putStrLn $ jn_cap++" cancelled." exitWith $ ExitSuccess _ -> do putStr $ wspfr_help jn wspfr jn matches ((pinf, Just p):pps) skipped where jn_cap = (toUpper $ head jn) : tail jn wspfr jn _ ((pinf, Nothing):_) _ = errorDoc $ text "" $$ text ("Can't " ++ jn ++ " patch") $$ human_friendly pinf $$ text "since I can't read it." $$ text "" $$ text "The most likely reason is that you are using a 'partial'" <> text "repository that doesn't contain this patch." commute_by :: ([Patch], Patch) -> Maybe (Patch, [Patch]) commute_by ([], a) = Just (a, []) commute_by (p:ps, a) = case commute (p, a) of Nothing -> Nothing Just (a', p') -> case commute_by (ps, a') of Nothing -> Nothing Just (a'', ps') -> Just (a'', p':ps') wspfr_help :: String -> String wspfr_help jn = "How to use "++jn++":\n"++ "y: "++jn++" this patch\n"++ "n: don't "++jn++" it\n"++ "v: view this patch in full\n"++ "p: view this patch in full with pager\n"++ "q: cancel "++jn++"\n\n"++ "h or ?: show this help\n"++ "\n: accept the current default (which is capitalized)\n" \end{code} \begin{code} with_any_selected_changes islast isreversed viewonly jobname opts _ fs ps m_ps_len job = if All `elem` opts || DryRun `elem` opts then job $ case (islast, isreversed) of (True, False) -> (ps_to_consider, other_ps) (False, False) -> (other_ps, ps_to_consider) (True, True) -> (reverse_invert other_ps, reverse_invert ps_to_consider) (False, True) -> (reverse_invert ps_to_consider, reverse_invert other_ps) else #ifdef HAVEWX if Gui `elem` opts then gui_select islast isreversed jobname opts ps job else #endif do pc <- without_buffering $ if not viewonly then tentatively_text_select jobname islast isreversed opts ps_len ps_len_calced 0 [] init_tps init_pc else text_view jobname islast isreversed opts ps_len ps_len_calced 0 [] init_tps init_pc job $ selected_patches islast isreversed other_ps pc where (ps_to_consider, other_ps) = patches_to_consider islast isreversed fs opts ps (init_pc, init_tps) = patch_choices_tps ps_to_consider (ps_len, ps_len_calced) = if null fs && not (have_nonrange_match opts) then case m_ps_len of Just l -> (l , True) Nothing -> (length ps , False) else (length ps_to_consider, False) patches_to_consider :: Bool -- ^ is last -> Bool -- ^ is reversed -> [FilePath] -- ^ files -> [DarcsFlag] -- ^ opts -> [Patch] -- ^ patches -> ([Patch],[Patch]) patches_to_consider islast isreversed fs opts ps = let cleanup = if isreversed then reverse_invert else id ps' = cleanup ps f = if islast then separate_middle_last_from_first else separate_first_middle_from_last deal_with_fs = if islast then select_not_touching fs else deselect_not_touching fs deselect_unwanted pc = if have_nonrange_match opts then if islast then bug "don't support patch matching with islast in wasp" else make_everything_later $ force_matching_first iswanted pc else pc iswanted = let maybe_invert = if isreversed then invert else id in (match_a_patch opts . maybe_invert . tp_patch) in if null fs && not (have_nonrange_match opts) then (ps', []) else tp_patches $ f $ deal_with_fs $ deselect_unwanted $ patch_choices ps' -- | Returns the results of a patch selection user interaction selected_patches :: Bool -> Bool -> [Patch] -- ^ patches set aside -> PatchChoices -> ([Patch],[Patch]) selected_patches islast isreversed other_ps pc = case (islast, isreversed) of (True, False) -> case separate_last_from_first_middle pc of (xs, ys) -> (map tp_patch xs, other_ps ++ map tp_patch ys) (False, False) -> case separate_first_from_middle_last pc of (xs, ys) -> (map tp_patch ys ++ other_ps, map tp_patch xs) (True, True) -> case separate_first_middle_from_last pc of (xs, ys) -> length xs `seq` -- Aaack, ugly hack here... (reverse_invert (other_ps ++ map tp_patch xs), reverse_invert (map tp_patch ys)) (False, True) -> case separate_first_from_middle_last pc of (xs, ys) -> (reverse_invert (map tp_patch xs), reverse_invert (map tp_patch ys ++ other_ps)) text_select :: String -> Bool -> Bool -> [DarcsFlag] -> Int -> Bool -> Int -> [TaggedPatch] -> [TaggedPatch] -> PatchChoices -> IO PatchChoices text_select _ _ _ _ _ _ _ _ [] pc = return pc text_select jn islast isinverted opts n_max n_max_calced n tps_done tps_todo@(tp:tps_todo') pc = do print_p opts viewp let keys = "ynw" ++ (if patch2patchinfo (tp_patch tp) == Nothing then "sf" else if Summary `elem` opts then "vp" else "vpx") ++ "qadjk" ++ (if n_max_calced then "" else "c") let prompt = "Shall I "++jn++" this "++thing++"? " ++ "(" ++ show (n+1) ++ "/" ++ (if n_max_calced then show n_max else "?") ++ ") " yorn <- promptCharFancy prompt keys (Just the_default) True let do_next = tentatively_text_select jn islast isinverted opts n_max n_max_calced (n+1) (tp:tps_done) tps_todo' repeat_this = text_select jn islast isinverted opts n_max n_max_calced n tps_done tps_todo pc case yorn of 'y' -> do_next $ force_yes tp pc 'n' -> do_next $ force_no tp pc 's' -> do_next $ skip_file 'f' -> do_next $ do_file 'v' -> do printPatch viewp repeat_this 'p' -> do printPatchPager viewp repeat_this 'x' -> do putDocLn $ prefix " " $ patch_summary viewp repeat_this 'w' -> do_next $ make_uncertain tp pc 'k' -> case tps_done of [] -> repeat_this (tp':tps_done') -> text_select jn islast isinverted opts n_max n_max_calced (n-1) tps_done' (tp':tps_todo) pc 'd' -> return pc 'a' -> do ask_confirmation return $ select_all_middles islast pc 'q' -> do putStrLn $ jn_cap++" cancelled." exitWith $ ExitSuccess 'j' -> case tps_todo' of [] -> -- May as well work out the length now we have all -- the patches in memory text_select jn islast isinverted opts n_max True n tps_done tps_todo pc _ -> text_select jn islast isinverted opts n_max n_max_calced (n+1) (tp:tps_done) tps_todo' pc 'c' -> text_select jn islast isinverted opts n_max True n tps_done tps_todo pc _ -> do putStr $ text_select_help opts jn (tp_patch tp) n_max_calced repeat_this where force_yes = if islast then force_last else force_first force_no = if islast then force_first else force_last patches_to_skip = (tp:) $ filter (is_similar (tp_patch tp) . tp_patch) $ tps_todo' skip_file = foldr force_no pc patches_to_skip do_file = foldr force_yes pc patches_to_skip the_default = get_default islast $ is_patch_first tp pc jn_cap = (toUpper $ head jn) : tail jn viewp = if isinverted then invert (tp_patch tp) else tp_patch tp thing = if patch2patchinfo (tp_patch tp) == Nothing then "change" else "patch" ask_confirmation = if jn `elem` ["unpull", "unrecord", "obliterate"] then do yorn <- askUser $ "Really " ++ jn ++ " all undecided patches? " case yorn of ('y':_) -> return () _ -> exitWith $ ExitSuccess else return () text_view :: String -> Bool -> Bool -> [DarcsFlag] -> Int -> Bool -> Int -> [TaggedPatch] -> [TaggedPatch] -> PatchChoices -> IO PatchChoices text_view _ _ _ _ _ _ _ _ [] _ = return $ patch_choices [] --return pc text_view jn islast isinverted opts n_max n_max_calced n tps_done tps_todo@(tp:tps_todo') pc = do print_p opts viewp let keys = "yn" ++ (if patch2patchinfo (tp_patch tp) == Nothing then "sf" else if Summary `elem` opts then "vp" else "vpx") ++ "qjk" ++ (if n_max_calced then "" else "c") prompt = "Shall I continue to "++jn++"? " ++ "(" ++ show (n+1) ++ "/" ++ (if n_max_calced then show n_max else "?") ++ ")" yorn <- promptCharFancy prompt keys (Just the_default) True putStr "\n" let repeat_this = text_view jn islast isinverted opts n_max n_max_calced n tps_done tps_todo pc next_patch = case tps_todo' of [] -> -- May as well work out the length now we have all -- the patches in memory text_view jn islast isinverted opts n_max True n tps_done tps_todo' pc _ -> text_view jn islast isinverted opts n_max n_max_calced (n+1) (tp:tps_done) tps_todo' pc case yorn of 'y' -> next_patch 'n' -> do exitWith $ ExitSuccess 'v' -> do printPatch viewp repeat_this 'p' -> do printPatchPager viewp repeat_this 'x' -> do putDocLn $ prefix " " $ patch_summary viewp repeat_this 'k' -> case tps_done of [] -> repeat_this (tp':tps_done') -> text_view jn islast isinverted opts n_max n_max_calced (n-1) tps_done' (tp':tps_todo) pc 'q' -> do exitWith $ ExitSuccess 'j' -> next_patch 'c' -> text_view jn islast isinverted opts n_max True n tps_done tps_todo pc _ -> do putStr $ text_view_help opts jn n_max_calced repeat_this where the_default = 'y' viewp = if isinverted then invert (tp_patch tp) else tp_patch tp print_p :: [DarcsFlag] -> Patch -> IO () print_p opts p = case patch2patchinfo p of Nothing -> printPatch p Just pinf -> do putDocLn $ text "" $$ human_friendly pinf when (Summary `elem` opts) $ putDocLn $ prefix " " $ patch_summary p tentatively_text_select :: String -> Bool -> Bool -> [DarcsFlag] -> Int -> Bool -> Int -> [TaggedPatch] -> [TaggedPatch] -> PatchChoices -> IO PatchChoices tentatively_text_select _ _ _ _ _ _ _ _ [] pc = return pc tentatively_text_select jn islast isinverted opts n_max n_max_calced n ps_done ps_todo@(p:ps_todo') pc | is_patch_first p pc /= Nothing = tentatively_text_select jn islast isinverted opts n_max n_max_calced (n+1) (p:ps_done) ps_todo' pc | otherwise = text_select jn islast isinverted opts n_max n_max_calced n ps_done ps_todo pc get_default :: Bool -> Maybe Bool -> Char get_default _ Nothing = 'w' get_default True (Just True) = 'n' get_default True (Just False) = 'y' get_default False (Just True) = 'y' get_default False (Just False) = 'n' text_select_help :: [DarcsFlag] -> String -> Patch -> Bool -> String text_select_help opts jn p n_max_calced = "How to use "++jn++"...\n"++ "y: "++jn++" this patch\n"++ "n: don't "++jn++" it\n"++ "w: wait and decide later, defaulting to no\n\n"++ (if patch2patchinfo p == Nothing then "s: don't "++jn++" the rest of the changes to this file\n"++ "f: "++jn++" the rest of the changes to this file\n\n" else "v: view this patch in full\n"++ "p: view this patch in full with pager\n"++ if Summary `elem` opts then "" else "x: view a summary of this patch\n\n") ++"d: "++jn++" selected patches, skipping all the remaining patches\n"++ "a: "++jn++" all the remaining patches\n"++ "q: cancel "++jn++"\n\n"++ "j: skip to next patch\n"++ "k: back up to previous patch\n"++ (if n_max_calced then "" else "c: calculate number of patches\n")++ "h or ?: show this help\n"++ "\n: accept the current default (which is capitalized)\n" text_view_help :: [DarcsFlag] -> String -> Bool -> String text_view_help opts jn n_max_calced = "How to "++jn++"...\n"++ "y: skip to the next patch\n"++ "n: quit "++jn++"\n\n"++ "v: view this patch in full\n"++ "p: view this patch in full with pager\n"++ (if Summary `elem` opts then "" else "x: view a summary of this patch\n\n")++ "q: quit "++jn++"\n\n"++ "j: skip to next patch\n"++ "k: back up to previous patch\n"++ (if n_max_calced then "" else "c: calculate number of patches\n")++ "h or ?: show this help\n"++ "\n: accept the current default (which is capitalized)\n" \end{code} \begin{code} promptChar :: String -> [Char] -> IO Char promptChar p chs = promptCharFancy p chs Nothing False promptCharFancy :: String -> [Char] -> Maybe Char -> Bool -> IO Char promptCharFancy p chs md qmark_for_help = do a <- without_buffering $ do putStr $ p ++ " ["++ setDefault chs ++"]" ++ helpStr hFlush stdout getChar when (a /= '\n') $ putStr "\n" case () of _ | a `elem` chs -> return a | a == ' ' -> case md of Nothing -> tryAgain Just d -> return d | a == '?' && qmark_for_help -> return a | otherwise -> tryAgain where helpStr = if qmark_for_help then ", or ? for help: " else "" tryAgain = do putStrLn "Invalid response, try again!" promptCharFancy p chs md qmark_for_help setDefault s = case md of Nothing -> s Just d -> map (setUpper d) s setUpper d c = if d == c then toUpper c else c \end{code} \begin{code} tp_patches :: ([TaggedPatch],[TaggedPatch]) -> ([Patch],[Patch]) tp_patches (x,y) = (map tp_patch x, map tp_patch y) reverse_invert :: [Patch] -> [Patch] reverse_invert = reverse . (map invert) \end{code}