--  Copyright (C) 2004-2009 David Roundy, Eric Kow, Simon Michael, Tomas Caithaml
--
--  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.

module Darcs.UI.Commands.ShowAuthors
    ( showAuthors, Spelling, compiledAuthorSpellings, canonizeAuthor, rankAuthors
    ) where

import Control.Arrow ( (&&&), (***) )
import Data.Char ( toLower, isSpace )
import Data.Function ( on )
import Data.List ( isInfixOf, sortBy, groupBy, group, sort )
import Data.Maybe( isJust )
import Data.Ord ( comparing )
import System.IO.Error ( catchIOError )
import Text.ParserCombinators.Parsec hiding ( lower, count, Line )
import Text.ParserCombinators.Parsec.Error
import Text.Regex ( Regex, mkRegexWithOpts, matchRegex )

import Darcs.Prelude

import Darcs.UI.Flags ( DarcsFlag, useCache, verbose )
import Darcs.UI.Options ( oid, odesc, ocheck, defaultFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, putWarning, amInRepository )
import Darcs.UI.Completion ( noArgs )
import Darcs.UI.External ( viewDoc )
import Darcs.Patch.PatchInfoAnd ( info )
import Darcs.Patch.Info ( piAuthor )
import Darcs.Patch.Set ( patchSet2RL )
import Darcs.Repository ( readRepo, withRepository, RepoJob(..) )
import Darcs.Patch.Witnesses.Ordered ( mapRL )
import Darcs.Util.Lock ( readTextFile )
import Darcs.Util.Printer ( Doc, text )
import Darcs.Util.Path ( AbsolutePath )

data Spelling = Spelling String String [Regex] -- name, email, regexps
type ParsedLine = Maybe Spelling -- Nothing for blank lines

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

showAuthorsHelp :: Doc
showAuthorsHelp :: Doc
showAuthorsHelp = String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$
 String
"The `darcs show authors` command lists the authors of the current\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"repository, sorted by the number of patches contributed.  With the\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"`--verbose` option, this command simply lists the author of each patch\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"(without aggregation or sorting).\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"An author's name or email address may change over time.  To tell Darcs\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"when multiple author strings refer to the same individual, create an\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"`.authorspellings` file in the root of the working tree.  Each line in\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"this file begins with an author's canonical name and address, and may\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"be followed by a comma separated list of extended regular expressions.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"Blank lines and lines beginning with two hyphens are ignored.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"The format of `.authorspelling` can be described by this pattern:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"    name <address> [, regexp ]*\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"There are some pitfalls concerning special characters:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"Whitespaces are stripped, if you need space in regexp use [ ]. \n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"Because comma serves as a separator you have to escape it if you want\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"it in regexp. Note that `.authorspelling` use extended regular\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"expressions so +, ? and so on are metacharacters and you need to \n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"escape them to be interpreted literally.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"Any patch with an author string that matches the canonical address or\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"any of the associated regexps is considered to be the work of that\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"author.  All matching is case-insensitive and partial (it can match a\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"substring). Use ^,$ to match the whole string in regexps\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"Currently this canonicalization step is done only in `darcs show\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"authors`.  Other commands, such as `darcs log` use author strings\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"verbatim.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"An example `.authorspelling` file is:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"    -- This is a comment.\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"    Fred Nurk <fred@example.com>\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"    John Snagge <snagge@bbc.co.uk>, John, snagge@, js@(si|mit).edu\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
 String
"    Chuck Jones\\, Jr. <chuck@pobox.com>, cj\\+user@example.com\n"

showAuthors :: DarcsCommand
showAuthors :: DarcsCommand
showAuthors = DarcsCommand :: String
-> String
-> Doc
-> String
-> Int
-> [String]
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO ())
-> ([DarcsFlag] -> IO (Either String ()))
-> ((AbsolutePath, AbsolutePath)
    -> [DarcsFlag] -> [String] -> IO [String])
-> ([DarcsFlag] -> AbsolutePath -> [String] -> IO [String])
-> [DarcsOptDescr DarcsFlag]
-> [DarcsOptDescr DarcsFlag]
-> [DarcsFlag]
-> ([DarcsFlag] -> [String])
-> DarcsCommand
DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"authors"
    , commandHelp :: Doc
commandHelp = Doc
showAuthorsHelp
    , commandDescription :: String
commandDescription = String
showAuthorsDescription
    , commandExtraArgs :: Int
commandExtraArgs = Int
0
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = []
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
authorsCmd
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInRepository
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
noArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
nodefaults
    , commandAdvancedOptions :: [DarcsOptDescr DarcsFlag]
commandAdvancedOptions = []
    , commandBasicOptions :: [DarcsOptDescr DarcsFlag]
commandBasicOptions = OptSpec DarcsOptDescr DarcsFlag Any (Maybe String -> Any)
-> [DarcsOptDescr DarcsFlag]
forall (d :: * -> *) f a b. OptSpec d f a b -> [d f]
odesc OptSpec DarcsOptDescr DarcsFlag Any (Maybe String -> Any)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe String)
showAuthorsBasicOpts
    , commandDefaults :: [DarcsFlag]
commandDefaults = OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> [DarcsFlag]
forall (d :: * -> *) f b. OptSpec d f [f] b -> [f]
defaultFlags OptSpec
  DarcsOptDescr
  DarcsFlag
  [DarcsFlag]
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall a.
DarcsOption
  a
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
showAuthorsOpts
    , commandCheckOptions :: [DarcsFlag] -> [String]
commandCheckOptions = OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
-> [DarcsFlag] -> [String]
forall (d :: * -> *) f a b. OptSpec d f a b -> [f] -> [String]
ocheck OptSpec
  DarcsOptDescr
  DarcsFlag
  Any
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> Any)
forall a.
DarcsOption
  a
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
showAuthorsOpts
    }
  where
    showAuthorsBasicOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe String)
showAuthorsBasicOpts = PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe String)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe String)
O.repoDir
    showAuthorsOpts :: DarcsOption
  a
  (Maybe String
   -> Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
showAuthorsOpts = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String)
forall a. PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe String)
showAuthorsBasicOpts PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> HooksConfig
   -> Bool
   -> Bool
   -> Bool
   -> a)
  (Maybe String)
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
-> DarcsOption
     a
     (Maybe String
      -> Maybe StdCmdAction
      -> Verbosity
      -> UseCache
      -> HooksConfig
      -> Bool
      -> Bool
      -> Bool
      -> a)
forall b c a.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a) b
-> DarcsOption a c
`withStdOpts` DarcsOption
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
  (UseCache -> HooksConfig -> Bool -> Bool -> Bool -> a)
forall (d :: * -> *) f a. OptSpec d f a a
oid

authorsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
authorsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
authorsCmd (AbsolutePath, AbsolutePath)
_ [DarcsFlag]
flags [String]
_ = UseCache -> RepoJob () -> IO ()
forall a. UseCache -> RepoJob a -> IO a
withRepository (PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
flags) (RepoJob () -> IO ()) -> RepoJob () -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob ((forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
  (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
  Repository rt p wR wU wR -> IO ())
 -> RepoJob ())
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
    (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
    Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a b. (a -> b) -> a -> b
$ \Repository rt p wR wU wR
repository -> do
    PatchSet rt p Origin wR
patches <- Repository rt p wR wU wR -> IO (PatchSet rt p Origin wR)
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p) =>
Repository rt p wR wU wT -> IO (PatchSet rt p Origin wR)
readRepo Repository rt p wR wU wR
repository
    [Spelling]
spellings <- [DarcsFlag] -> IO [Spelling]
compiledAuthorSpellings [DarcsFlag]
flags
    let authors :: [String]
authors = (forall wW wZ. PatchInfoAnd rt p wW wZ -> String)
-> RL (PatchInfoAnd rt p) Origin wR -> [String]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> RL a wX wY -> [b]
mapRL (PatchInfo -> String
piAuthor (PatchInfo -> String)
-> (PatchInfoAndG rt (Named p) wW wZ -> PatchInfo)
-> PatchInfoAndG rt (Named p) wW wZ
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAndG rt (Named p) wW wZ -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info) (RL (PatchInfoAnd rt p) Origin wR -> [String])
-> RL (PatchInfoAnd rt p) Origin wR -> [String]
forall a b. (a -> b) -> a -> b
$ PatchSet rt p Origin wR -> RL (PatchInfoAnd rt p) Origin wR
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> RL (PatchInfoAnd rt p) wStart wX
patchSet2RL PatchSet rt p Origin wR
patches
    Doc -> IO ()
viewDoc (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
        if [DarcsFlag] -> Bool
verbose [DarcsFlag]
flags
            then [String]
authors
            else [Spelling] -> [String] -> [String]
rankAuthors [Spelling]
spellings [String]
authors

rankAuthors :: [Spelling] -> [String] -> [String]
rankAuthors :: [Spelling] -> [String] -> [String]
rankAuthors [Spelling]
spellings [String]
authors =
              -- A list of the form ["#<rank> <count> <canonical name>"].
              -- Turn the final result into a list of strings.
              ((Int, (Int, String)) -> String)
-> [(Int, (Int, String))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Int
rank, (Int
count, String
name)) -> String
"#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
rank String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\t"
                                              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
count String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\t" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name) ([(Int, (Int, String))] -> [String])
-> ([(Int, String)] -> [(Int, (Int, String))])
-> [(Int, String)]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              [Int] -> [(Int, String)] -> [(Int, (Int, String))]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
1..] :: [Int]) ([(Int, String)] -> [(Int, (Int, String))])
-> ([(Int, String)] -> [(Int, String)])
-> [(Int, String)]
-> [(Int, (Int, String))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              -- Sort by descending patch count.
              [(Int, String)] -> [(Int, String)]
forall a. [a] -> [a]
reverse ([(Int, String)] -> [String]) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> a -> b
$ ((Int, String) -> (Int, String) -> Ordering)
-> [(Int, String)] -> [(Int, String)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Int, String) -> Int)
-> (Int, String) -> (Int, String) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, String) -> Int
forall a b. (a, b) -> a
fst) ([(Int, String)] -> [(Int, String)])
-> ([String] -> [(Int, String)]) -> [String] -> [(Int, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              -- Combine duplicates from a list [(count, canonized name)]
              -- with duplicates canonized names (see next comment).
              ([(Int, String)] -> (Int, String))
-> [[(Int, String)]] -> [(Int, String)]
forall a b. (a -> b) -> [a] -> [b]
map (([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int)
-> ([String] -> String) -> ([Int], [String]) -> (Int, String)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** [String] -> String
forall a. [a] -> a
head) (([Int], [String]) -> (Int, String))
-> ([(Int, String)] -> ([Int], [String]))
-> [(Int, String)]
-> (Int, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, String)] -> ([Int], [String])
forall a b. [(a, b)] -> ([a], [b])
unzip) ([[(Int, String)]] -> [(Int, String)])
-> ([String] -> [[(Int, String)]]) -> [String] -> [(Int, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              ((Int, String) -> (Int, String) -> Bool)
-> [(Int, String)] -> [[(Int, String)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) (String -> String -> Bool)
-> ((Int, String) -> String)
-> (Int, String)
-> (Int, String)
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Int, String) -> String
forall a b. (a, b) -> b
snd) ([(Int, String)] -> [[(Int, String)]])
-> ([String] -> [(Int, String)]) -> [String] -> [[(Int, String)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              ((Int, String) -> (Int, String) -> Ordering)
-> [(Int, String)] -> [(Int, String)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy  (((Int, String) -> String)
-> (Int, String) -> (Int, String) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, String) -> String
forall a b. (a, b) -> b
snd) ([(Int, String)] -> [(Int, String)])
-> ([String] -> [(Int, String)]) -> [String] -> [(Int, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              -- 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)].
              ([String] -> (Int, String)) -> [[String]] -> [(Int, String)]
forall a b. (a -> b) -> [a] -> [b]
map ([String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([String] -> Int)
-> ([String] -> String) -> [String] -> (Int, String)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& ([Spelling] -> String -> String
canonizeAuthor [Spelling]
spellings (String -> String) -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
forall a. [a] -> a
head)) ([[String]] -> [(Int, String)])
-> ([String] -> [[String]]) -> [String] -> [(Int, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              [String] -> [[String]]
forall a. Eq a => [a] -> [[a]]
group ([String] -> [(Int, String)]) -> [String] -> [(Int, String)]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. Ord a => [a] -> [a]
sort [String]
authors

canonizeAuthor :: [Spelling] -> String -> String
canonizeAuthor :: [Spelling] -> String -> String
canonizeAuthor [Spelling]
spells String
author = [Spelling] -> String
getName [Spelling]
canonicals
  where
    getName :: [Spelling] -> String
getName [] = String
author
    getName (Spelling String
name String
email [Regex]
_ : [Spelling]
_) = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" <" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
email String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
    canonicals :: [Spelling]
canonicals = (Spelling -> Bool) -> [Spelling] -> [Spelling]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> Spelling -> Bool
ismatch String
author) [Spelling]
spells
    ismatch :: String -> Spelling -> Bool
ismatch String
s (Spelling String
_ String
mail [Regex]
regexps) =
        String
s String -> String -> Bool
`correspondsTo` String
mail Bool -> Bool -> Bool
|| (Regex -> Bool) -> [Regex] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String
s String -> Regex -> Bool
`contains_regex`) [Regex]
regexps
    contains_regex :: String -> Regex -> Bool
contains_regex String
a Regex
r = Maybe [String] -> Bool
forall a. Maybe a -> Bool
isJust (Maybe [String] -> Bool) -> Maybe [String] -> Bool
forall a b. (a -> b) -> a -> b
$ Regex -> String -> Maybe [String]
matchRegex Regex
r String
a
    correspondsTo :: String -> String -> Bool
correspondsTo String
a String
b = String -> String
lower String
b String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String -> String
lower String
a
    lower :: String -> String
lower = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower

compiledAuthorSpellings :: [DarcsFlag] -> IO [Spelling]
compiledAuthorSpellings :: [DarcsFlag] -> IO [Spelling]
compiledAuthorSpellings [DarcsFlag]
flags = do
    let as_file :: String
as_file = String
".authorspellings"
    [String]
content_lines <- String -> IO [String]
forall p. FilePathLike p => p -> IO [String]
readTextFile String
as_file IO [String] -> (IOError -> IO [String]) -> IO [String]
forall a. IO a -> (IOError -> IO a) -> IO a
`catchIOError` (IO [String] -> IOError -> IO [String]
forall a b. a -> b -> a
const ([String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []))
    let parse_results :: [Either ParseError ParsedLine]
parse_results = (String -> Either ParseError ParsedLine)
-> [String] -> [Either ParseError ParsedLine]
forall a b. (a -> b) -> [a] -> [b]
map (Parsec String () ParsedLine
-> String -> String -> Either ParseError ParsedLine
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () ParsedLine
sentence String
as_file) [String]
content_lines
    Int -> [Either ParseError ParsedLine] -> IO [Spelling]
clean Int
1 [Either ParseError ParsedLine]
parse_results
  where
    clean :: Int -> [Either ParseError ParsedLine] -> IO [Spelling]
    clean :: Int -> [Either ParseError ParsedLine] -> IO [Spelling]
clean Int
_ [] = [Spelling] -> IO [Spelling]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    -- print parse error
    clean Int
n (Left ParseError
err : [Either ParseError ParsedLine]
xs) = do
      let npos :: SourcePos
npos = SourcePos -> Int -> SourcePos
setSourceLine (ParseError -> SourcePos
errorPos ParseError
err) Int
n
      [DarcsFlag] -> Doc -> IO ()
putWarning [DarcsFlag]
flags (Doc -> IO ()) -> (ParseError -> Doc) -> ParseError -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
text (String -> Doc) -> (ParseError -> String) -> ParseError -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> String
forall a. Show a => a -> String
show (ParseError -> IO ()) -> ParseError -> IO ()
forall a b. (a -> b) -> a -> b
$ SourcePos -> ParseError -> ParseError
setErrorPos SourcePos
npos ParseError
err
      Int -> [Either ParseError ParsedLine] -> IO [Spelling]
clean (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Either ParseError ParsedLine]
xs
    -- skip blank line
    clean Int
n (Right ParsedLine
Nothing : [Either ParseError ParsedLine]
xs)  = Int -> [Either ParseError ParsedLine] -> IO [Spelling]
clean (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Either ParseError ParsedLine]
xs
    -- unwrap Spelling
    clean Int
n (Right (Just Spelling
a) : [Either ParseError ParsedLine]
xs) = do
      [Spelling]
as <- Int -> [Either ParseError ParsedLine] -> IO [Spelling]
clean (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Either ParseError ParsedLine]
xs
      [Spelling] -> IO [Spelling]
forall (m :: * -> *) a. Monad m => a -> m a
return (Spelling
a Spelling -> [Spelling] -> [Spelling]
forall a. a -> [a] -> [a]
: [Spelling]
as)

----------
-- PARSERS

sentence :: Parser ParsedLine
sentence :: Parsec String () ParsedLine
sentence = ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces ParsecT String () Identity ()
-> Parsec String () ParsedLine -> Parsec String () ParsedLine
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Parsec String () ParsedLine
forall u a. ParsecT String u Identity (Maybe a)
comment Parsec String () ParsedLine
-> Parsec String () ParsedLine -> Parsec String () ParsedLine
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parsec String () ParsedLine
forall u a. ParsecT String u Identity (Maybe a)
blank Parsec String () ParsedLine
-> Parsec String () ParsedLine -> Parsec String () ParsedLine
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Parsec String () ParsedLine
addressline)
  where
    comment :: ParsecT String u Identity (Maybe a)
comment = String -> ParsecT String u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"--" ParsecT String u Identity String
-> ParsecT String u Identity (Maybe a)
-> ParsecT String u Identity (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe a -> ParsecT String u Identity (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    blank :: ParsecT String u Identity (Maybe a)
blank = ParsecT String u Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof ParsecT String u Identity ()
-> ParsecT String u Identity (Maybe a)
-> ParsecT String u Identity (Maybe a)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe a -> ParsecT String u Identity (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

addressline :: Parser ParsedLine
addressline :: Parsec String () ParsedLine
addressline = do
    String
name <- Parser String
canonicalName Parser String -> String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"Canonical name"
    String
addr <- ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> Parser String
-> Parser String
forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'<') (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'>') (ParsecT String () Identity Char -> Parser String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (String -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
">")) Parser String -> String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"Address"
    ParsecT String () Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces
    [String]
rest <- [String]
-> ParsecT String () Identity [String]
-> ParsecT String () Identity [String]
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option [] (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',' ParsecT String () Identity Char
-> ParsecT String () Identity [String]
-> ParsecT String () Identity [String]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser String
regexp Parser String
-> ParsecT String () Identity Char
-> ParsecT String () Identity [String]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`sepBy` Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',')
            ParsecT String () Identity [String]
-> String -> ParsecT String () Identity [String]
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"List of regexps"
    ParsedLine -> Parsec String () ParsedLine
forall (m :: * -> *) a. Monad m => a -> m a
return (ParsedLine -> Parsec String () ParsedLine)
-> ParsedLine -> Parsec String () ParsedLine
forall a b. (a -> b) -> a -> b
$ Spelling -> ParsedLine
forall a. a -> Maybe a
Just (Spelling -> ParsedLine) -> Spelling -> ParsedLine
forall a b. (a -> b) -> a -> b
$ String -> String -> [Regex] -> Spelling
Spelling (String -> String
strip String
name) String
addr ([String] -> [Regex]
compile [String]
rest)
  where
    strip :: String -> String
strip = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
reverse
    makeRegex :: String -> Regex
makeRegex String
s = String -> Bool -> Bool -> Regex
mkRegexWithOpts String
s Bool
True Bool
False
    compile :: [String] -> [Regex]
compile = (String -> Regex) -> [String] -> [Regex]
forall a b. (a -> b) -> [a] -> [b]
map String -> Regex
makeRegex ([String] -> [Regex])
-> ([String] -> [String]) -> [String] -> [Regex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
strip

    parseComma :: ParsecT String u Identity Char
parseComma = String -> ParsecT String u Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"\\," ParsecT String u Identity String
-> ParsecT String u Identity Char -> ParsecT String u Identity Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ParsecT String u Identity Char
forall (m :: * -> *) a. Monad m => a -> m a
return Char
','

    regexp :: Parser String
    regexp :: Parser String
regexp = ParsecT String () Identity Char -> Parser String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall u. ParsecT String u Identity Char
p Parser String -> String -> Parser String
forall s u (m :: * -> *) a.
ParsecT s u m a -> String -> ParsecT s u m a
<?> String
"Regular expression"
      where
        p :: ParsecT String u Identity Char
p = ParsecT String u Identity Char -> ParsecT String u Identity Char
forall tok st a. GenParser tok st a -> GenParser tok st a
try ParsecT String u Identity Char
forall u. ParsecT String u Identity Char
parseComma ParsecT String u Identity Char
-> ParsecT String u Identity Char -> ParsecT String u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
","

    canonicalName :: Parser String
    canonicalName :: Parser String
canonicalName = ParsecT String () Identity Char -> Parser String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String () Identity Char
forall u. ParsecT String u Identity Char
p
      where
        p :: ParsecT String u Identity Char
p = ParsecT String u Identity Char -> ParsecT String u Identity Char
forall tok st a. GenParser tok st a -> GenParser tok st a
try ParsecT String u Identity Char
forall u. ParsecT String u Identity Char
parseComma ParsecT String u Identity Char
-> ParsecT String u Identity Char -> ParsecT String u Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> ParsecT String u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m Char
noneOf String
",<"