#include "gadts.h"
module Darcs.Commands.WhatsNew ( whatsnew, status ) where
import System.Exit ( ExitCode(..), exitWith )
import Data.List ( sort, (\\) )
import Control.Monad ( when )
import Control.Applicative ( (<$>) )
import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias )
import Darcs.Commands.Util ( announceFiles )
import Darcs.Arguments ( DarcsFlag(..), workingRepoDir, lookforadds,
ignoretimes, noskipBoring,
unified, summary,
fixSubPaths,
listRegisteredFiles,
)
import Darcs.Flags( isUnified, diffingOpts )
import Darcs.Repository ( Repository, withRepository, RepoJob(..)
, amInRepository
, unrecordedChanges, readRecorded )
import Darcs.Repository.Prefs ( filetypeFunction )
import Darcs.Patch ( RepoPatch, PrimPatch, PrimOf, plainSummaryPrims, primIsHunk, applyToTree )
import Darcs.Patch.TouchesFiles( choosePreTouching )
import Darcs.Patch.Permutations ( partitionRL )
import Darcs.RepoPath( SubPath, toFilePath )
import Darcs.PrintPatch ( printPatch, contextualPrintPatch )
import Darcs.Witnesses.Ordered ( FL(..), reverseRL, reverseFL, (:>)(..), nullFL )
import Darcs.Witnesses.Sealed ( Sealed(..), unFreeLeft )
import Darcs.Diff( treeDiff )
import Printer ( putDocLn, renderString, vcat, text )
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" ++
"\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"
whatsnew :: DarcsCommand
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 = [ignoretimes, noskipBoring],
commandBasicOptions = [summary, unified,
lookforadds,
workingRepoDir]}
filteredChanges :: RepoPatch p => [DarcsFlag] -> Repository p C(r u t)
-> Maybe [SubPath] -> IO (Sealed (FL (PrimOf p) C(t)))
filteredChanges opts repo files =
choosePreTouching (map toFilePath <$> files) `fmap` unrecordedChanges (diffingOpts opts) repo files
whatsnewCmd :: [DarcsFlag] -> [String] -> IO ()
whatsnewCmd opts' args
| LookForAdds `elem` opts' && NoSummary `notElem` opts' =
withRepository (Summary:opts')
$ RepoJob $ \(repository :: Repository p C(r u r)) -> do
files <- if null args then return Nothing
else Just <$> fixSubPaths opts' args
announceFiles files "What's new in"
Sealed all_changes <- filteredChanges opts' repository files
Sealed chold <- filteredChanges (opts' \\ [LookForAdds]) repository files
pristine <- readRecorded repository
ftf <- filetypeFunction
cho_adds :> _ <- return $ partitionRL primIsHunk $ reverseFL chold
cha :> _ <- return $ partitionRL primIsHunk $ reverseFL all_changes
cho_adds_t <- applyToTree (reverseRL cho_adds) pristine
cha_t <- applyToTree (reverseRL cha) pristine
Sealed chn <- unFreeLeft `fmap` treeDiff ftf cho_adds_t cha_t :: IO (Sealed (FL (PrimOf p) C(r)))
exitOnNoChanges (chn, chold)
putDocLn $ plainSummaryPrims chold
printSummary chn
where lower_as x = vcat $ map (text . l_as) $ lines x
l_as ('A':x) = 'a':x
l_as x = x
exitOnNoChanges :: (FL prim C(x y), FL p C(u v)) -> IO ()
exitOnNoChanges (NilFL, NilFL) = do putStrLn "No changes!"
exitWith $ ExitFailure 1
exitOnNoChanges _ = return ()
printSummary :: PrimPatch prim => FL prim C(x y) -> IO ()
printSummary NilFL = return ()
printSummary new = putDocLn $ lower_as $ renderString $ plainSummaryPrims new
whatsnewCmd opts args
| otherwise =
withRepository opts $ RepoJob $ \repository -> do
files <- if null args then return Nothing
else Just . sort <$> fixSubPaths opts args
announceFiles files "What's new in"
Sealed changes <- filteredChanges opts repository files
when (nullFL changes) $ putStrLn "No changes!" >> (exitWith $ ExitFailure 1)
printSummary repository changes
where printSummary :: RepoPatch p => Repository p C(r u t) -> FL (PrimOf p) C(r y) -> IO ()
printSummary _ NilFL = do putStrLn "No changes!"
exitWith $ ExitFailure 1
printSummary r ch | Summary `elem` opts = putDocLn $ plainSummaryPrims ch
| isUnified opts = do pristine <- readRecorded r
contextualPrintPatch pristine ch
| otherwise = printPatch ch
status :: DarcsCommand
status = (commandAlias "status" Nothing whatsnew)
{ commandCommand = \fs -> commandCommand whatsnew (Summary : LookForAdds : fs)
, commandDescription = "Alias for `darcs " ++ commandName whatsnew ++ " -ls '."
}