Changes.lhs

%  Copyright (C) 2003-2004 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.

\darcsCommand{changes}
\begin{code}
{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
{-# LANGUAGE CPP, PatternGuards #-}

module Darcs.Commands.Changes ( changes ) where

import Data.List ( intersect, sort )
import Data.Maybe ( fromMaybe )
import Control.Monad ( when, unless )

import Darcs.Hopefully ( hopefullyM, info )
import Darcs.Patch.Depends ( slightly_optimize_patchset )
import Darcs.Commands ( DarcsCommand(..), nodefaults )
import Darcs.Arguments ( DarcsFlag(Context, HumanReadable, MachineReadable,
                                   Interactive, OnlyChangesToFiles, Count,
                                   NumberPatches, XMLOutput, Summary,
                                   Reverse, Verbose, Debug),
                         fixSubPaths, changes_format,
                         possibly_remote_repo_dir, get_repourl,
                         working_repo_dir, only_to_files,
                         summary, changes_reverse,
                         match_several_or_range,
                         match_maxcount, maxCount,
                         all_interactive, showFriendly,
                         network_options
                      )
import Darcs.RepoPath ( toFilePath, rootDirectory )
import Darcs.Patch.FileName ( fp2fn, fn2fp, norm_path )
import Darcs.Repository ( Repository, PatchSet, PatchInfoAnd,
                          get_unrecorded_in_files_unsorted,
                          withRepositoryDirectory, ($-), findRepository,
                          read_repo )
import Darcs.Patch.Info ( to_xml, showPatchInfo )
import Darcs.Patch.Depends ( get_common_and_uncommon )
import Darcs.Patch.TouchesFiles ( look_touch )
import Darcs.Patch ( RepoPatch, invert, xml_summary, description, apply_to_filepaths,
                     list_touched_files, effect, identity )
import Darcs.Ordered ( (:\/:)(..), RL(..), unsafeFL, unsafeUnRL, concatRL,
                             EqCheck(..), filterFL )
import Darcs.Match ( first_match, second_match,
               match_a_patchread, have_nonrange_match,
               match_first_patchset, match_second_patchset,
             )
import Darcs.Commands.Annotate ( created_as_xml )
import Printer ( Doc, putDocLnWith, simplePrinters, (<+>),
                 renderString, prefix, text, vcat, vsep, 
                 ($$), empty, errorDoc, insert_before_lastline )
import Darcs.ColorPrinter ( fancyPrinters )
import Progress ( setProgressMode, debugMessage )
import Darcs.SelectChanges ( view_changes )
import Darcs.Sealed ( unsafeUnseal )
#include "impossible.h"

changes_description :: String
changes_description = "List patches in the repository."

changes_help :: String
changes_help =
 "The `darcs changes' command lists the patches that constitute the\n" ++
 "current repository.  Without options or arguments, ALL patches will be\n" ++
 "listed.\n" ++
 "\n" ++ changes_help' ++
 "\n" ++ changes_help''

changes :: DarcsCommand
changes = DarcsCommand {command_name = "changes",
                        command_help = changes_help,
                        command_description = changes_description,
                        command_extra_args = -1,
                        command_extra_arg_help = ["[FILE or DIRECTORY]..."],
                        command_get_arg_possibilities = return [],
                        command_command = changes_cmd,
                        command_prereq = findRepository,
                        command_argdefaults = nodefaults,
                        command_advanced_options = network_options,
                        command_basic_options = [match_several_or_range,
                                                 match_maxcount,
                                                 only_to_files,
                                                 changes_format,
                                                 summary,
                                                 changes_reverse,
                                                 possibly_remote_repo_dir,
                                                 working_repo_dir,
                                                 all_interactive]}

changes_cmd :: [DarcsFlag] -> [String] -> IO ()
changes_cmd [Context _] [] = return ()
changes_cmd opts args | Context rootDirectory `elem` opts =
  let repodir = fromMaybe "." (get_repourl opts) in
  withRepositoryDirectory opts repodir $- \repository -> do
  when (args /= []) $ fail "changes --context cannot accept other arguments"
  changes_context repository opts
changes_cmd opts args =
  let repodir = fromMaybe "." (get_repourl opts) in
  withRepositoryDirectory opts repodir $- \repository -> do
  unless (Debug `elem` opts) $ setProgressMode False
  files <- sort `fmap` fixSubPaths opts args
  unrec <- if null files then return identity
             else get_unrecorded_in_files_unsorted repository (map (fp2fn . toFilePath) files)
           `catch` \_ -> return identity -- this is triggered when repository is remote
  let filez = map (fn2fp . norm_path . fp2fn) $ apply_to_filepaths (invert unrec) $ map toFilePath files
      filtered_changes p = maybe_reverse $ get_changes_info opts filez p
  debugMessage "About to read the repository..."
  patches <- read_repo repository
  debugMessage "Done reading the repository."
  if Interactive `elem` opts
    then do let (fp_and_fs, _, _) = filtered_changes patches
                fp = map fst fp_and_fs
            view_changes opts (unsafeFL fp)
    else do when (not (null files) && not (XMLOutput `elem` opts)) $
                 putStrLn $ "Changes to "++unwords filez++":\n"
            debugMessage "About to print the changes..."
            let printers = if XMLOutput `elem` opts then simplePrinters else fancyPrinters
            ps <- read_repo repository -- read repo again to prevent holding onto
                                       -- values forced by filtered_changes
            putDocLnWith printers $ changelog opts ps $ filtered_changes patches
  where maybe_reverse (xs,b,c) = if Reverse `elem` opts
                                 then (reverse xs, b, c)
                                 else (xs, b, c)


-- FIXME: this prose is unreadable. --twb, 2009-08
changes_help' :: String
changes_help' =
 "When given one or more files or directories as an argument, only\n" ++
 "patches which affect those files or directories are listed. This\n" ++
 "includes changes that happened to files before they were moved or\n" ++
 "renamed.\n" ++
 "\n" ++
 "When given a --from-tag, --from-patch or --from-match, only changes\n" ++
 "since that tag or patch are listed.  Similarly, the --to-tag,\n" ++
 "--to-patch and --to-match options restrict the list to older patches.\n" ++
 "\n" ++
 "The --last and --max-count options both limit the number of patches\n" ++
 "listed.  The former applies BEFORE other filters, whereas the latter\n" ++
 "applies AFTER other filters.  For example `darcs changes foo.c\n" ++
 "--max-count 3' will print the last three patches that affect foo.c,\n" ++
 "whereas `darcs changes --last 3 foo.c' will, of the last three\n" ++
 "patches, print only those that affect foo.c.\n"

get_changes_info :: RepoPatch p => [DarcsFlag] -> [FilePath] -> PatchSet p
                 -> ([(PatchInfoAnd p, [FilePath])], [FilePath], Doc)
get_changes_info opts plain_fs ps =
  case get_common_and_uncommon (p2s,p1s) of
  (_,us:\/:_) -> filter_patches_by_names (maxCount opts) fs $ filter pf $ unsafeUnRL $ concatRL us
  where fs = map (\x -> "./" ++ x) $ plain_fs
        p1s = if first_match opts then unsafeUnseal $ match_first_patchset opts ps
                                  else NilRL:<:NilRL
        p2s = if second_match opts then unsafeUnseal $ match_second_patchset opts ps
                                   else ps
        pf = if have_nonrange_match opts
             then match_a_patchread opts
             else \_ -> True

-- | Take a list of filenames and patches and produce a list of
-- patches that actually touch the given files with list of touched
-- file names, a new file list that represents the same set of files
-- as in input, before the returned patches would have been applied,
-- and possibly an error. Additionaly, the function takes a "depth
-- limit" -- maxcount, that could be Nothing (return everything) or
-- "Just n" -- returns at most n patches touching the file (starting
-- from the beginning of the patch list).
filter_patches_by_names :: RepoPatch p =>
                           Maybe Int -- ^ maxcount
                        -> [FilePath] -- ^ filenames
                        -> [PatchInfoAnd p] -- ^ patchlist
                        -> ([(PatchInfoAnd p,[FilePath])], [FilePath], Doc)
filter_patches_by_names (Just 0) _ _ = ([], [], empty)
filter_patches_by_names _ _ [] = ([], [], empty)
filter_patches_by_names maxcount [] (hp:ps) =
    (hp, []) -:- filter_patches_by_names (subtract 1 `fmap` maxcount) [] ps
filter_patches_by_names maxcount fs (hp:ps)
    | Just p <- hopefullyM hp =
    case look_touch fs (invert p) of
    (True, []) -> ([(hp, fs)], fs, empty)
    (True, fs') -> (hp, fs) -:- filter_patches_by_names
                                (subtract 1 `fmap` maxcount) fs' ps
    (False, fs') -> filter_patches_by_names maxcount fs' ps
filter_patches_by_names _ _ (hp:_) =
    ([], [], text "Can't find changes prior to:" $$ description hp)

-- | Note, lazy pattern matching is required to make functions like
-- filter_patches_by_names lazy in case you are only not interested in
-- the first element. E.g.:
--
--   let (fs, _, _) = filter_patches_by_names ...
(-:-) :: a -> ([a],b,c) -> ([a],b,c)
x -:- ~(xs,y,z) = (x:xs,y,z)

changelog :: RepoPatch p => [DarcsFlag] -> PatchSet p -> ([(PatchInfoAnd p, [FilePath])], [FilePath], Doc)
          -> Doc
changelog opts patchset (pis_and_fs, orig_fs, errstring)
    | Count `elem` opts = text $ show $ length pis_and_fs
    | MachineReadable `elem` opts =
        if renderString errstring == ""
        then vsep $ map (showPatchInfo.info) pis
        else errorDoc errstring
    | XMLOutput `elem` opts =
         text "<changelog>"
      $$ vcat xml_file_names
      $$ vcat actual_xml_changes
      $$ text "</changelog>"
    | Summary `elem` opts || Verbose `elem`  opts =
           vsep (map (number_patch change_with_summary) pis_and_fs)
        $$ errstring
    | otherwise = vsep (map (number_patch description') pis_and_fs)
               $$ errstring
    where change_with_summary (hp, fs)
              | Just p <- hopefullyM hp = if OnlyChangesToFiles `elem` opts
                                          then description hp $$ text "" $$
                                               indent (showFriendly opts (filterFL xx $ effect p))
                                          else showFriendly opts p
              | otherwise = description hp
                            $$ indent (text "[this patch is unavailable]")
              where xx x = case list_touched_files x of
                             ys | null $ ys `intersect` fs -> IsEq
                             _ -> NotEq
          xml_with_summary hp
              | Just p <- hopefullyM hp = insert_before_lastline
                                           (to_xml $ info hp) (indent $ xml_summary p)
          xml_with_summary hp = to_xml (info hp)
          indent = prefix "    "
          actual_xml_changes = if Summary `elem` opts
                               then map xml_with_summary pis
                               else map (to_xml.info) pis
          xml_file_names = map (created_as_xml first_change) orig_fs
          first_change = if Reverse `elem` opts
                         then info $ head pis
                         else info $ last pis
          number_patch f x = if NumberPatches `elem` opts
                             then case get_number (fst x) of
                                  Just n -> text (show n++":") <+> f x
                                  Nothing -> f x
                             else f x
          get_number :: PatchInfoAnd p -> Maybe Int
          get_number y = gn 1 (concatRL patchset)
              where iy = info y
                    gn n (b:<:bs) | seq n (info b) == iy = Just n
                                  | otherwise = gn (n+1) bs
                    gn _ NilRL = Nothing
          pis = map fst pis_and_fs
          description' = description . fst

-- FIXME: this prose is unreadable. --twb, 2009-08
changes_help'' :: String
changes_help'' =
 "Three output formats exist.  The default is --human-readable.  You can\n" ++
 "also select --context, which is the internal format (as seen in patch\n" ++
 "bundles) that can be re-read by Darcs (e.g. `darcs get --context').\n" ++
 "\n" ++
 "Finally, there is --xml-output, which emits valid XML... unless a the\n" ++
 "patch metadata (author, name or description) contains a non-ASCII\n" ++
 "character and was recorded in a non-UTF8 locale.\n" ++
 "\n" ++
 -- FIXME: can't we just disallow the following usage?
 "Note that while the --context flag may be used in conjunction with\n" ++
 "--xml-output or --human-readable, in neither case will darcs get be\n" ++
 "able to read the output.  On the other hand, sufficient information\n" ++
 "WILL be output for a knowledgeable human to recreate the current state\n" ++
 "of the repository.\n"

changes_context :: RepoPatch p => Repository p -> [DarcsFlag] -> IO ()
changes_context repository opts = do
  r <- read_repo repository
  putStrLn "\nContext:\n"
  when (not $ null (unsafeUnRL r) || null (unsafeUnRL $ head $ unsafeUnRL r)) $
    putDocLnWith simplePrinters $ changelog opts' NilRL $
                 get_changes_info opts' []
                 (headRL (slightly_optimize_patchset r) :<: NilRL)
    where opts' = if HumanReadable `elem` opts || XMLOutput `elem` opts
                  then opts
                  else MachineReadable : opts
          headRL (x:<:_) = x
          headRL NilRL = impossible
\end{code}