1 %  Copyright (C) 2004-2009 David Roundy, Eric Kow, Simon Michael
    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 
   18 \darcsCommand{show authors}
   19 \begin{code}
   20 {-# OPTIONS_GHC -cpp #-}
   21 module Darcs.Commands.ShowAuthors ( show_authors ) where
   22 
   23 import Control.Arrow ((&&&), (***))
   24 import Data.List ( sort, sortBy, group, groupBy, isInfixOf, isPrefixOf )
   25 import Data.Ord (comparing)
   26 import Data.Char ( toLower, isSpace )
   27 import Text.Regex ( Regex, mkRegexWithOpts, matchRegex )
   28 
   29 import Darcs.Arguments ( DarcsFlag(..), working_repo_dir )
   30 import Darcs.Commands ( DarcsCommand(..), nodefaults )
   31 import Darcs.External ( viewDoc )
   32 import Darcs.Hopefully ( info )
   33 import Darcs.Repository ( amInRepository, read_repo, withRepository, ($-) )
   34 import Darcs.Patch.Info ( pi_author )
   35 import Darcs.Ordered ( mapRL, concatRL )
   36 import Printer ( text )
   37 import Data.Function (on)
   38 
   39 show_authors_description :: String
   40 show_authors_description = "List authors by patch count."
   41 
   42 show_authors_help :: String
   43 show_authors_help =
   44  "The `darcs show authors' command lists the authors of the current\n" ++
   45  "repository, sorted by the number of patches contributed.  With the\n" ++
   46  "--verbose option, this command simply lists the author of each patch\n" ++
   47  "(without aggregation or sorting).\n" ++
   48  "\n" ++
   49  "An author's name or email address may change over time.  To tell Darcs\n" ++
   50  "when multiple author strings refer to the same individual, create an\n" ++
   51  "`.authorspellings' file in the root of the working tree.  Each line in\n" ++
   52  "this file begins with an author's canonical name and address, and may\n" ++
   53  "be followed by a comma and zero or more extended regular expressions,\n" ++
   54  "separated by commas.  Blank lines and lines beginning with two\n" ++
   55  "hyphens, are ignored.\n" ++
   56  "\n" ++
   57  "Any patch with an author string that matches the canonical address or\n" ++
   58  "any of the associated regexps is considered to be the work of that\n" ++
   59  "author.  All matching is case-insensitive and partial (it can match a\n" ++
   60  "substring).\n" ++
   61  "\n" ++
   62  "Currently this canonicalization step is done only in `darcs show\n" ++
   63  "authors'.  Other commands, such as `darcs changes' use author strings\n" ++
   64  "verbatim.\n" ++
   65  "\n" ++
   66  "An example .authorspelling file is:\n" ++
   67  "\n" ++
   68  "    -- This is a comment.\n" ++
   69  "    Fred Nurk <fred@example.com>\n" ++
   70  "    John Snagge <snagge@bbc.co.uk>, John, snagge@, js@(si|mit).edu\n"
   71 
   72 show_authors :: DarcsCommand
   73 show_authors = DarcsCommand {
   74   command_name = "authors",
   75   command_help = show_authors_help,
   76   command_description = show_authors_description,
   77   command_extra_args = 0,
   78   command_extra_arg_help = [],
   79   command_command = authors_cmd,
   80   command_prereq = amInRepository,
   81   command_get_arg_possibilities = return [],
   82   command_argdefaults = nodefaults,
   83   command_advanced_options = [],
   84   command_basic_options = [working_repo_dir] }
   85 
   86 authors_cmd :: [DarcsFlag] -> [String] -> IO ()
   87 authors_cmd opts _ = withRepository opts $- \repository -> do
   88   patches <- read_repo repository
   89   spellings <- compiled_author_spellings
   90   let authors = mapRL (pi_author . info) $ concatRL patches
   91   viewDoc $ text $ unlines $
   92    if Verbose `elem` opts
   93     then authors
   94     else -- A list of the form ["<count> <canonical name>"]...
   95 
   96       -- Turn the final result into a list of strings.
   97       map (\ (count, name) -> show count ++ "\t" ++ name) $
   98       -- Sort by descending patch count.
   99       reverse $ sortBy (comparing fst) $
  100       -- Combine duplicates from a list [(count, canonized name)]
  101       -- with duplicates canonized names (see next comment).
  102       map ((sum *** head) . unzip) $
  103       groupBy ((==) `on` snd) $
  104       sortBy  (comparing snd) $
  105       -- Because it would take a long time to canonize "foo" into
  106       -- "foo <foo@bar.baz>" once per patch, the code below
  107       -- generates a list [(count, canonized name)].
  108       map (length &&& (canonize_author spellings . head)) $
  109       group $ sort authors
  110 
  111 canonize_author :: [(String,[Regex])] -> String -> String
  112 canonize_author [] a = a
  113 canonize_author spellings a = safehead a $ canonicalsfor a
  114     where
  115       safehead x xs = if null xs then x else head xs
  116       canonicalsfor s = map fst $ filter (ismatch s) spellings
  117       ismatch s (canonical,regexps) =
  118           (not (null email) && (s `contains` email)) || (any (s `contains_regex`) regexps)
  119           where email = takeWhile (/= '>') $ drop 1 $ dropWhile (/= '<') canonical
  120 
  121 contains :: String -> String -> Bool
  122 a `contains` b = lower b `isInfixOf` (lower a) where lower = map toLower
  123 
  124 contains_regex :: String -> Regex -> Bool
  125 a `contains_regex` r = case matchRegex r a of
  126                          Just _ -> True
  127                          _ -> False
  128 
  129 compiled_author_spellings :: IO [(String,[Regex])]
  130 compiled_author_spellings = do
  131   ss <- author_spellings_from_file
  132   return $ map compile $ ss
  133     where
  134       compile [] = error "each author spelling should contain at least the canonical form"
  135       compile (canonical:pats) = (canonical, map mkregex pats)
  136       mkregex pat = mkRegexWithOpts pat True False
  137 
  138 authorspellingsfile :: FilePath
  139 authorspellingsfile = ".authorspellings"
  140 
  141 author_spellings_from_file :: IO [[String]]
  142 author_spellings_from_file = do
  143   s <- readFile -- ratify readFile: never unlinked from within darcs
  144          authorspellingsfile `catch` (\_ -> return "")
  145   let noncomments = filter (not . ("--" `isPrefixOf`)) $
  146                     filter (not . null) $ map strip $ lines s
  147   return $ map (map strip . split_on ',') noncomments
  148 
  149 split_on :: Eq a => a -> [a] -> [[a]]
  150 split_on e l =
  151     case dropWhile (e==) l of
  152       [] -> []
  153       l' -> first : split_on e rest
  154         where
  155           (first,rest) = break (e==) l'
  156 
  157 strip :: String -> String
  158 strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse
  159 
  160 \end{code}