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