1-- Copyright (C) 2004-2009 David Roundy, Eric Kow, Simon Michael, Tomas Caithaml 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 18module Darcs.UI.Commands.ShowAuthors 19 ( showAuthors, Spelling, compiledAuthorSpellings, canonizeAuthor, rankAuthors 20 ) where 21 22import Control.Arrow ( (&&&), (***) ) 23import Data.Char ( toLower, isSpace ) 24import Data.Function ( on ) 25import Data.List ( isInfixOf, sortBy, groupBy, group, sort ) 26import Data.Maybe( isJust ) 27import Data.Ord ( comparing ) 28import System.IO.Error ( catchIOError ) 29import Text.ParserCombinators.Parsec hiding ( lower, count, Line ) 30import Text.ParserCombinators.Parsec.Error 31import Text.Regex ( Regex, mkRegexWithOpts, matchRegex ) 32 33import Darcs.Prelude 34 35import Darcs.UI.Flags ( DarcsFlag, useCache, verbose ) 36import Darcs.UI.Options ( oid, odesc, ocheck, defaultFlags, (?) ) 37import qualified Darcs.UI.Options.All as O 38import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, putWarning, amInRepository ) 39import Darcs.UI.Completion ( noArgs ) 40import Darcs.UI.External ( viewDoc ) 41import Darcs.Patch.PatchInfoAnd ( info ) 42import Darcs.Patch.Info ( piAuthor ) 43import Darcs.Patch.Set ( patchSet2RL ) 44import Darcs.Repository ( readRepo, withRepository, RepoJob(..) ) 45import Darcs.Patch.Witnesses.Ordered ( mapRL ) 46import Darcs.Util.Lock ( readTextFile ) 47import Darcs.Util.Printer ( Doc, text ) 48import Darcs.Util.Path ( AbsolutePath ) 49 50data Spelling = Spelling String String [Regex] -- name, email, regexps 51type ParsedLine = Maybe Spelling -- Nothing for blank lines 52 53showAuthorsDescription :: String 54showAuthorsDescription = "List authors by patch count." 55 56showAuthorsHelp :: Doc 57showAuthorsHelp = text $ 58 "The `darcs show authors` command lists the authors of the current\n" ++ 59 "repository, sorted by the number of patches contributed. With the\n" ++ 60 "`--verbose` option, this command simply lists the author of each patch\n" ++ 61 "(without aggregation or sorting).\n" ++ 62 "\n" ++ 63 "An author's name or email address may change over time. To tell Darcs\n" ++ 64 "when multiple author strings refer to the same individual, create an\n" ++ 65 "`.authorspellings` file in the root of the working tree. Each line in\n" ++ 66 "this file begins with an author's canonical name and address, and may\n" ++ 67 "be followed by a comma separated list of extended regular expressions.\n" ++ 68 "Blank lines and lines beginning with two hyphens are ignored.\n" ++ 69 "The format of `.authorspelling` can be described by this pattern:\n" ++ 70 "\n" ++ 71 " name <address> [, regexp ]*\n" ++ 72 "\n" ++ 73 "There are some pitfalls concerning special characters:\n" ++ 74 "Whitespaces are stripped, if you need space in regexp use [ ]. \n" ++ 75 "Because comma serves as a separator you have to escape it if you want\n" ++ 76 "it in regexp. Note that `.authorspelling` use extended regular\n" ++ 77 "expressions so +, ? and so on are metacharacters and you need to \n" ++ 78 "escape them to be interpreted literally.\n" ++ 79 "\n" ++ 80 "Any patch with an author string that matches the canonical address or\n" ++ 81 "any of the associated regexps is considered to be the work of that\n" ++ 82 "author. All matching is case-insensitive and partial (it can match a\n" ++ 83 "substring). Use ^,$ to match the whole string in regexps\n" ++ 84 "\n" ++ 85 "Currently this canonicalization step is done only in `darcs show\n" ++ 86 "authors`. Other commands, such as `darcs log` use author strings\n" ++ 87 "verbatim.\n" ++ 88 "\n" ++ 89 "An example `.authorspelling` file is:\n" ++ 90 "\n" ++ 91 " -- This is a comment.\n" ++ 92 " Fred Nurk <fred@example.com>\n" ++ 93 " John Snagge <snagge@bbc.co.uk>, John, snagge@, js@(si|mit).edu\n" ++ 94 " Chuck Jones\\, Jr. <chuck@pobox.com>, cj\\+user@example.com\n" 95 96showAuthors :: DarcsCommand 97showAuthors = DarcsCommand 98 { commandProgramName = "darcs" 99 , commandName = "authors" 100 , commandHelp = showAuthorsHelp 101 , commandDescription = showAuthorsDescription 102 , commandExtraArgs = 0 103 , commandExtraArgHelp = [] 104 , commandCommand = authorsCmd 105 , commandPrereq = amInRepository 106 , commandCompleteArgs = noArgs 107 , commandArgdefaults = nodefaults 108 , commandAdvancedOptions = [] 109 , commandBasicOptions = odesc showAuthorsBasicOpts 110 , commandDefaults = defaultFlags showAuthorsOpts 111 , commandCheckOptions = ocheck showAuthorsOpts 112 } 113 where 114 showAuthorsBasicOpts = O.repoDir 115 showAuthorsOpts = showAuthorsBasicOpts `withStdOpts` oid 116 117authorsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () 118authorsCmd _ flags _ = withRepository (useCache ? flags) $ RepoJob $ \repository -> do 119 patches <- readRepo repository 120 spellings <- compiledAuthorSpellings flags 121 let authors = mapRL (piAuthor . info) $ patchSet2RL patches 122 viewDoc $ text $ unlines $ 123 if verbose flags 124 then authors 125 else rankAuthors spellings authors 126 127rankAuthors :: [Spelling] -> [String] -> [String] 128rankAuthors spellings authors = 129 -- A list of the form ["#<rank> <count> <canonical name>"]. 130 -- Turn the final result into a list of strings. 131 map (\ (rank, (count, name)) -> "#" ++ show rank ++ "\t" 132 ++ show count ++ "\t" ++ name) . 133 zip ([1..] :: [Int]) . 134 -- Sort by descending patch count. 135 reverse $ sortBy (comparing fst) . 136 -- Combine duplicates from a list [(count, canonized name)] 137 -- with duplicates canonized names (see next comment). 138 map ((sum *** head) . unzip) . 139 groupBy ((==) `on` snd) . 140 sortBy (comparing snd) . 141 -- Because it would take a long time to canonize "foo" into 142 -- "foo <foo@bar.baz>" once per patch, the code below 143 -- generates a list [(count, canonized name)]. 144 map (length &&& (canonizeAuthor spellings . head)) . 145 group $ sort authors 146 147canonizeAuthor :: [Spelling] -> String -> String 148canonizeAuthor spells author = getName canonicals 149 where 150 getName [] = author 151 getName (Spelling name email _ : _) = name ++ " <" ++ email ++ ">" 152 canonicals = filter (ismatch author) spells 153 ismatch s (Spelling _ mail regexps) = 154 s `correspondsTo` mail || any (s `contains_regex`) regexps 155 contains_regex a r = isJust $ matchRegex r a 156 correspondsTo a b = lower b `isInfixOf` lower a 157 lower = map toLower 158 159compiledAuthorSpellings :: [DarcsFlag] -> IO [Spelling] 160compiledAuthorSpellings flags = do 161 let as_file = ".authorspellings" 162 content_lines <- readTextFile as_file `catchIOError` (const (return [])) 163 let parse_results = map (parse sentence as_file) content_lines 164 clean 1 parse_results 165 where 166 clean :: Int -> [Either ParseError ParsedLine] -> IO [Spelling] 167 clean _ [] = return [] 168 -- print parse error 169 clean n (Left err : xs) = do 170 let npos = setSourceLine (errorPos err) n 171 putWarning flags . text . show $ setErrorPos npos err 172 clean (n + 1) xs 173 -- skip blank line 174 clean n (Right Nothing : xs) = clean (n + 1) xs 175 -- unwrap Spelling 176 clean n (Right (Just a) : xs) = do 177 as <- clean (n + 1) xs 178 return (a : as) 179 180---------- 181-- PARSERS 182 183sentence :: Parser ParsedLine 184sentence = spaces >> (comment <|> blank <|> addressline) 185 where 186 comment = string "--" >> return Nothing 187 blank = eof >> return Nothing 188 189addressline :: Parser ParsedLine 190addressline = do 191 name <- canonicalName <?> "Canonical name" 192 addr <- between (char '<') (char '>') (many1 (noneOf ">")) <?> "Address" 193 spaces 194 rest <- option [] (char ',' >> regexp `sepBy` char ',') 195 <?> "List of regexps" 196 return $ Just $ Spelling (strip name) addr (compile rest) 197 where 198 strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse 199 makeRegex s = mkRegexWithOpts s True False 200 compile = map makeRegex . filter (not . null) . map strip 201 202 parseComma = string "\\," >> return ',' 203 204 regexp :: Parser String 205 regexp = many1 p <?> "Regular expression" 206 where 207 p = try parseComma <|> noneOf "," 208 209 canonicalName :: Parser String 210 canonicalName = many1 p 211 where 212 p = try parseComma <|> noneOf ",<" 213