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