module Darcs.UI.Commands.WhatsNew
(
whatsnew
, status
) where
import Prelude hiding ( (^), catch )
import Control.Applicative ( (<$>) )
import Control.Monad ( void )
import Control.Monad.Reader ( runReaderT )
import Control.Monad.State ( evalStateT, liftIO )
import Storage.Hashed.Tree ( Tree )
import System.Exit ( ExitCode (..), exitSuccess, exitWith )
import Darcs.Patch
( PrimOf, PrimPatch, RepoPatch
, applyToTree, plainSummaryPrims, primIsHunk
)
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Patch.Choices ( patchChoicesLps, lpPatch )
import Darcs.Patch.FileHunk ( IsHunk (..) )
import Darcs.Patch.Format ( PatchListFormat (..) )
import Darcs.Patch.Inspect ( PatchInspect (..) )
import Darcs.Patch.Patchy ( Patchy )
import Darcs.Patch.Permutations ( partitionRL )
import Darcs.Patch.Prim.Class ( PrimDetails (..) )
import Darcs.Patch.Show ( ShowPatch )
import Darcs.Patch.Split ( primSplitter )
import Darcs.Patch.TouchesFiles ( choosePreTouching )
import Darcs.Patch.Witnesses.Ordered
( (:>) (..), FL (..), RL (..)
, lengthFL, reverseFL, reverseRL
)
import Darcs.Patch.Witnesses.Sealed
( Sealed (..), Sealed2 (..)
, unFreeLeft
)
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )
import Darcs.Patch.Witnesses.WZipper ( FZipper (..) )
import Darcs.Repository
( RepoJob (..), Repository
, listRegisteredFiles, readRecorded
, unrecordedChangesWithPatches, withRepository
)
import Darcs.Repository.Diff ( treeDiff )
import Darcs.Repository.Prefs ( filetypeFunction )
import Darcs.Repository.Util ( getMovesPs, getReplaces )
import Darcs.UI.Commands
( DarcsCommand(..), withStdOpts, amInRepository
, commandAlias, nodefaults
)
import Darcs.UI.Commands.Util ( announceFiles )
import Darcs.UI.Flags
( DarcsFlag (Summary, LookForAdds, LookForMoves), diffAlgorithm, diffingOpts
, isUnified, useCache, fixSubPaths
, verbosity, isInteractive, isUnified, lookForAdds, lookForMoves, lookForReplaces, hasSummary
)
import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.PrintPatch
( contextualPrintPatch, printPatch
, printPatchPager
)
import Darcs.UI.SelectChanges
( InteractiveSelectionContext (..)
, InteractiveSelectionM, KeyPress (..)
, WhichChanges (..), backAll
, backOne, currentFile
, currentPatch, decide
, decideWholeFile, helpFor
, keysFor, prompt
, selectionContextPrim, skipMundane
, skipOne, printSummary
)
import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )
import Darcs.Util.Path ( AbsolutePath, SubPath, toFilePath )
import Darcs.Util.Printer
( putDocLn, renderString, RenderMode(..)
, text, vcat
)
import Darcs.Util.Prompt ( PromptConfig (..), promptChar )
whatsnewBasicOpts :: DarcsOption a
(Maybe O.Summary
-> O.WithContext
-> O.LookFor
-> O.DiffAlgorithm
-> Maybe String
-> Maybe Bool
-> a)
whatsnewBasicOpts
= O.summary
^ O.withContext
^ O.lookfor
^ O.diffAlgorithm
^ O.workingRepoDir
^ O.interactive
whatsnewAdvancedOpts :: DarcsOption a (O.UseIndex -> Bool -> a)
whatsnewAdvancedOpts = O.useIndex ^ O.includeBoring
whatsnewOpts :: DarcsOption a
(Maybe O.Summary
-> O.WithContext
-> O.LookFor
-> O.DiffAlgorithm
-> Maybe String
-> Maybe Bool
-> Maybe O.StdCmdAction
-> Bool
-> Bool
-> O.Verbosity
-> Bool
-> O.UseIndex
-> Bool
-> O.UseCache
-> Maybe String
-> Bool
-> Maybe String
-> Bool
-> a)
whatsnewOpts = whatsnewBasicOpts `withStdOpts` whatsnewAdvancedOpts
patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions
patchSelOpts flags = S.PatchSelectionOptions
{ S.verbosity = verbosity flags
, S.matchFlags = []
, S.diffAlgorithm = diffAlgorithm flags
, S.interactive = isInteractive True flags
, S.selectDeps = O.PromptDeps
, S.summary = hasSummary (defaultSummary flags) flags
, S.withContext = isUnified flags
}
defaultSummary :: [DarcsFlag] -> O.Summary
defaultSummary flags = if lookForAdds flags == O.YesLookForAdds then O.YesSummary else O.NoSummary
whatsnew :: DarcsCommand [DarcsFlag]
whatsnew = DarcsCommand
{ commandProgramName = "darcs"
, commandName = "whatsnew"
, commandHelp = whatsnewHelp
, commandDescription = whatsnewDescription
, commandExtraArgs = 1
, commandExtraArgHelp = ["[FILE or DIRECTORY]..."]
, commandCommand = whatsnewCmd
, commandPrereq = amInRepository
, commandGetArgPossibilities = listRegisteredFiles
, commandArgdefaults = nodefaults
, commandAdvancedOptions = odesc whatsnewAdvancedOpts
, commandBasicOptions = odesc whatsnewBasicOpts
, commandDefaults = defaultFlags whatsnewOpts
, commandCheckOptions = ocheck whatsnewOpts
, commandParseOptions = onormalise whatsnewOpts
}
whatsnewDescription :: String
whatsnewDescription = "List unrecorded changes in the working tree."
whatsnewHelp :: String
whatsnewHelp =
"The `darcs whatsnew` command lists unrecorded changes to the working\n" ++
"tree. If you specify a set of files and directories, only unrecorded\n" ++
"changes to those files and directories are listed.\n" ++
"\n" ++
"With the `--summary` option, the changes are condensed to one line per\n" ++
"file, with mnemonics to indicate the nature and extent of the change.\n" ++
"The `--look-for-adds` option causes candidates for `darcs add` to be\n" ++
"included in the summary output. Summary mnemonics are as follows:\n" ++
"\n" ++
"* `A f` and `A d/` respectively mean an added file or directory.\n" ++
"* `R f` and `R d/` respectively mean a removed file or directory.\n" ++
"* `M f -N +M rP` means a modified file, with `N` lines deleted, `M`\n" ++
" lines added, and `P` lexical replacements.\n" ++
"* `f -> g` means a moved file or directory.\n" ++
"* `a f` and `a d/` respectively mean a new, but unadded, file or\n" ++
" directory, when using `--look-for-adds`.\n" ++
"\n" ++
" An exclamation mark (!) as in `R! foo.c`, means the hunk is known to\n" ++
" conflict with a hunk in another patch. The phrase `duplicated`\n" ++
" means the hunk is known to be identical to a hunk in another patch.\n" ++
"\n" ++
"By default, `darcs whatsnew` uses Darcs' internal format for changes.\n" ++
"To see some context (unchanged lines) around each change, use the\n" ++
"`--unified` option. To view changes in conventional `diff` format, use\n" ++
"the `darcs diff` command; but note that `darcs whatsnew` is faster.\n" ++
"\n" ++
"This command exits unsuccessfully (returns a non-zero exit status) if\n" ++
"there are no unrecorded changes.\n"
whatsnewCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
whatsnewCmd fps opts args =
withRepository (useCache opts) $ RepoJob $ \(repo :: Repository p wR wU wR) -> do
files <- if null args
then return Nothing
else Just <$> fixSubPaths fps args
let isLookForMoves = lookForMoves opts == O.YesLookForMoves && parseFlags O.summary opts /= Just O.NoSummary
isLookForAdds = lookForAdds opts == O.YesLookForAdds && parseFlags O.summary opts /= Just O.NoSummary
isLookForReplaces = lookForReplaces opts == O.YesLookForReplaces
optsModifier = if isLookForAdds
then (Summary :) . filter (\o -> LookForAdds /= o &&
LookForMoves /= o )
else id
opts' = optsModifier opts
movesPs <- if isLookForMoves
then getMovesPs repo files
else return NilFL
Sealed replacePs <- if isLookForReplaces
then getReplaces (diffingOpts opts) repo files
else return (Sealed NilFL)
Sealed noLookChanges <- filteredUnrecordedChanges opts' repo files movesPs
(unsafeCoerceP replacePs :: FL (PrimOf p) wR wR)
pristine <- readRecorded repo
Sealed unaddedNewPathsPs <- if isLookForAdds
then do
Sealed lookChanges <- filteredUnrecordedChanges opts repo files movesPs (unsafeCoerceP replacePs :: FL (PrimOf p) wR wR)
noLookAddsTree <- applyAddPatchesToPristine noLookChanges pristine
lookAddsTree <- applyAddPatchesToPristine lookChanges pristine
ftf <- filetypeFunction
unFreeLeft <$> treeDiff (diffAlgorithm opts) ftf noLookAddsTree lookAddsTree
else return (Sealed NilFL)
announceFiles files "What's new in"
exitOnNoChanges (unaddedNewPathsPs, noLookChanges)
if maybeIsInteractive opts
then runInteractive (interactiveHunks pristine) opts' pristine noLookChanges
else do
printChanges opts' pristine noLookChanges
printUnaddedPaths unaddedNewPathsPs
where
applyAddPatchesToPristine ps pristine = do
adds :> _ <- return $ partitionRL primIsHunk $ reverseFL ps
applyToTree (reverseRL adds) pristine
exitOnNoChanges :: (FL p wX wY, FL p wU wV) -> IO ()
exitOnNoChanges (NilFL, NilFL) = do putStrLn "No changes!"
exitWith $ ExitFailure 1
exitOnNoChanges _ = return ()
printUnaddedPaths :: PrimPatch p => FL p wX wY -> IO ()
printUnaddedPaths NilFL = return ()
printUnaddedPaths ps =
putDocLn . lowercaseAs . renderString Encode . plainSummaryPrims $ ps
lowercaseAs x = vcat $ map (text . lowercaseA) $ lines x
lowercaseA ('A' : x) = 'a' : x
lowercaseA x = x
printChanges :: (PatchListFormat p, IsHunk p, Patchy p, ShowPatch p, PrimDetails p,
ApplyState p ~ Tree) => [DarcsFlag] -> Tree IO -> FL p wX wY
-> IO ()
printChanges opts' pristine changes
| Summary `elem` opts' = putDocLn $ plainSummaryPrims changes
| isUnified opts' == O.YesContext = contextualPrintPatch pristine changes
| otherwise = printPatch changes
filteredUnrecordedChanges :: forall p wR wU wT. (RepoPatch p, ApplyState p ~ Tree,
ApplyState (PrimOf p) ~ Tree) => [DarcsFlag]
-> Repository p wR wU wT -> Maybe [SubPath]
-> FL (PrimOf p) wR wT
-> FL (PrimOf p) wT wT
-> IO (Sealed (FL (PrimOf p) wT))
filteredUnrecordedChanges opts' repo files movesPs replacesPs =
let filePaths = map toFilePath <$> files in
choosePreTouching filePaths <$> unrecordedChangesWithPatches (diffingOpts opts') repo files movesPs replacesPs
runInteractive :: (PatchListFormat p, IsHunk p, Patchy p, ShowPatch p,
PrimPatch p, PatchInspect p, PrimDetails p,
ApplyState p ~ Tree)
=> InteractiveSelectionM p wX wY ()
-> [DarcsFlag]
-> Tree IO
-> FL p wX wY
-> IO ()
runInteractive i opts pristine ps' = do
let (choices',lps') = patchChoicesLps ps'
let ps = evalStateT i $
ISC { total = lengthFL lps'
, current = 0
, lps = FZipper NilRL lps'
, choices = choices'
}
void $ runReaderT ps $
selectionContextPrim First "view" (patchSelOpts opts) (Just primSplitter)
Nothing (Just pristine)
interactiveHunks :: (PatchListFormat p, IsHunk p, Patchy p, ShowPatch p,
PatchInspect p, PrimDetails p, ApplyState p ~ Tree)
=> Tree IO -> InteractiveSelectionM p wX wY ()
interactiveHunks pristine = do
c <- currentPatch
case c of
Nothing -> liftIO $ putStrLn "No more changes!"
Just (Sealed2 lp) -> do
liftIO $ printPatch (lpPatch lp)
repeatThis lp
where
repeatThis lp = do
thePrompt <- prompt
yorn <- liftIO $ promptChar
(PromptConfig thePrompt (keysFor basic_options) (keysFor adv_options)
(Just 'n') "?h")
case yorn of
'v' -> liftIO (contextualPrintPatch pristine (lpPatch lp))
>> repeatThis lp
'x' -> liftIO (printSummary (lpPatch lp))
>> repeatThis lp
'y' -> liftIO (contextualPrintPatch pristine (lpPatch lp))
>> decide True lp >> next_hunk
'n' -> decide False lp >> next_hunk
's' -> do
currentFile >>= maybe
(return ())
(\f -> decideWholeFile f False)
next_hunk
'p' -> liftIO (printPatchPager $ lpPatch lp)
>> repeatThis lp
'j' -> next_hunk
'k' -> prev_hunk
'g' -> start_over
'q' -> liftIO $ exitSuccess
_ -> do liftIO . putStrLn $
helpFor "whatsnew" basic_options adv_options
repeatThis lp
start_over = backAll >> interactiveHunks pristine
next_hunk = skipOne >> skipMundane >> interactiveHunks pristine
prev_hunk = backOne >> interactiveHunks pristine
options_yn =
[ KeyPress 'v' "view this hunk in a context"
, KeyPress 'y'
"view this hunk in a context and go to the next one"
, KeyPress 'n' "go to the next hunk" ]
optionsView =
[ KeyPress 'p' "view this hunk in context wih pager "
, KeyPress 'x' "view a summary of this patch"
]
optionsNav =
[ KeyPress 'q' "quit whatsnew"
, KeyPress 's' "skip the rest of the changes to this file"
, KeyPress 'j' "skip to the next hunk"
, KeyPress 'k' "back up to previous hunk"
, KeyPress 'g' "start over from the first hunk"
]
basic_options = [ options_yn ]
adv_options = [ optionsView, optionsNav ]
status :: DarcsCommand [DarcsFlag]
status = statusAlias { commandCommand = statusCmd
, commandDescription = statusDesc
}
where
statusAlias = commandAlias "status" Nothing whatsnew
statusCmd fps fs = commandCommand whatsnew fps (Summary : LookForAdds : fs)
statusDesc = "Alias for `darcs " ++ commandName whatsnew ++ " -ls '."
maybeIsInteractive :: [DarcsFlag] -> Bool
maybeIsInteractive = maybe False id . parseFlags O.interactive