#!/gnu/store/5rbr7gi8q7gpmb4gmqrpnpk55a4gjpkz-profile/bin/guile \
--no-auto-compile -s
!#

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2022 Julien Lepiller <julien@lepiller.eu>
;;;
;;; 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 is a helper for news file translation using Gettext.

;;; Code:

(use-modules (srfi srfi-1)
             (srfi srfi-9)
             (srfi srfi-19)
             (ice-9 match)
             (ice-9 pretty-print)
             (ice-9 rdelim)
             (ice-9 regex)
             (guix build po)
             (guix channels))

(define read-channel-news (@@ (guix channels) read-channel-news))
(define channel-news-entries (@@ (guix channels) channel-news-entries))
(define <channel-news-entry> (@@ (guix channels) <channel-news-entry>))
(define channel-news-entry (@@ (guix channels) channel-news-entry))

(define (print-msg msg)
  (if msg
    (let* ((msg (string-join (string-split msg #\\) "\\\\"))
           (msg (string-join (string-split msg #\") "\\\""))
           (msg (string-join (string-split msg #\newline)
                             "\\n\"\n\"")))
      (if (string-contains msg "\n") (string-append "\"\n\"" msg) msg))
    ""))

(define* (generate-po news-file pot-file #:optional lang)
  "Generate a pot file from a news file."
  (let ((news (call-with-input-file news-file read-channel-news)))
    (call-with-output-file pot-file
      (lambda (port)
        (format port "# SOME DESCRIPTIVE TITLE~%")
        (format port "# Copyright (C) YEAR the authors of Guix (msgids) and the following authors (msgstr)~%")
        (format port "# This file is distributed under the same license as the guix news file.~%")
        (format port "# ~%")
        (format port "msgid \"\"~%")
        (format port "msgstr \"\"
\"Project-Id-Version: guix news checkout\\n\"
\"Report-Msgid-Bugs-To: bug-guix@gnu.org\\n\"
\"POT-Creation-Date: ~a\\n\"
\"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\\n\"
\"Last-Translator: FULL NAME <EMAIL@ADDRESS>\\n\"
\"Language-Team: LANGUAGE <LL@li.org>\\n\"
\"Language: \\n\"
\"MIME-Version: 1.0\\n\"
\"Content-Type: text/plain; charset=UTF-8\\n\"
\"Content-Transfer-Encoding: 8bit\\n\"~%~%" (date->string (current-date)))
        (for-each
          (match-lambda
            (($ <channel-news-entry> commit tag title body)
             (let ((msgid1 (assoc-ref title "en"))
                   (msgid2 (assoc-ref body "en"))
                   (msgstr1 (assoc-ref title lang))
                   (msgstr2 (assoc-ref body lang)))
               (when commit
                 (format port "#. commit: ~a~%" commit))
               (when tag
                 (format port "#. tag: ~a~%" tag))
               (format port "msgid \"~a\"~%" (print-msg msgid1))
               (format port "msgstr \"~a\"~%~%" (print-msg msgstr1))
               (when commit
                 (format port "#. commit: ~a~%" commit))
               (when tag
                 (format port "#. tag: ~a~%" tag))
               (format port "msgid \"~a\"~%" (print-msg msgid2))
               (format port "msgstr \"~a\"~%~%" (print-msg msgstr2)))))
          (channel-news-entries news))))))

(define (languages lingua)
  (with-input-from-file lingua
    (lambda _
      (let loop ((line (read-line)))
        (if (eof-object? line)
            '()
            ;; else read linguas before comment
            (let ((before-comment (car (string-split line #\#))))
              (append
               (map match:substring (list-matches "[^ \t]+" before-comment))
               (loop (read-line)))))))))

(define (clean-string entry)
  (string-join (string-split entry #\newline) "\n"))

(define (complete-msg entries pos)
  "Complete an entry's message list using po files that were parsed in pos."

  (let ((entry (assoc-ref entries "en")))
    (let loop ((pos pos) (entries entries))
      (match pos
        (() entries)
        (((lang . po) pos ...)
         (if (assoc-ref po entry)
           (loop pos (cons (cons lang (assoc-ref po entry)) entries))
           (loop pos entries)))))))

(define (merge-entries news pos languages)
  (let ((entries (channel-news-entries news)))
    (map
      (lambda (entry)
        (let* ((title (list (cons "en"
                                  (clean-string
                                    (assoc-ref (channel-news-entry-title entry)
                                               "en")))))
               (title (complete-msg title pos))
               (body (list (cons "en"
                                 (clean-string
                                   (assoc-ref (channel-news-entry-body entry)
                                              "en")))))
               (body (complete-msg body pos)))
          (channel-news-entry (channel-news-entry-commit entry)
                              (channel-news-entry-tag entry)
                              title body)))
      entries)))

(define-record-type <copyright>
  (make-copyright name years)
  copyright?
  (name copyright-name)
  (years copyright-years))

(define (parse-years years)
  (let ((years (map string-trim (string-split years #\,))))
    (let loop ((years years) (res '()))
      (match years
        (() (sort res <))
        ((year years ...)
         (match (string-split year #\-)
           ((year) (loop years (cons (string->number year) res)))
           ((start end)
            (let ((start (string->number start))
                  (end   (string->number end)))
              (loop years (append (iota (- end start -1) start) res))))))))))

(define (parse-scm-copyrights file)
  (with-input-from-file file
    (lambda _
      (let loop ((line (read-line)))
        (if (eof-object? line)
          '()
          (let ((matches (string-match "^;; Copyright © ([0-9, -]*) (.*)$" line)))
            (if matches
              (cons
                (make-copyright (match:substring matches 2)
                                (parse-years (match:substring matches 1)))
                (loop (read-line)))
              (loop (read-line)))))))))

(define (parse-po-copyrights file)
  (with-input-from-file file
    (lambda _
      (let loop ((line (read-line)))
        (if (eof-object? line)
          '()
          (let ((matches (string-match "^# (.* <.*@.*>), ([0-9, -]*)\\.$" line)))
            (if matches
              (cons
                (make-copyright (match:substring matches 1)
                                (parse-years (match:substring matches 2)))
                (loop (read-line)))
              (loop (read-line)))))))))

(define (merge-copyrights copyrights)
  (define (uniq lst)
    (match lst
      (() '())
      ((e lst ...)
       (let ((rest (uniq lst)))
         (if (member e rest)
           rest
           (cons e rest))))))

  (define (merge-copyright-of name copyrights)
    (make-copyright name (uniq (sort (apply append (map copyright-years copyrights)) <))))

  (fold
    (lambda (copyright res)
      (if (find (lambda (r) (equal? (copyright-name r) (copyright-name copyright))) res)
          (sort res (lambda (c1 c2) (string<=? (copyright-name c1) (copyright-name c2))))
          (cons
            (merge-copyright-of
              (copyright-name copyright)
              (filter
                (lambda (c)
                  (equal? (copyright-name c) (copyright-name copyright)))
                copyrights))
            res)))
    '()
    copyrights))


(define (parse-copyrights news-file po-dir languages)
  (let ((scm-copyrights (parse-scm-copyrights news-file))
        (po-copyrights
          (apply append
                 (map
                   (lambda (lang)
                     (parse-po-copyrights (string-append po-dir "/" lang ".po")))
                   languages))))
    (merge-copyrights (append scm-copyrights po-copyrights))))

(define (print-copyrights copyrights)
  (define (format-years years)
    (let loop ((years years) (first-consecutive #f) (last-consecutive #f) (res '()))
      (match years
        ((year years ...)
         (cond
           ((and first-consecutive
                 (equal? (+ last-consecutive 1) year))
            (loop years first-consecutive year res))
           ((and first-consecutive 
                 (equal? first-consecutive last-consecutive))
            (loop years year year (cons (number->string first-consecutive) res)))
           ((and first-consecutive 
                 (equal? (+ first-consecutive 1) last-consecutive))
            (loop years year year (cons* (number->string last-consecutive) (number->string first-consecutive) res)))
           (first-consecutive
            (loop years year year (cons (string-append number->string first-consecutive) "-" (number->string last-consecutive))))
           (else
            (loop years year year res))))
        (()
         (cond
           ((and first-consecutive
                 (equal? first-consecutive last-consecutive))
            (cons (number->string first-consecutive) res))
           ((and first-consecutive
                 (equal? (+ first-consecutive 1) last-consecutive))
            (cons* (number->string last-consecutive)
                   (number->string first-consecutive)
                   res))
           (first-consecutive
            (cons (string-append (number->string first-consecutive)
                                 "-"
                                 (number->string last-consecutive))
                  res)))))))

  (for-each
    (match-lambda
      (($ <copyright> name years)
       (format #t ";; Copyright © ~a ~a~%" (string-join (reverse (format-years years)) ", ") name)))
    copyrights))

(define (print-entry entry)
  (define (print-content content)
    (for-each
      (match-lambda
        ((lang . content)
         (let* ((content (string-join (string-split content #\\) "\\\\"))
                (content (string-join (string-split content #\") "\\\"")))
           (format #t "~%         (~a \"~a\")" lang content))))
      content))

  (define (content<=? c1 c2)
    (or (equal? (car c1) "en")
        (and
          (not (equal? (car c2) "en"))
          (string<=? (car c1) (car c2)))))

  (format #t "~%~% (entry ")
  (when (channel-news-entry-commit entry)
    (format #t "(commit \"~a\")~%" (channel-news-entry-commit entry)))
  (when (channel-news-entry-tag entry)
    (format #t "        (tag \"~a\")~%" (channel-news-entry-tag entry)))
  (format #t "        (title")
  (print-content (sort (channel-news-entry-title entry) content<=?))
  (display ")")
  (newline)
  (format #t "        (body")
  (print-content (sort (channel-news-entry-body entry) content<=?))
  (display "))"))

(define (merge-news news-file po-dir)
  (let* ((lingua (string-append po-dir "/LINGUAS"))
         (languages (languages lingua))
         (pos (map
                (lambda (lang)
                  (cons
                    lang
                    (call-with-input-file
                      (string-append po-dir "/" lang ".po")
                      read-po-file)))
                languages))
         (news (call-with-input-file news-file read-channel-news))
         (entries (merge-entries news pos languages))
         (copyrights (parse-copyrights news-file po-dir languages)))
    (with-output-to-file (string-append news-file ".tmp")
      (lambda _
        (display ";; GNU Guix news, for use by 'guix pull'.
;;
")
        (print-copyrights copyrights)
        (display ";;
;; Copying and distribution of this file, with or without modification, are
;; permitted in any medium without royalty provided the copyright notice and
;; this notice are preserved.

(channel-news
 (version 0)")
        (for-each print-entry entries)
        (display ")")
        (newline)))))

(define (main . args)
  (match args
    (("pot" news-file pot-file)
     (generate-po news-file pot-file))
    (("po" news-file lang po-file)
     (generate-po news-file po-file lang))
    (("merge" news-file po-dir)
     (merge-news news-file po-dir))
    (_
     (format (current-error-port)
             "Usage: etc/teams.scm <command> [<args>]~%"))))

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