#!@GUILE@ \
--no-auto-compile -s
!#

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2022 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2022 Mathieu Othacehe <othacehe@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix 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 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix 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 GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

;;; Commentary:

;; This code defines development teams and team members, as well as their
;; scope.

;;; Code:

(use-modules (srfi srfi-1)
             (srfi srfi-9)
             (srfi srfi-26)
             (ice-9 format)
             (ice-9 regex)
             (ice-9 match)
             (guix ui)
             (git))

(define-record-type <team>
  (make-team id name description members scope)
  team?
  (id          team-id)
  (name        team-name)
  (description team-description)
  (members     team-members set-team-members!)
  (scope       team-scope))

(define-record-type <person>
  (make-person name email)
  person?
  (name    person-name)
  (email   person-email))

(define* (person name #:optional email)
  (make-person name email))

(define* (team id #:key name description (members '())
               (scope '()))
  (make-team id
             (or name (symbol->string id))
             description
             members
             scope))

(define %teams
  (make-hash-table))

(define-syntax define-team
  (lambda (x)
    (syntax-case x ()
      ((_ id value)
       #`(begin
           (define-public id value)
           (hash-set! %teams 'id id))))))

(define-syntax-rule (define-member person teams ...)
  (let ((p person))
    (for-each (lambda (team-id)
                (let ((team
                       (hash-ref %teams team-id
                                 (lambda ()
                                   (error (format #false
                                                  "Unknown team ~a for ~a~%"
                                                  team-id p))))))
                  (set-team-members!
                   team (cons p (team-members team)))))
              (quote (teams ...)))))


(define-team python
  (team 'python
        #:name "Python team"
        #:description
        "Python, Python packages, the \"pypi\" importer, and the python-build-system."
        #:scope
        (list "gnu/packages/django.scm"
              "gnu/packages/jupyter.scm"
              ;; Match haskell.scm and haskell-*.scm.
              (make-regexp "^gnu/packages/python(-.+|)\\.scm$")
              "gnu/packages/sphinx.scm"
              "gnu/packages/tryton.scm"
              "guix/build/python-build-system.scm"
              "guix/build-system/python.scm"
              "guix/import/pypi.scm"
              "guix/scripts/import/pypi.scm"
              "tests/pypi.scm")))

(define-team haskell
  (team 'haskell
        #:name "Haskell team"
        #:description
        "GHC, Hugs, Haskell packages, the \"hackage\" and \"stackage\" importers, and
the haskell-build-system."
        #:scope
        (list "gnu/packages/dhall.scm"
              ;; Match haskell.scm and haskell-*.scm.
              (make-regexp "^gnu/packages/haskell(-.+|)\\.scm$")
              "gnu/packages/purescript.scm"
              "guix/build/haskell-build-system.scm"
              "guix/build-system/haskell.scm"
              "guix/import/cabal.scm"
              "guix/import/hackage.scm"
              "guix/import/stackage.scm"
              "guix/scripts/import/hackage.scm")))

(define-team r
  (team 'r
        #:name "R team"
        #:description
        "The R language, CRAN and Bioconductor repositories, the \"cran\" importer,
and the r-build-system."))

(define-team julia
  (team 'julia
        #:name "Julia team"
        #:description
        "The Julia language, Julia packages, and the julia-build-system."))

(define-team ocaml
  (team 'ocaml
        #:name "OCaml and Dune team"
        #:description
        "The OCaml language, the Dune build system, OCaml packages, the \"opam\"
importer, and the ocaml-build-system."
        #:scope
        (list "gnu/packages/ocaml.scm"
              "gnu/packages/coq.scm"
              "guix/build/ocaml-build-system.scm"
              "guix/build/dune-build-system.scm"
              "guix/build-system/ocaml.scm"
              "guix/build-system/dune.scm"
              "guix/import/opam.scm"
              "guix/scripts/import/opam.scm"
              "tests/opam.scm")))

(define-team java
  (team 'java
        #:name "Java and Maven team"
        #:description
        "The JDK and JRE, the Maven build system, Java packages, the ant-build-system,
and the maven-build-system."
        #:scope
        (list ;; Match java.scm and java-*.scm.
              (make-regexp "^gnu/packages/java(-.+|)\\.scm$")
              ;; Match maven.scm and maven-*.scm
              (make-regexp "^gnu/packages/maven(-.+|)\\.scm$")
              "guix/build/ant-build-system.scm"
              "guix/build/java-utils.scm"
              "guix/build/maven-build-system.scm"
              ;; The maven directory
              (make-regexp "^guix/build/maven/")
              "guix/build-system/ant.scm"
              "guix/build-system/maven.scm")))

(define-team science
  (team 'science
        #:name "Science team"))

(define-team emacs
  (team 'emacs
        #:name "Emacs team"
        #:description "The extensible, customizable text editor and its
ecosystem."
        #:scope (list (make-regexp "^gnu/packages/emacs(-.+|)\\.scm$")
                      "guix/build/emacs-build-system.scm"
                      "guix/build/emacs-utils.scm"
                      "guix/build-system/emacs.scm")))

(define-team lisp
  (team 'lisp
        #:name "Lisp team"
        #:description
        "Common Lisp and similar languages, Common Lisp packages and the
asdf-build-system."
        #:scope (list (make-regexp "^gnu/packages/lisp(-.+|)\\.scm$")
                      "guix/build/asdf-build-system.scm"
                      "guix/build/lisp-utils.scm"
                      "guix/build-system/asdf.scm")))

(define-team ruby
  (team 'ruby
        #:name "Ruby team"))

(define-team go
  (team 'go
        #:name "Go team"))

(define-team embedded-bootstrap
  (team 'embedded-bootstrap
        #:name "Embedded / Bootstrap"))

(define-team rust
  (team 'rust
        #:name "Rust"))

(define-team kernel
  (team 'kernel
        #:name "Linux-libre kernel team"))

(define-team core
  (team 'core
        #:name "Core / Tools / Internals"
        #:scope
        (list "guix/avahi.scm"
              "guix/base16.scm"
              "guix/base32.scm"
              "guix/base64.scm"
              "guix/bzr-download.scm"
              "guix/cache.scm"
              "guix/channels.scm"
              "guix/ci.scm"
              "guix/colors.scm"
              "guix/combinators.scm"
              "guix/config.scm"
              "guix/cpio.scm"
              "guix/cpu.scm"
              "guix/cve.scm"
              "guix/cvs-download.scm"
              "guix/deprecation.scm"
              "guix/derivations.scm"
              "guix/describe.scm"
              "guix/diagnostics.scm"
              "guix/discovery.scm"
              "guix/docker.scm"
              "guix/download.scm"
              "guix/elf.scm"
              "guix/ftp-client.scm"
              "guix/gexp.scm"
              "guix/git-authenticate.scm"
              "guix/git-download.scm"
              "guix/git.scm"
              "guix/glob.scm"
              "guix/gnu-maintenance.scm"
              "guix/gnupg.scm"
              "guix/grafts.scm"
              "guix/graph.scm"
              "guix/hash.scm"
              "guix/hg-download.scm"
              "guix/http-client.scm"
              "guix/i18n.scm"
              "guix/inferior.scm"
              "guix/ipfs.scm"
              "guix/least-authority.scm"
              "guix/licenses.scm"
              "guix/lint.scm"
              "guix/man-db.scm"
              "guix/memoization.scm"
              "guix/modules.scm"
              "guix/monad-repl.scm"
              "guix/monads.scm"
              "guix/narinfo.scm"
              "guix/nar.scm"
              "guix/openpgp.scm"
              "guix/packages.scm"
              "guix/pki.scm"
              "guix/platform.scm"
              "guix/profiles.scm"
              "guix/profiling.scm"
              "guix/progress.scm"
              "guix/quirks.scm"
              "guix/read-print.scm"
              "guix/records.scm"
              "guix/remote.scm"
              "guix/repl.scm"
              "guix/search-paths.scm"
              "guix/self.scm"
              "guix/serialization.scm"
              "guix/sets.scm"
              "guix/ssh.scm"
              "guix/status.scm"
              "guix/store.scm"
              "guix/substitutes.scm"
              "guix/svn-download.scm"
              "guix/swh.scm"
              "guix/tests.scm"
              "guix/transformations.scm"
              "guix/ui.scm"
              "guix/upstream.scm"
              "guix/utils.scm"
              "guix/workers.scm"
              (make-regexp "^guix/platforms/")
              (make-regexp "^guix/scripts/")
              (make-regexp "^guix/store/"))))

(define-team games
  (team 'games
        #:name "Games and Toys"
        #:description "Packaging programs for amusement."
        #:scope (list "gnu/packages/games.scm"
                      "gnu/packages/game-development.scm"
                      "gnu/packages/minetest.scm"
                      "gnu/packages/esolangs.scm" ; granted, rather niche
                      "gnu/packages/motti.scm"
                      "guix/build/minetest-build-system.scm")))

(define-team translations
  (team 'translations
        #:name "Translations"))

(define-team installer
  (team 'installer
        #:name "Installer script and system installer"
        #:scope
        (list (make-regexp "^guix/installer(\\.scm$|/)"))))

(define-team home
  (team 'home
        #:name "Team for \"Guix Home\""))

(define-team mentors
  (team 'mentors
        #:name "Mentors"
        #:description
        "A group of mentors who chaperone contributions by newcomers."))

(define-team mozilla
  (team 'mozilla
        #:name "Mozilla"
        #:description
        "Taking care about Icecat and Icedove, built from Mozilla Firefox
and Thunderbird."))

(define-team racket
  (team 'racket
        #:name "Racket team"
        #:description
        "The Racket language and Racket-based languages, Racket packages,
Racket's variant of Chez Scheme, and development of a Racket build system and
importer."))


(define-member (person "Thiago Jung Bauermann"
                       "bauermann@kolabnow.com")
  embedded-bootstrap translations)

(define-member (person "Eric Bavier"
                       "bavier@posteo.net")
  science)

(define-member (person "Lars-Dominik Braun"
                       "lars@6xq.net")
  python haskell)

(define-member (person "Jonathan Brielmaier"
                       "jonathan.brielmaier@web.de")
  mozilla)

(define-member (person "Ludovic Courtès"
                       "ludo@gnu.org")
  core home embedded-bootstrap mentors)

(define-member (person "Andreas Enge"
                       "andreas@enge.fr")
  science)

(define-member (person "Björn Höfling"
                       "bjoern.hoefling@bjoernhoefling.de")
  java)

(define-member (person "Leo Famulari"
                       "leo@famulari.name")
  kernel)

(define-member (person "Efraim Flashner"
                       "efraim@flashner.co.il")
  embedded-bootstrap julia rust science)

(define-member (person "jgart"
                       "jgart@dismail.de")
  python lisp mentors)

(define-member (person "Guillaume Le Vaillant"
                       "glv@posteo.net")
  lisp)

(define-member (person "Julien Lepiller"
                       "julien@lepiller.eu")
  java ocaml translations)

(define-member (person "Philip McGrath"
                       "philip@philipmcgrath.com")
  racket)

(define-member (person "Mathieu Othacehe"
                       "othacehe@gnu.org")
  core installer mentors)

(define-member (person "Florian Pelz"
                       "pelzflorian@pelzflorian.de")
  translations)

(define-member (person "Liliana Marie Prikler"
                       "liliana.prikler@gmail.com")
  emacs games)

(define-member (person "Ricardo Wurmus"
                       "rekado@elephly.net")
  r core mentors)

(define-member (person "Christopher Baines"
                       "mail@cbaines.net")
  core mentors ruby)

(define-member (person "Andrew Tropin"
                       "andrew@trop.in")
  home emacs)

(define-member (person "Josselin Poiret"
                       "dev@jpoiret.xyz")
  core installer)


(define (find-team name)
  (or (hash-ref %teams (string->symbol name))
      (error (format #false
                           "no such team: ~a~%" name))))

(define (find-team-by-scope files)
  "Return the team(s) which scope matches at least one of the FILES, as list
of file names as string."
  (hash-fold
   (lambda (key team acc)
     (if (any (lambda (file)
                (any (match-lambda
                       ((? string? scope)
                        (string=? scope file))
                       ((? regexp? scope)
                        (regexp-exec scope file)))
                     (team-scope team)))
              files)
         (cons team acc)
         acc))
   '()
   %teams))

(define (cc . teams)
  "Return arguments for `git send-email' to notify the members of the given
TEAMS when a patch is received by Debbugs."
  (format #true
          "~{--add-header=\"X-Debbugs-Cc: ~a\"~^ ~}"
          (map person-email
               (delete-duplicates (append-map team-members teams) equal?))))

(define* (list-members team #:optional port (prefix ""))
  "Print the members of the given TEAM."
  (define port* (or port (current-output-port)))
  (for-each
   (lambda (member)
     (format port*
             "~a~a <~a>~%"
             prefix
             (person-name member)
             (person-email member)))
   (team-members team)))

(define (list-teams)
  "Print all teams, their scope and their members."
  (define port* (current-output-port))
  (define width* (%text-width))
  (hash-for-each
   (lambda (key team)
     (format port*
             "\
id: ~a
name: ~a
description: ~a
~amembers:
"
             (team-id team)
             (team-name team)
             (or (and=> (team-description team)
                        (lambda (text)
                          (string->recutils
                           (fill-paragraph text width*
                                           (string-length "description: ")))))
                 "<none>")
             (match (team-scope team)
               (() "")
               (scope (format #f "scope: ~{~s ~}~%" scope))))
     (list-members team port* "+ ")
     (newline))
   %teams))


(define (diff-revisions rev-start rev-end)
  "Return the list of added, modified or removed files between REV-START
and REV-END, two git revision strings."
  (let* ((repository (repository-open (getcwd)))
         (commit1 (commit-lookup repository
                                 (object-id
                                  (revparse-single repository rev-start))))
         (commit2 (commit-lookup repository
                                 (object-id
                                  (revparse-single repository rev-end))))
         (diff (diff-tree-to-tree repository
                                  (commit-tree commit1)
                                  (commit-tree commit2)))
         (files '()))
    (diff-foreach
     diff
     (lambda (delta progress)
       (set! files
             (cons (diff-file-path (diff-delta-old-file delta)) files))
       0)
     (const 0)
     (const 0)
     (const 0))
    files))


(define (main . args)
  (match args
    (("cc" . team-names)
     (apply cc (map find-team team-names)))
    (("cc-members" rev-start rev-end)
     (apply cc (find-team-by-scope
                (diff-revisions rev-start rev-end))))
    (("list-teams" . args)
     (list-teams))
    (("list-members" . team-names)
     (for-each
      (lambda (team-name)
        (list-members (find-team team-name)))
      team-names))
    (anything
     (format (current-error-port)
             "Usage: etc/teams.scm <command> [<args>]~%"))))

(apply main (cdr (command-line)))