ShowAuthors.lhs

%  Copyright (C) 2004-2009 David Roundy, Eric Kow, Simon Michael
%
%  This program is free software; you can redistribute it and/or modify
%  it under the terms of the GNU General Public License as published by
%  the Free Software Foundation; either version 2, or (at your option)
%  any later version.
%
%  This program is distributed in the hope that it will be useful,
%  but WITHOUT ANY WARRANTY; without even the implied warranty of
%  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
%  GNU General Public License for more details.
%
%  You should have received a copy of the GNU General Public License
%  along with this program; see the file COPYING.  If not, write to
%  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
%  Boston, MA 02110-1301, USA.

\darcsCommand{show authors}
\begin{code}
{-# OPTIONS_GHC -cpp #-}
module Darcs.Commands.ShowAuthors ( show_authors ) where

import Control.Arrow ((&&&), (***))
import Data.List ( sort, sortBy, group, groupBy, isInfixOf, isPrefixOf )
import Data.Ord (comparing)
import Data.Char ( toLower, isSpace )
import Text.Regex ( Regex, mkRegexWithOpts, matchRegex )

import Darcs.Arguments ( DarcsFlag(..), working_repo_dir )
import Darcs.Commands ( DarcsCommand(..), nodefaults )
import Darcs.External ( viewDoc )
import Darcs.Hopefully ( info )
import Darcs.Repository ( amInRepository, read_repo, withRepository, ($-) )
import Darcs.Patch.Info ( pi_author )
import Darcs.Ordered ( mapRL, concatRL )
import Printer ( text )
import Data.Function (on)

show_authors_description :: String
show_authors_description = "List authors by patch count."

show_authors_help :: String
show_authors_help =
 "The `darcs show authors' command lists the authors of the current\n" ++
 "repository, sorted by the number of patches contributed.  With the\n" ++
 "--verbose option, this command simply lists the author of each patch\n" ++
 "(without aggregation or sorting).\n" ++
 "\n" ++
 "An author's name or email address may change over time.  To tell Darcs\n" ++
 "when multiple author strings refer to the same individual, create an\n" ++
 "`.authorspellings' file in the root of the working tree.  Each line in\n" ++
 "this file begins with an author's canonical name and address, and may\n" ++
 "be followed by a comma and zero or more extended regular expressions,\n" ++
 "separated by commas.  Blank lines and lines beginning with two\n" ++
 "hyphens, are ignored.\n" ++
 "\n" ++
 "Any patch with an author string that matches the canonical address or\n" ++
 "any of the associated regexps is considered to be the work of that\n" ++
 "author.  All matching is case-insensitive and partial (it can match a\n" ++
 "substring).\n" ++
 "\n" ++
 "Currently this canonicalization step is done only in `darcs show\n" ++
 "authors'.  Other commands, such as `darcs changes' use author strings\n" ++
 "verbatim.\n" ++
 "\n" ++
 "An example .authorspelling file is:\n" ++
 "\n" ++
 "    -- This is a comment.\n" ++
 "    Fred Nurk <fred@example.com>\n" ++
 "    John Snagge <snagge@bbc.co.uk>, John, snagge@, js@(si|mit).edu\n"

show_authors :: DarcsCommand
show_authors = DarcsCommand {
  command_name = "authors",
  command_help = show_authors_help,
  command_description = show_authors_description,
  command_extra_args = 0,
  command_extra_arg_help = [],
  command_command = authors_cmd,
  command_prereq = amInRepository,
  command_get_arg_possibilities = return [],
  command_argdefaults = nodefaults,
  command_advanced_options = [],
  command_basic_options = [working_repo_dir] }

authors_cmd :: [DarcsFlag] -> [String] -> IO ()
authors_cmd opts _ = withRepository opts $- \repository -> do
  patches <- read_repo repository
  spellings <- compiled_author_spellings
  let authors = mapRL (pi_author . info) $ concatRL patches
  viewDoc $ text $ unlines $
   if Verbose `elem` opts
    then authors
    else -- A list of the form ["<count> <canonical name>"]...

      -- Turn the final result into a list of strings.
      map (\ (count, name) -> show count ++ "\t" ++ name) $
      -- Sort by descending patch count.
      reverse $ sortBy (comparing fst) $
      -- Combine duplicates from a list [(count, canonized name)]
      -- with duplicates canonized names (see next comment).
      map ((sum *** head) . unzip) $
      groupBy ((==) `on` snd) $
      sortBy  (comparing snd) $
      -- Because it would take a long time to canonize "foo" into
      -- "foo <foo@bar.baz>" once per patch, the code below
      -- generates a list [(count, canonized name)].
      map (length &&& (canonize_author spellings . head)) $
      group $ sort authors

canonize_author :: [(String,[Regex])] -> String -> String
canonize_author [] a = a
canonize_author spellings a = safehead a $ canonicalsfor a
    where
      safehead x xs = if null xs then x else head xs
      canonicalsfor s = map fst $ filter (ismatch s) spellings
      ismatch s (canonical,regexps) =
          (not (null email) && (s `contains` email)) || (any (s `contains_regex`) regexps)
          where email = takeWhile (/= '>') $ drop 1 $ dropWhile (/= '<') canonical

contains :: String -> String -> Bool
a `contains` b = lower b `isInfixOf` (lower a) where lower = map toLower

contains_regex :: String -> Regex -> Bool
a `contains_regex` r = case matchRegex r a of
                         Just _ -> True
                         _ -> False

compiled_author_spellings :: IO [(String,[Regex])]
compiled_author_spellings = do
  ss <- author_spellings_from_file
  return $ map compile $ ss
    where
      compile [] = error "each author spelling should contain at least the canonical form"
      compile (canonical:pats) = (canonical, map mkregex pats)
      mkregex pat = mkRegexWithOpts pat True False

authorspellingsfile :: FilePath
authorspellingsfile = ".authorspellings"

author_spellings_from_file :: IO [[String]]
author_spellings_from_file = do
  s <- readFile -- ratify readFile: never unlinked from within darcs
         authorspellingsfile `catch` (\_ -> return "")
  let noncomments = filter (not . ("--" `isPrefixOf`)) $
                    filter (not . null) $ map strip $ lines s
  return $ map (map strip . split_on ',') noncomments

split_on :: Eq a => a -> [a] -> [[a]]
split_on e l =
    case dropWhile (e==) l of
      [] -> []
      l' -> first : split_on e rest
        where
          (first,rest) = break (e==) l'

strip :: String -> String
strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse

\end{code}