1--  Copyright (C) 2003 David Roundy, 2010-2011 Petr Rockai
2--
3--  This program is free software; you can redistribute it and/or modify
4--  it under the terms of the GNU General Public License as published by
5--  the Free Software Foundation; either version 2, or (at your option)
6--  any later version.
7--
8--  This program is distributed in the hope that it will be useful,
9--  but WITHOUT ANY WARRANTY; without even the implied warranty of
10--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
11--  GNU General Public License for more details.
12--
13--  You should have received a copy of the GNU General Public License
14--  along with this program; see the file COPYING.  If not, write to
15--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
16--  Boston, MA 02110-1301, USA.
17{-# LANGUAGE OverloadedStrings #-}
18
19module Darcs.UI.Commands.Annotate ( annotate ) where
20
21import Darcs.Prelude
22
23import Control.Monad ( when )
24
25import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )
26import Darcs.UI.Completion ( knownFileArgs )
27import Darcs.UI.External ( viewDocWith )
28import Darcs.UI.Flags ( DarcsFlag, useCache, patchIndexYes, pathsFromArgs )
29import Darcs.UI.Options ( (^), odesc, ocheck
30                        , defaultFlags, parseFlags, (?) )
31import qualified Darcs.UI.Options.All as O
32
33import Darcs.Repository.State ( readRecorded )
34import Darcs.Repository
35    ( withRepository
36    , withRepoLockCanFail
37    , RepoJob(..)
38    , readRepo
39    )
40import Darcs.Repository.PatchIndex ( attemptCreatePatchIndex )
41import Darcs.Patch.Set ( patchSet2RL )
42import qualified Data.ByteString.Char8 as BC ( pack, concat, intercalate )
43import Data.ByteString.Lazy ( toChunks )
44import Darcs.Patch.ApplyMonad( withFileNames )
45import Darcs.Patch.Match ( patchSetMatch, rollbackToPatchSetMatch  )
46import Darcs.Repository.Match ( getOnePatchset )
47import Darcs.Repository.PatchIndex ( getRelevantSubsequence, canUsePatchIndex )
48import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal )
49import qualified Darcs.Patch.Annotate as A
50
51import Darcs.Util.Tree( TreeItem(..) )
52import qualified Darcs.Util.Tree as T ( readBlob, list, expand )
53import Darcs.Util.Tree.Monad( findM, virtualTreeIO )
54import Darcs.Util.Path( AbsolutePath, AnchoredPath, displayPath, catPaths )
55import Darcs.Util.Printer ( Doc, simplePrinters, renderString, text )
56import Darcs.Util.Exception ( die )
57
58annotateDescription :: String
59annotateDescription = "Annotate lines of a file with the last patch that modified it."
60
61annotateHelp :: Doc
62annotateHelp = text $ unlines
63 [ "When `darcs annotate` is called on a file, it will find the patch that"
64 , "last modified each line in that file. This also works on directories."
65 , ""
66 , "The `--machine-readable` option can be used to generate output for"
67 , "machine postprocessing."
68 ]
69
70annotate :: DarcsCommand
71annotate = DarcsCommand
72    { commandProgramName = "darcs"
73    , commandName = "annotate"
74    , commandHelp = annotateHelp
75    , commandDescription = annotateDescription
76    , commandExtraArgs = 1
77    , commandExtraArgHelp = ["[FILE or DIRECTORY]"]
78    , commandCommand = annotateCmd
79    , commandPrereq = amInHashedRepository
80    , commandCompleteArgs = knownFileArgs
81    , commandArgdefaults = nodefaults
82    , commandAdvancedOptions = odesc annotateAdvancedOpts
83    , commandBasicOptions = odesc annotateBasicOpts
84    , commandDefaults = defaultFlags annotateOpts
85    , commandCheckOptions = ocheck annotateOpts
86    }
87  where
88    annotateBasicOpts = O.machineReadable ^ O.matchUpToOne ^ O.repoDir
89    annotateAdvancedOpts = O.patchIndexYes
90    annotateOpts = annotateBasicOpts `withStdOpts` annotateAdvancedOpts
91
92annotateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
93annotateCmd fps opts args = do
94  paths <- pathsFromArgs fps args
95  case paths of
96    [path] -> do
97      when (patchIndexYes ? opts == O.YesPatchIndex)
98        $ withRepoLockCanFail (useCache ? opts)
99        $ RepoJob (\repo -> readRepo repo >>= attemptCreatePatchIndex repo)
100      annotateCmd' opts path
101    _ -> die "Error: annotate requires a single filepath argument"
102
103annotateCmd' :: [DarcsFlag] -> AnchoredPath -> IO ()
104annotateCmd' opts fixed_path = withRepository (useCache ? opts) $ RepoJob $ \repository -> do
105  let matchFlags = parseFlags O.matchUpToOne opts
106  r <- readRepo repository
107  recorded <- readRecorded repository
108  (patches, initial, path) <-
109    case patchSetMatch matchFlags of
110      Just psm -> do
111        Sealed x <- getOnePatchset repository psm
112        let (_, [path'], _) =
113              withFileNames Nothing [fixed_path] (rollbackToPatchSetMatch psm r)
114        initial <- snd `fmap` virtualTreeIO (rollbackToPatchSetMatch psm r) recorded
115        return (seal $ patchSet2RL x, initial, path')
116      Nothing ->
117        return (seal $ patchSet2RL r, recorded, fixed_path)
118
119  found <- findM initial path
120  -- TODO need to decide about the --machine flag
121  let (fmt, view) = if parseFlags O.machineReadable opts
122                      then (A.machineFormat, putStrLn . renderString)
123                      else (A.format, viewDocWith simplePrinters)
124  usePatchIndex <- (O.yes (O.patchIndexYes ? opts) &&) <$> canUsePatchIndex repository
125  case found of
126    Nothing -> die $ "Error: path not found in repository: " ++ displayPath fixed_path
127    Just (SubTree s) -> do
128      -- TODO the semantics and implementation of annotating of directories need to be revised
129      s' <- T.expand s
130      let subs = map (catPaths path . fst) $ T.list s'
131          showPath (n, File _) = BC.pack $ displayPath $ path `catPaths` n
132          showPath (n, _) = BC.concat [BC.pack $ displayPath $ path `catPaths` n, "/"]
133      (Sealed ans_patches) <- do
134         if not usePatchIndex
135            then return patches
136            else getRelevantSubsequence patches repository r subs
137      view . text $
138        fmt (BC.intercalate "\n" $ map showPath $ T.list s') $
139        A.annotateDirectory ans_patches path subs
140    Just (File b) -> do (Sealed ans_patches) <- do
141                           if not usePatchIndex
142                              then return patches
143                              else getRelevantSubsequence patches repository r [path]
144                        con <- BC.concat `fmap` toChunks `fmap` T.readBlob b
145                        view $ text . fmt con $
146                          A.annotateFile ans_patches path con
147    Just (Stub _ _) -> error "impossible case"
148