;; disfluid, implementation of the Solid specification
;; Copyright (C) 2022  Vivien Kraus

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU Affero General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, 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 Affero General Public License for more details.

;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

(define-module (disfluid maintainer new-phases)
  #:use-module (guix gexp)
  #:use-module (gnu packages base)
  #:use-module (gnu packages guile-xyz)
  #:declarative? #t
  #:export (new-phases))

;; new-phases should be the content of the #:phase argument of the
;; disfluid package. It adds phases to set up the build system,
;; generate the complete source code distribution and more.

(define kwote (string->symbol "quote"))

(define (new-phases scan)
  (let ((version (assq-ref scan 'version)))
    `(modify-phases %standard-phases
       (add-after 'unpack 'fix-mtime
         (lambda _
           (let ((disfluid-mtimes (,kwote ,(assq-ref scan 'mtimes))))
             (for-each
              ((@ (ice-9 match) match-lambda)
                ((file . mtime)
                 (utime file mtime mtime)))
              disfluid-mtimes))))
       (add-before 'bootstrap 'fix-hall.scm
         (lambda _
           (let ((disfluid-version ,version))
             (substitute* "hall.scm"
               (("SNAPSHOT") disfluid-version)))))
       (add-after 'fix-hall.scm 'hall-scan
         (lambda _
           (setenv "HOME" (getcwd))
           ;; hall scan needs to know there will be a module (disfluid
           ;; config), but disfluid/config.scm has not been generated
           ;; yet.
           (call-with-output-file "disfluid/config.scm"
             (lambda (port)
               (write
                `(define-module (disfluid config))
                port)))
           (invoke "hall" "scan" "-x")
           (delete-file "disfluid/config.scm")))
       (add-after 'hall-scan 'hall-build-system
         (lambda _
           (invoke "hall" "build-system" "-x")
           (substitute* "Makefile.am"
             (("EXTRA_DIST =")
              "EXTRA_DIST = guix.scm channels.scm"))))
       (add-after 'hall-build-system 'support-config.scm
         (lambda _
           (let ((expanded-variables
                  '(("prefix" . "PREFIX")
                    ("bindir" . "BINDIR")
                    ("exec_prefix" . "EXEC_PREFIX")
                    ("guilemoduledir" . "GUILEMODULEDIR")
                    ("guileobjectdir" . "GUILEOBJECTDIR")
                    ("localedir" . "LOCALEDIR"))))
             (let ((subst
                    (string-join
                     (map
                      ((@ (ice-9 match) match-lambda)
                        ((var . expanded)
                         (format #f "\
AX_RECURSIVE_EVAL([$~a], EXPANDED_~a)
AC_SUBST([EXPANDED_~a])"
                                 var expanded expanded)))
                      expanded-variables)
                     "\n")))
               (substitute* "configure.ac"
                 (("AC_OUTPUT")
                  (string-append subst "
AC_CONFIG_FILES([disfluid/config.scm])
AC_OUTPUT")))))
           (rename-file "Makefile.am" "hall.mk")
           (call-with-output-file "Makefile.am"
             (lambda (port)
               (format port "\
include %reldir%/hall.mk

dist-hook:
\trm -rf $(distdir)/disfluid/config.scm
")))
           (call-with-output-file "disfluid/config.scm.in"
             (lambda (port)
               (for-each
                (lambda (code)
                  ((@ (ice-9 pretty-print) pretty-print) code port)
                  (newline port))
                '((define-module (disfluid config)
                    #:export
                    (
                     package
                      package-bugreport
                      version
                      localedir
                      guilemoduledir
                      prefix
                      exec-prefix
                      pkg-config
                      ))
                  (define package "@PACKAGE@")
                  (define package-bugreport "@PACKAGE_BUGREPORT@")
                  (define version "@VERSION@")
                  (define prefix "@EXPANDED_PREFIX@")
                  (define exec-prefix "@EXPANDED_EXEC_PREFIX@")
                  (define localedir "@EXPANDED_LOCALEDIR@")
                  (define guilemoduledir "@EXPANDED_GUILEMODULEDIR@")
                  (define pkg-config "@PKG_CONFIG@")))))))
       (add-after 'support-config.scm 'gettextize
         (lambda _
           (substitute* "configure.ac"
             (("AC_OUTPUT")
              "
AM_GNU_GETTEXT([external])
AM_GNU_GETTEXT_VERSION([0.21])
AC_OUTPUT
")
             (("AC_CONFIG_FILES\\(\\[Makefile")
              "AC_CONFIG_FILES([Makefile po/Makefile.in"))
           (substitute* "hall.mk"
             (("EXTRA_DIST =")
              "EXTRA_DIST = guix.scm channels.scm"))
           (rename-file "Makefile.am" "withconfig.mk")
           (call-with-output-file "Makefile.am"
             (lambda (port)
               (format port "SUBDIRS = po
include withconfig.mk
")))
           (mkdir-p "po")
           (call-with-output-file "po/Makevars"
             (lambda (port)
               (format port "\
DOMAIN = $(PACKAGE)
subdir = po
top_builddir = ..
XGETTEXT_OPTIONS = --keyword=_ --keyword=N_ --keyword=G_
COPYRIGHT_HOLDER = Viven Kraus
PACKAGE_GNU =
MSGID_BUGS_ADDRESS = vivien@planete-kraus.eu
EXTRA_LOCALE_CATEGORIES =
USE_MSGCTXT = no
MSGMERGE_OPTIONS =
MSGINIT_OPTIONS =
PO_DEPENDS_ON_POT = yes
DIST_DEPENDS_ON_UPDATE_PO = yes
")))
         (call-with-output-file "collect-potfiles.sh"
           (lambda (port)
             (format port "
(for pattern in '*.scm' ;
 do find . -name \"$pattern\" ;
 done) > po/POTFILES.in
")
             (chmod port #o755)))
         (call-with-output-file "collect-linguas.sh"
           (lambda (port)
             (format port "
(for pofile in po/*.po ;
 do echo \"$pofile\" | cut -d '/' -f 2 | cut -d '.' -f 1 ;
 done) > po/LINGUAS
")
             (chmod port #o755)))
         (invoke "bash" "collect-potfiles.sh")
         (invoke "bash" "collect-linguas.sh")))
       (add-after 'hall-build-system 'define-package-bugreport
         (lambda _
           (substitute* "configure.ac"
             (("AC_INIT")
              (format #f "AC_INIT([disfluid], [~a], [vivien@planete-kraus.eu])
dnl AC_INIT"
                      ,version)))))
       (add-after 'unpack 'fix-gnutls-location
         (lambda* (#:key inputs #:allow-other-keys)
           (let ((gnutls (search-input-file inputs "/lib/libgnutls.so")))
             (substitute* '("disfluid/gnutls/datum.scm"
                            "disfluid/gnutls/global.scm"
                            "disfluid/gnutls/pubkey.scm"
                            "disfluid/gnutls/privkey.scm"
                            "disfluid/gnutls/x509/privkey.scm")
               (("\"libgnutls\"")
                (format #f "~s" gnutls))))))
       (add-after 'bootstrap 'fix-po-makefile-shell
         (lambda _
           (substitute* "po/Makefile.in.in"
             (("SHELL = /bin/sh")
              "SHELL = @SHELL@"))))
       (add-after 'check 'distcheck
         (lambda* (#:key make-flags inputs #:allow-other-keys)
           (apply invoke "make"
                  `(,@make-flags
                    "distcheck"
                    ,(format #f "DISTCHECK_CONFIGURE_FLAGS=SHELL=~a"
                             (search-input-file inputs "/bin/bash"))))
           (copy-file ,(format #f "disfluid-~a.tar.gz" version)
                      ,(format #f "/tmp/disfluid-~a.tar.gz" version))
           (with-directory-excursion "/tmp"
             (invoke "tar" "xf"
                     ,(format #f "disfluid-~a.tar.gz" version))
             (delete-file ,(format #f "disfluid-~a.tar.gz" version))
             (invoke "tar"
                     ;; see https://reproducible-builds.org/docs/archives/
                     "--sort=name"
                     "--mtime=2022-01-01 00:00Z"
                     "--owner=0"
                     "--group=0"
                     "--numeric-owner"
                     "--pax-option=exthdr.name=%d/PaxHeaders/%f,delete=atime,delete=ctime"
                     "-cf" ,(format #f "disfluid-~a.tar.gz" version)
                     ,(format #f "disfluid-~a" version)))
           (copy-file ,(format #f "/tmp/disfluid-~a.tar.gz" version)
                      ,(format #f "disfluid-~a.tar.gz" version))))
       (add-after 'build 'html
         (lambda* (#:key make-flags #:allow-other-keys)
           (apply invoke "make" "html" make-flags)))
       (add-before 'check 'set-tz
         (lambda* (#:key inputs #:allow-other-keys)
           (setenv "TZ" "CET")
           (setenv "TZDIR"
                   (search-input-directory inputs
                                           "share/zoneinfo"))))
       (add-after 'install 'install-complete-corresponding-source
         (lambda* (#:key outputs #:allow-other-keys)
           (let ((out (assoc-ref outputs "out")))
             (mkdir-p (string-append out "/share/disfluid"))
             (copy-file
              ,(format #f "disfluid-~a.tar.gz" version)
              (string-append
               out
               "/share/disfluid/complete-corresponding-source.tar.gz")))))
       (add-after 'install 'install-html
         (lambda* (#:key make-flags #:allow-other-keys)
           (apply invoke "make" "install-html" make-flags)))
       (add-after 'install 'wrap-disfluid
         (lambda* (#:key inputs outputs #:allow-other-keys)
           (let ((out (assoc-ref outputs "out")))
             (wrap-program (string-append out "/bin/disfluid")
               `("GUILE_LOAD_PATH" prefix
                 ,(search-path-as-list
                   '("share/guile/site/3.0")
                   (map cdr inputs)))
               `("GUILE_COMPILED_LOAD_PATH" prefix
                 ,(search-path-as-list
                   '("lib/guile/3.0/site-ccache")
                   (map cdr inputs)))
               `("GUILE_EXTENSIONS_PATH" prefix
                 ,(search-path-as-list
                   '("lib")
                   (map cdr inputs))))))))))