--  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, sort )
import Data.List.NonEmpty ( group, groupBy )
import qualified Data.List.NonEmpty as NE
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 Darcs.Prelude

import Darcs.UI.Flags ( DarcsFlag, useCache, verbose )
import Darcs.UI.Options ( oid, (?) )
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 ( readPatches, withRepository, RepoJob(..) )
import Darcs.Patch.Witnesses.Ordered ( mapRL )
import Darcs.Util.Lock ( readTextFile )
import Darcs.Util.Printer ( Doc, text )
import Darcs.Util.Path ( AbsolutePath )
import Darcs.Util.Regex ( Regex, mkRegexWithOpts, matchRegex )

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
    { 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
    , commandOptions :: CommandOptions
commandOptions = CommandOptions
showAuthorsOpts
    }
  where
    showAuthorsBasicOpts :: PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe String)
showAuthorsBasicOpts = PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe String)
PrimDarcsOption (Maybe String)
O.repoDir
    showAuthorsOpts :: CommandOptions
showAuthorsOpts = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe String)
PrimDarcsOption (Maybe String)
showAuthorsBasicOpts PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Maybe String)
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
-> CommandOptions
forall b c.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     b
-> CommandOptions
`withStdOpts` DarcsOption
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
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 'RO () -> IO ()
forall a. UseCache -> RepoJob 'RO a -> IO a
withRepository (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
flags) (RepoJob 'RO () -> IO ()) -> RepoJob 'RO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TreePatchJob 'RO () -> RepoJob 'RO ()
forall (rt :: AccessType) a. TreePatchJob rt a -> RepoJob rt a
RepoJob (TreePatchJob 'RO () -> RepoJob 'RO ())
-> TreePatchJob 'RO () -> RepoJob 'RO ()
forall a b. (a -> b) -> a -> b
$ \Repository 'RO p wU wR
repository -> do
    PatchSet p Origin wR
patches <- Repository 'RO p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatches Repository 'RO p wU wR
repository
    [Spelling]
spellings <- [DarcsFlag] -> IO [Spelling]
compiledAuthorSpellings [DarcsFlag]
flags
    let authors :: [String]
authors = (forall wW wZ. PatchInfoAnd p wW wZ -> String)
-> RL (PatchInfoAnd 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)
-> (PatchInfoAnd p wW wZ -> PatchInfo)
-> PatchInfoAnd p wW wZ
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAnd p wW wZ -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info) (RL (PatchInfoAnd p) Origin wR -> [String])
-> RL (PatchInfoAnd p) Origin wR -> [String]
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin wR -> RL (PatchInfoAnd p) Origin wR
forall (p :: * -> * -> *) wStart wX.
PatchSet p wStart wX -> RL (PatchInfoAnd p) wStart wX
patchSet2RL PatchSet 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).
              (NonEmpty (Int, String) -> (Int, String))
-> [NonEmpty (Int, String)] -> [(Int, String)]
forall a b. (a -> b) -> [a] -> [b]
map ((NonEmpty Int -> Int
forall a. Num a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (NonEmpty Int -> Int)
-> (NonEmpty String -> String)
-> (NonEmpty Int, NonEmpty String)
-> (Int, String)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** NonEmpty String -> String
forall a. NonEmpty a -> a
NE.head) ((NonEmpty Int, NonEmpty String) -> (Int, String))
-> (NonEmpty (Int, String) -> (NonEmpty Int, NonEmpty String))
-> NonEmpty (Int, String)
-> (Int, String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Int, String) -> (NonEmpty Int, NonEmpty String)
forall (f :: * -> *) a b. Functor f => f (a, b) -> (f a, f b)
NE.unzip) ([NonEmpty (Int, String)] -> [(Int, String)])
-> ([String] -> [NonEmpty (Int, String)])
-> [String]
-> [(Int, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              ((Int, String) -> (Int, String) -> Bool)
-> [(Int, String)] -> [NonEmpty (Int, String)]
forall (f :: * -> *) a.
Foldable f =>
(a -> a -> Bool) -> f a -> [NonEmpty 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)] -> [NonEmpty (Int, String)])
-> ([String] -> [(Int, String)])
-> [String]
-> [NonEmpty (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)].
              (NonEmpty String -> (Int, String))
-> [NonEmpty String] -> [(Int, String)]
forall a b. (a -> b) -> [a] -> [b]
map (NonEmpty String -> Int
forall a. NonEmpty a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (NonEmpty String -> Int)
-> (NonEmpty String -> String) -> NonEmpty String -> (Int, String)
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
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)
-> (NonEmpty String -> String) -> NonEmpty String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty String -> String
forall a. NonEmpty a -> a
NE.head)) ([NonEmpty String] -> [(Int, String)])
-> ([String] -> [NonEmpty String]) -> [String] -> [(Int, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
              [String] -> [NonEmpty String]
forall (f :: * -> *) a. (Foldable f, Eq a) => f a -> [NonEmpty 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 a. a -> IO a
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 a. a -> IO a
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 a. a -> IO a
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 a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
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 a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe a -> ParsecT String u Identity (Maybe a)
forall a. a -> ParsecT String u Identity 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 a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe a -> ParsecT String u Identity (Maybe a)
forall a. a -> ParsecT String u Identity 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 a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
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 a. a -> ParsecT String () Identity a
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 a. [a] -> 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 a b.
ParsecT String u Identity a
-> ParsecT String u Identity b -> ParsecT String u Identity b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ParsecT String u Identity Char
forall a. a -> ParsecT String u Identity a
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
",<"