darcs-cabalized-2.0.2: src/Darcs/SelectChanges.lhs
% 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_GHC -cpp -fffi -fglasgow-exts #-}
#include "gadts.h"
module Darcs.SelectChanges ( with_selected_changes',
with_selected_changes_to_files',
with_selected_last_changes_to_files',
with_selected_last_changes_reversed',
with_selected_changes,
with_selected_changes_to_files,
with_selected_changes_reversed,
with_selected_last_changes_to_files,
with_selected_last_changes_to_files_reversed,
with_selected_last_changes_reversed,
view_changes,
with_selected_patch_from_repo,
) where
import System.IO
import Data.List ( intersperse )
import Data.Maybe ( isJust, catMaybes )
import Data.Char ( toUpper )
import Control.Monad ( when )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )
import English ( Noun(..), englishNum )
import Darcs.Hopefully ( PatchInfoAnd, hopefully, n2pia )
import Darcs.Repository ( Repository, read_repo, read_pending )
import Darcs.Patch ( RepoPatch, Patchy, Prim, summary, commute,
fromPrims, invert, list_touched_files, anonymous )
import qualified Darcs.Patch ( thing, things )
import Darcs.Patch.Ordered ( FL(..), RL(..), (:<)(..), (:>)(..),
(+>+), lengthFL, concatRL, mapFL_FL,
spanFL, reverseFL, (+<+), mapFL )
import Darcs.Patch.Choices ( PatchChoices, patch_choices, patch_choices_tps,
force_first, force_last, make_uncertain, tag,
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_last,
force_matching_first, make_everything_later,
TaggedPatch, tp_patch,
)
import Darcs.Patch.TouchesFiles ( deselect_not_touching, select_not_touching )
import Darcs.PrintPatch ( printFriendly, printPatch, printPatchPager )
import Darcs.SlurpDirectory ( Slurpy )
import Darcs.Match ( have_nonrange_match, match_a_patch, doesnt_not_match )
import Darcs.Flags ( DarcsFlag( DryRun, All, Summary, DontGrabDeps, Verbose
) )
import Darcs.Sealed ( Sealed(..) )
import Darcs.Utils ( askUser, promptCharFancy, without_buffering )
import Printer ( prefix, putDocLn )
#include "impossible.h"
\end{code}
\begin{code}
type WithPatches p a =
String -- jobname
-> [DarcsFlag] -- opts
-> Slurpy -- directory
-> FL p -- patches to select among
-> (FL p :> FL p -> IO a) -- job
-> IO a -- result of running job
-- | The only difference with 'WithPatches' is the [FilePath] argument
type WithPatchesToFiles p a =
String -- jobname
-> [DarcsFlag] -- opts
-> Slurpy -- directory
-> [FilePath] -- files
-> FL p -- patches to select among
-> (FL p :> FL p -> IO a) -- job
-> IO a -- result of running job
with_selected_changes' :: WithPatches Prim a
with_selected_changes_to_files' :: WithPatchesToFiles Prim a
with_selected_last_changes_to_files' :: WithPatchesToFiles Prim a
with_selected_last_changes_reversed' :: WithPatches Prim a
with_selected_changes' = wasc First
with_selected_changes_to_files' = wasc_ First
with_selected_last_changes_to_files' = wasc_ Last
with_selected_last_changes_reversed' = wasc LastReversed
with_selected_changes :: RepoPatch p => WithPatches (PatchInfoAnd p) a
with_selected_changes_to_files :: RepoPatch p => WithPatchesToFiles (PatchInfoAnd p) a
with_selected_changes_reversed :: RepoPatch p => WithPatches (PatchInfoAnd p) a
with_selected_last_changes_to_files :: RepoPatch p => WithPatchesToFiles (PatchInfoAnd p) a
with_selected_last_changes_to_files_reversed :: RepoPatch p => WithPatchesToFiles (PatchInfoAnd p) a
with_selected_last_changes_reversed :: RepoPatch p => WithPatches (PatchInfoAnd p) a
with_selected_changes = wasc' First
with_selected_changes_to_files = wasc_' First
with_selected_changes_reversed = wasc' FirstReversed
with_selected_last_changes_to_files = wasc_' Last
with_selected_last_changes_to_files_reversed = wasc_' LastReversed
with_selected_last_changes_reversed = wasc' LastReversed
data WhichChanges = Last | LastReversed | First | FirstReversed deriving (Eq, Show)
-- | wasc and wasc_ are just shorthand for with_any_selected_changes
wasc :: Patchy p => WhichChanges -> WithPatches p a
wasc mwch j o s = wasc_ mwch j o s []
wasc_ :: Patchy p => WhichChanges -> WithPatchesToFiles p a
wasc_ = with_any_selected_changes
wasc' :: RepoPatch p => WhichChanges -> WithPatches (PatchInfoAnd p) a
wasc' mwch j o s = wasc_' mwch j o s []
wasc_' :: RepoPatch p => WhichChanges -> WithPatchesToFiles (PatchInfoAnd p) a
wasc_' = with_any_selected_changes'
with_any_selected_changes :: Patchy p => WhichChanges -> WithPatchesToFiles p a
with_any_selected_changes wch jn opts s fs =
with_any_selected_changes_ wch (patches_to_consider (Just wch) fs) jn opts s fs
with_any_selected_changes' :: RepoPatch p => WhichChanges -> WithPatchesToFiles (PatchInfoAnd p) a
with_any_selected_changes' wch jn opts s fs =
with_any_selected_changes_ wch (patches_to_consider' (Just wch) fs opts) jn opts s fs
view_changes :: RepoPatch p => [DarcsFlag] -> Slurpy -> [FilePath] -> FL (PatchInfoAnd p) -> IO ()
view_changes opts _ fp ps =
without_buffering $ do text_view opts ps_len 0 NilRL init_tps init_pc
return ()
where ps_to_consider :> _ = patches_to_consider' Nothing fp opts ps
(init_pc, init_tps) = patch_choices_tps ps_to_consider
ps_len = lengthFL init_tps
\end{code}
\begin{code}
data KeyPress a = KeyPress { kp :: Char
, kpHelp :: String }
helpFor :: String -> [[KeyPress a]] -> String
helpFor jobname options =
unlines $ [ "How to use "++jobname++":" ]
++ (concat $ intersperse [""] $ map (map help) options)
++ [ ""
, "?: show this help"
, ""
, "<Space>: accept the current default (which is capitalized)"
]
where help i = kp i:(": "++kpHelp i)
keysFor :: [[KeyPress a]] -> [Char]
keysFor = concatMap (map kp)
\end{code}
\begin{code}
with_selected_patch_from_repo :: RepoPatch p => String -> Repository p -> [DarcsFlag] -> Bool
-> ((PatchInfoAnd p,[PatchInfoAnd p]) -> IO ()) -> IO ()
with_selected_patch_from_repo jn repository opts ignore_pending job = do
Sealed p_s <- read_repo repository
pend <- if ignore_pending
then return NilFL
else read_pending repository
sp <- without_buffering $ wspfr jn (doesnt_not_match opts)
(concatRL p_s) [n2pia $ anonymous $ fromPrims pend]
case sp of
Just (selected, s_and_pend) ->
case (last s_and_pend, init s_and_pend) of
(pend',skipped) ->
case commute (pend' :> selected) of
Just (selected' :> _) -> job (selected', skipped)
Nothing -> impossible
Nothing -> do putStrLn $ "Cancelling "++jn++" since no patch was selected."
exitWith $ ExitSuccess
wspfr :: RepoPatch p => String -> (PatchInfoAnd p -> Bool)
-> RL (PatchInfoAnd p) -> [PatchInfoAnd p]
-> IO (Maybe (PatchInfoAnd p, [PatchInfoAnd p]))
wspfr _ _ NilRL _ = return Nothing
wspfr jn matches (p:<:pps) skipped
| not $ matches p = wspfr jn matches pps (p:skipped)
| otherwise =
case commute_by (skipped :< p) of
Nothing -> do putStr "\nSkipping depended-upon patch:"
printFriendly [] p
wspfr jn matches pps (p:skipped)
Just (p' :< skipped') -> do
printFriendly [] p
let repeat_this = wspfr jn matches (p:<:pps) skipped
options = [[ KeyPress 'y' (jn++" this patch")
, KeyPress 'n' ("don't "++jn++" it")
, KeyPress 'v' "view this patch in full"
, KeyPress 'p' "view this patch in full with pager"
, KeyPress 'x' "view a summary of this patch"
, KeyPress 'q' ("cancel "++jn)
]]
let prompt = "Shall I "++jn++" this patch?"
yorn <- promptCharFancy prompt (keysFor options) (Just 'n') "?h"
case yorn of
'y' -> return $ Just (p', skipped')
'n' -> wspfr jn matches pps (p:skipped)
'v' -> printPatch p >> repeat_this
'p' -> printPatchPager p >> repeat_this
'x' -> do putDocLn $ prefix " " $ summary p
repeat_this
'q' -> do putStrLn $ jn_cap++" cancelled."
exitWith $ ExitSuccess
_ -> do putStrLn $ helpFor jn options
repeat_this
where jn_cap = (toUpper $ head jn) : tail jn
commute_by :: Patchy p => [p] :< p -> Maybe (p :< [p])
commute_by ([] :< a) = Just (a :< [])
commute_by (p:ps :< a) =
case commute (a :> p) of
Nothing -> Nothing
Just (p':>a') -> case commute_by (ps :< a') of
Nothing -> Nothing
Just (a'' :< ps') -> Just (a'' :< p':ps')
\end{code}
\begin{code}
with_any_selected_changes_ :: Patchy p => WhichChanges
-> (FL p -> FL p :> FL p)
-> WithPatchesToFiles p a
with_any_selected_changes_ whichch p2c
jobname opts _ _ ps job =
if All `elem` opts || DryRun `elem` opts
then job $ case whichch of LastReversed -> invert other_ps :> invert ps_to_consider
FirstReversed -> invert other_ps :> invert ps_to_consider
_ -> ps_to_consider :> other_ps
else do pc <- without_buffering $
tentatively_text_select "" jobname (Noun "patch") whichch
opts ps_len 0 NilRL init_tps init_pc
job $ selected_patches whichch rejected_ps pc
where ps_to_consider :> other_ps = p2c ps
rejected_ps = if whichch == Last || whichch == FirstReversed then ps_to_consider else other_ps
(init_pc, init_tps) = patch_choices_tps $ case whichch of Last -> other_ps
FirstReversed -> other_ps
_ -> ps_to_consider
ps_len = lengthFL init_tps
patches_to_consider :: Patchy p => Maybe WhichChanges
-> [FilePath] -- ^ files
-> FL p -- ^ patches
-> (FL p :> FL p)
patches_to_consider mwhichch fs ps =
let ps' = if mwhichch == Just LastReversed || mwhichch == Just FirstReversed then invert ps else ps
f = case mwhichch of Just Last -> separate_middle_last_from_first
Just FirstReversed -> separate_middle_last_from_first
_ -> separate_first_middle_from_last
deal_with_fs = case mwhichch of Just Last -> select_not_touching fs
Just FirstReversed -> select_not_touching fs
_ -> deselect_not_touching fs
in if null fs then if mwhichch == Just Last || mwhichch == Just FirstReversed then NilFL :> ps' else ps' :> NilFL
else tp_patches $ f $ deal_with_fs $ patch_choices ps'
patches_to_consider' :: RepoPatch p => Maybe WhichChanges
-> [FilePath] -- ^ files
-> [DarcsFlag] -- ^ opts
-> FL (PatchInfoAnd p) -- ^ patches
-> FL (PatchInfoAnd p) :> FL (PatchInfoAnd p)
patches_to_consider' mwhichch fs opts ps =
let ps' = if mwhichch == Just LastReversed || mwhichch == Just FirstReversed then invert ps else ps
f = case mwhichch of Just Last -> separate_middle_last_from_first
Just FirstReversed -> separate_middle_last_from_first
_ -> separate_first_middle_from_last
deal_with_fs = case mwhichch of Just Last -> select_not_touching fs
Just FirstReversed -> select_not_touching fs
_ -> deselect_not_touching fs
deselect_unwanted pc =
if have_nonrange_match opts
then case mwhichch of
Just Last -> bug "don't support patch matching with Last in wasp"
Just FirstReversed -> bug "don't support patch matching with FirstReversed in wasp"
_ -> if DontGrabDeps `elem` opts
then force_matching_last (not.iswanted) pc
else make_everything_later $ force_matching_first iswanted pc
else pc
iswanted = let maybe_invert = if mwhichch == Just LastReversed || mwhichch == Just FirstReversed then invert else id
in (match_a_patch opts . hopefully . maybe_invert . tp_patch)
in if null fs && not (have_nonrange_match opts)
then if mwhichch == Just Last || mwhichch == Just FirstReversed then NilFL :> ps' else ps' :> NilFL
else tp_patches $ f $ deal_with_fs $ deselect_unwanted $ patch_choices ps'
-- | Returns the results of a patch selection user interaction
selected_patches :: Patchy p => WhichChanges
-> FL p -- ^ patches set aside
-> PatchChoices p
-> (FL p :> FL p)
selected_patches whichch other_ps pc =
case whichch of
Last -> case separate_last_from_first_middle pc of
xs :> ys -> other_ps +>+ mapFL_FL tp_patch xs :> mapFL_FL tp_patch ys
First -> case separate_first_from_middle_last pc of
xs :> ys -> mapFL_FL tp_patch xs :> mapFL_FL tp_patch ys +>+ other_ps
LastReversed -> case separate_first_from_middle_last pc of
xs :> ys -> invert (mapFL_FL tp_patch ys +>+ other_ps) :> invert (mapFL_FL tp_patch xs)
FirstReversed -> case separate_last_from_first_middle pc of
xs :> ys -> invert (mapFL_FL tp_patch ys) :> invert (other_ps +>+ mapFL_FL tp_patch xs)
text_select :: Patchy p => String -> WhichChanges -> [DarcsFlag] -> Int -> Int
-> RL (TaggedPatch p) -> FL (TaggedPatch p) -> PatchChoices p
-> IO (PatchChoices p)
text_select _ _ _ _ _ _ NilFL pc = return pc
text_select jn whichch opts n_max n
tps_done tps_todo@(tp:>:tps_todo') pc = do
printFriendly opts viewp
repeat_this -- prompt the user
where
do_next_action ja je = tentatively_text_select ja jn je whichch opts
n_max
(n+1) (tp:<:tps_done) tps_todo'
do_next = do_next_action "" (Noun "patch")
helper :: PatchChoices p -> p
helper = undefined
thing = Darcs.Patch.thing (helper pc)
things = Darcs.Patch.things (helper pc)
options_basic =
[ KeyPress 'y' (jn++" this "++thing)
, KeyPress 'n' ("don't "++jn++" it")
, KeyPress 'w' ("wait and decide later, defaulting to no") ]
options_file =
[ KeyPress 's' ("don't "++jn++" the rest of the changes to this file")
, KeyPress 'f' (jn++" the rest of the changes to this file") ]
options_view =
[ KeyPress 'v' ("view this "++thing++" in full")
, KeyPress 'p' ("view this "++thing++" in full with pager") ]
options_summary =
[ KeyPress 'x' ("view a summary of this "++thing) ]
options_quit =
[ KeyPress 'd' (jn++" selected "++things++", skipping all the remaining "++things)
, KeyPress 'a' (jn++" all the remaining "++things)
, KeyPress 'q' ("cancel "++jn) ]
options_nav =
[ KeyPress 'j' ("skip to next "++thing)
, KeyPress 'k' ("back up to previous "++thing) ]
options = [options_basic]
++ (if is_single_file_patch then [options_file] else [])
++ [options_view ++
if Summary `elem` opts then [] else options_summary]
++ [options_quit]
++ [options_nav ]
prompt = "Shall I "++jn++" this "++thing++"? "
++ "(" ++ show (n+1) ++ "/" ++ show n_max ++ ") "
repeat_this = do
yorn <- promptCharFancy prompt (keysFor options) (Just the_default) "?h"
case yorn of
'y' -> do_next $ force_yes (tag tp) pc
'n' -> do_next $ force_no (tag tp) pc
'w' -> do_next $ make_uncertain (tag tp) pc
's' -> do_next_action "Skipped" (Noun "change") $ skip_file
'f' -> do_next_action "Included" (Noun "change") $ do_file
'v' -> printPatch viewp >> repeat_this
'p' -> printPatchPager viewp >> repeat_this
'x' -> do putDocLn $ prefix " " $ summary viewp
repeat_this
'd' -> return pc
'a' -> do ask_confirmation
return $ select_all_middles (whichch == Last || whichch == FirstReversed) pc
'q' -> do putStrLn $ jn_cap++" cancelled."
exitWith $ ExitSuccess
'j' -> case tps_todo' of
NilFL -> -- May as well work out the length now we have all
-- the patches in memory
text_select jn whichch opts
n_max n tps_done tps_todo pc
_ -> text_select jn whichch opts
n_max (n+1) (tp:<:tps_done) tps_todo' pc
'k' -> case tps_done of
NilRL -> repeat_this
(tp':<:tps_done') ->
text_select jn whichch opts
n_max (n-1) tps_done' (tp':>:tps_todo) pc
'c' -> text_select jn whichch opts
n_max n tps_done tps_todo pc
_ -> do putStrLn $ helpFor jn options
repeat_this
force_yes = if whichch == Last || whichch == FirstReversed then force_last else force_first
force_no = if whichch == Last || whichch == FirstReversed then force_first else force_last
patches_to_skip = (tag tp:) $ catMaybes
$ mapFL (\tp' -> if list_touched_files tp' == touched_files
then Just (tag tp')
else Nothing) tps_todo'
skip_file = foldr force_no pc patches_to_skip
do_file = foldr force_yes pc patches_to_skip
the_default = get_default (whichch == Last || whichch == FirstReversed) $ is_patch_first tp pc
jn_cap = (toUpper $ head jn) : tail jn
touched_files = list_touched_files $ tp_patch tp
is_single_file_patch = length touched_files == 1
viewp = if whichch == LastReversed || whichch == FirstReversed then invert (tp_patch tp) else tp_patch tp
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 :: Patchy p => [DarcsFlag] -> Int -> Int
-> RL (TaggedPatch p) -> FL (TaggedPatch p) -> PatchChoices p
-> IO (PatchChoices p)
text_view _ _ _ _ NilFL _ = return $ patch_choices NilFL --return pc
text_view opts n_max n
tps_done tps_todo@(tp:>:tps_todo') pc = do
printFriendly opts (tp_patch tp)
putStr "\n"
repeat_this -- prompt the user
where
prev_patch = case tps_done of
NilRL -> repeat_this
(tp':<:tps_done') ->
text_view opts
n_max (n-1) tps_done' (tp':>:tps_todo) pc
next_patch = case tps_todo' of
NilFL -> -- May as well work out the length now we have all
-- the patches in memory
text_view opts n_max
n tps_done tps_todo' pc
_ -> text_view opts n_max
(n+1) (tp:<:tps_done) tps_todo' pc
options_yn =
[ KeyPress 'y' "view this patch and go to the next"
, KeyPress 'n' "skip to the next patch" ]
options_view =
[ KeyPress 'v' "view this patch in full"
, KeyPress 'p' "view this patch in fill with pager" ]
options_summary =
[ KeyPress 'x' "view a summary of this patch" ]
options_nav =
[ KeyPress 'q' ("quit view changes")
, KeyPress 'k' "back up to previous patch"
, KeyPress 'j' "skip to next patch" ]
options = [ options_yn ]
++ [ options_view ++
if Summary `elem` opts then [] else options_summary ]
++ [ options_nav ]
prompt = "Shall I view this patch? "
++ "(" ++ show (n+1) ++ "/" ++ show n_max ++ ")"
repeat_this = do
yorn <- promptCharFancy prompt (keysFor options) (Just 'n') "?h"
case yorn of
'y' -> printPatch (tp_patch tp) >> next_patch
'n' -> next_patch
'v' -> printPatch (tp_patch tp) >> repeat_this
'p' -> printPatchPager (tp_patch tp) >> repeat_this
'x' -> do putDocLn $ prefix " " $ summary (tp_patch tp)
repeat_this
'q' -> exitWith ExitSuccess
'k' -> prev_patch
'j' -> next_patch
'c' -> text_view opts
n_max n tps_done tps_todo pc
_ -> do putStrLn $ helpFor "view changes" options
repeat_this
tentatively_text_select :: Patchy p => String -> String -> Noun -> WhichChanges -> [DarcsFlag]
-> Int -> Int -> RL (TaggedPatch p) -> FL (TaggedPatch p)
-> PatchChoices p
-> IO (PatchChoices p)
tentatively_text_select _ _ _ _ _ _ _ _ NilFL pc = return pc
tentatively_text_select jobaction jobname jobelement whichch opts n_max n ps_done
ps_todo pc = do
when (numSkipped > 0) show_skipped
text_select jobname whichch opts n_max (n + numSkipped)
(reverseFL skipped +<+ ps_done) unskipped pc
where
skipped :> unskipped = spanFL (\p -> isJust $ is_patch_first p pc) ps_todo
numSkipped = lengthFL skipped
show_skipped = do putStrLn $ _doing_ ++ _with_ ++ "."
when (Verbose `elem` opts) $ showskippedpatch skipped
where
_doing_ = _action_ ++ " " ++ jobname
_with_ = " of " ++ show numSkipped ++ " " ++ _elem_ ""
_action_ = if (length jobaction) == 0 then "Skipped" else jobaction
_elem_ = englishNum numSkipped jobelement
showskippedpatch (tp:>:tps) = (putDocLn $ prefix " " $ summary (tp_patch tp)) >> showskippedpatch tps
showskippedpatch NilFL = return ()
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'
\end{code}
\begin{code}
tp_patches :: (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x y)
-> (FL p :> FL p) C(x y)
tp_patches (x:>y) = mapFL_FL tp_patch x :> mapFL_FL tp_patch y
\end{code}