;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
;;; Copyright © 2019, 2020, 2021, 2022 Guillaume Le Vaillant <glv@posteo.net>
;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2022 Pierre Neidhardt <mail@ambrevar.xyz>
;;;
;;; 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/>.

(define-module (guix build-system asdf)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:use-module (guix memoization)
  #:use-module (guix packages)
  #:use-module (guix gexp)
  #:use-module (guix monads)
  #:use-module (guix search-paths)
  #:use-module ((guix build utils)
                #:select ((package-name->name+version
                           . hyphen-separated-name->name+version)))
  #:use-module (guix build-system)
  #:use-module (guix build-system gnu)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (gnu packages)
  #:export (%asdf-build-system-modules
            %asdf-build-modules
            asdf-build
            asdf-build-system/sbcl
            asdf-build-system/ecl
            asdf-build-system/source
            sbcl-package->cl-source-package
            sbcl-package->ecl-package))

;; Commentary:
;;
;; Standard build procedure for asdf packages.  This is implemented as an
;; extension of 'gnu-build-system'.
;;
;; Code:

(define %asdf-build-system-modules
  ;; Imported build-side modules
  `((guix build asdf-build-system)
    (guix build lisp-utils)
    (guix build union)
    ,@%gnu-build-system-modules))

(define %asdf-build-modules
  ;; Used (visible) build-side modules
  '((guix build asdf-build-system)
    (guix build utils)
    (guix build union)
    (guix build lisp-utils)))

(define (default-lisp implementation)
  "Return the default package for the lisp IMPLEMENTATION."
  ;; Lazily resolve the binding to avoid a circular dependency.
  (let ((lisp-module (resolve-interface '(gnu packages lisp))))
    (module-ref lisp-module implementation)))

(define* (lower/source name
                       #:key source inputs outputs native-inputs system target
                       #:allow-other-keys
                       #:rest arguments)
  "Return a bag for NAME"
  (define private-keywords
    '(#:target #:inputs #:native-inputs))

  (and (not target)
       (bag
         (name name)
         (system system)
         (host-inputs `(,@(if source
                              `(("source" ,source))
                              '())
                        ,@inputs
                        ,@(standard-packages)))
         (build-inputs native-inputs)
         (outputs outputs)
         (build asdf-build/source)
         (arguments (strip-keyword-arguments private-keywords arguments)))))

(define* (asdf-build/source name inputs
                            #:key source outputs
                            (phases '%standard-phases/source)
                            (search-paths '())
                            (system (%current-system))
                            (guile #f)
                            (imported-modules %asdf-build-system-modules)
                            (modules %asdf-build-modules))
  (define builder
    (with-imported-modules imported-modules
      #~(begin
          (use-modules #$@(sexp->gexp modules))
          (asdf-build/source #:name #$name
                             #:source #+source
                             #:system #$system
                             #:phases #$phases
                             #:outputs #$(outputs->gexp outputs)
                             #:search-paths '#$(sexp->gexp
                                                (map search-path-specification->sexp
                                                     search-paths))
                             #:inputs #$(input-tuples->gexp inputs)))))

  (mlet %store-monad ((guile (package->derivation (or guile (default-guile))
                                                  system #:graft? #f)))
    (gexp->derivation name builder
                      #:system system
                      #:guile-for-build guile)))

(define* (package-with-build-system from-build-system to-build-system
                                    from-prefix to-prefix
                                    #:key variant-property
                                    phases-transformer)
  "Return a precedure which takes a package PKG which uses FROM-BUILD-SYSTEM,
and returns one using TO-BUILD-SYSTEM.  If PKG was prefixed by FROM-PREFIX,
the resulting package will be prefixed by TO-PREFIX.  Inputs of PKG are
recursively transformed using the same rule.  The result's #:phases argument
will be modified by PHASES-TRANSFORMER, an S-expression which evaluates on the
build side to a procedure of one argument.

VARIANT-PROPERTY can be added to a package's properties to indicate that the
corresponding package promise should be used as the result of this
transformation.  This allows the result to differ from what the transformation
would otherwise produce.

If TO-BUILD-SYSTEM is asdf-build-system/source, the resulting package will be
set up using CL source package conventions."
  (define target-is-source? (eq? asdf-build-system/source to-build-system))

  (define (transform-package-name name)
    (if (string-prefix? from-prefix name)
        (let ((new-name (string-drop name (string-length from-prefix))))
          (if (string-prefix? to-prefix new-name)
              new-name
              (string-append to-prefix new-name)))
        name))

  (define (has-from-build-system? pkg)
    (and (package? pkg)
         (eq? from-build-system (package-build-system pkg))))

  (define (find-input-package pkg)
    (let* ((name (package-name pkg))
           (new-name (transform-package-name name))
           (pkgs (find-packages-by-name new-name)))
      (if (null? pkgs) #f (list-ref pkgs 0))))

  (define transform
    (mlambda (pkg)
      (define rewrite
        (match-lambda
          ((name content . rest)
           (let* ((is-package? (package? content))
                  (new-content (if is-package?
                                   (or (find-input-package content)
                                       (transform content))
                                   content)))
             `(,name ,new-content ,@rest)))))

      ;; Special considerations for source packages: CL inputs become
      ;; propagated, and un-handled arguments are removed.

      (define (new-propagated-inputs)
        (if target-is-source?
            (map rewrite
                 (append
                  (filter (match-lambda
                            ((_ input . _)
                             (has-from-build-system? input)))
                          (append (package-inputs pkg)
                                  ;; The native inputs might be needed just
                                  ;; to load the system.
                                  (package-native-inputs pkg)))
                  (package-propagated-inputs pkg)))

            (map rewrite (package-propagated-inputs pkg))))

      (define (new-inputs inputs-getter)
        (if target-is-source?
            (map rewrite
                 (filter (match-lambda
                           ((_ input . _)
                            (not (has-from-build-system? input))))
                         (inputs-getter pkg)))
            (map rewrite (inputs-getter pkg))))

      (define base-arguments
        (if target-is-source?
            (strip-keyword-arguments
             '(#:tests? #:lisp #:asd-systems #:asd-test-systems #:asd-operation)
             (package-arguments pkg))
            (package-arguments pkg)))

      (cond
       ((and variant-property
             (assoc-ref (package-properties pkg) variant-property))
        => force)

       ((has-from-build-system? pkg)
        (package
          (inherit pkg)
          (location (package-location pkg))
          (name (transform-package-name (package-name pkg)))
          (build-system to-build-system)
          (arguments
           (substitute-keyword-arguments base-arguments
             ((#:phases phases) (list phases-transformer phases))))
          (inputs (new-inputs package-inputs))
          (propagated-inputs (new-propagated-inputs))
          (native-inputs (append (if target-is-source?
                                     (list (list (package-name pkg) pkg))
                                     '())
                                 (new-inputs package-native-inputs)))
          (outputs (if target-is-source?
                       '("out")
                       (package-outputs pkg)))))
       (else pkg))))

  transform)

(define (strip-variant-as-necessary variant pkg)
  (define properties (package-properties pkg))
  (if (assoc variant properties)
      (package
        (inherit pkg)
        (properties (alist-delete variant properties)))
      pkg))

(define (lower lisp-type)
  (lambda* (name
            #:key source inputs outputs native-inputs system target
            (lisp (default-lisp (string->symbol lisp-type)))
            #:allow-other-keys
            #:rest arguments)
    "Return a bag for NAME"
    (define private-keywords
      '(#:target #:inputs #:native-inputs #:lisp))

    (and (not target)
         (bag
           (name name)
           (system system)
           (host-inputs `(,@(if source
                                `(("source" ,source))
                                '())
                          ,@inputs
                          ,@(standard-packages)))
           (build-inputs `((,lisp-type ,lisp)
                           ,@native-inputs))
           (outputs outputs)
           (build (asdf-build lisp-type))
           (arguments (strip-keyword-arguments private-keywords arguments))))))

(define (asdf-build lisp-type)
  (lambda* (name inputs
                 #:key source outputs
                 (tests? #t)
                 (asd-systems ''())
                 (asd-test-systems ''())
                 (asd-operation "load-system")
                 (phases '%standard-phases)
                 (search-paths '())
                 (system (%current-system))
                 (guile #f)
                 (imported-modules %asdf-build-system-modules)
                 (modules %asdf-build-modules))

    (define systems
      (if (null? (cadr asd-systems))
          ;; FIXME: Find a more reliable way to get the main system name.
          (let* ((lisp-prefix (string-append lisp-type "-"))
                 (package-name (hyphen-separated-name->name+version
                                (if (string-prefix? lisp-prefix name)
                                    (string-drop name
                                                 (string-length lisp-prefix))
                                    name))))
            `(quote ,(list package-name)))
          asd-systems))

    (define test-systems
      (if (null? (cadr asd-test-systems))
          systems
          asd-test-systems))

    (define builder
      (with-imported-modules imported-modules
        #~(begin
            (use-modules #$@(sexp->gexp modules))
            (parameterize ((%lisp (search-input-file
                                   #$(input-tuples->gexp inputs)
                                   (string-append "bin/" #$lisp-type)))
                           (%lisp-type #$lisp-type))
              (asdf-build #:name #$name
                          #:source #+source
                          #:asd-systems #$systems
                          #:asd-test-systems #$test-systems
                          #:asd-operation #$asd-operation
                          #:system #$system
                          #:tests? #$tests?
                          #:phases #$phases
                          #:outputs #$(outputs->gexp outputs)
                          #:search-paths '#$(sexp->gexp
                                             (map search-path-specification->sexp
                                                  search-paths))
                          #:inputs #$(input-tuples->gexp inputs))))))

    (mlet %store-monad ((guile (package->derivation (or guile (default-guile))
                                                    system #:graft? #f)))
      (gexp->derivation name builder
                        #:system system
                        #:guile-for-build guile))))

(define asdf-build-system/sbcl
  (build-system
    (name 'asdf/sbcl)
    (description "The build system for ASDF binary packages using SBCL")
    (lower (lower "sbcl"))))

(define asdf-build-system/ecl
  (build-system
    (name 'asdf/ecl)
    (description "The build system for ASDF binary packages using ECL")
    (lower (lower "ecl"))))

(define asdf-build-system/source
  (build-system
    (name 'asdf/source)
    (description "The build system for ASDF source packages")
    (lower lower/source)))

(define sbcl-package->cl-source-package
  (let* ((property 'cl-source-variant)
         (transformer
          (package-with-build-system asdf-build-system/sbcl
                                     asdf-build-system/source
                                     "sbcl-"
                                     "cl-"
                                     #:variant-property property
                                     #:phases-transformer
                                     '(const %standard-phases/source))))
    (lambda (pkg)
      (transformer
       (strip-variant-as-necessary property pkg)))))

(define sbcl-package->ecl-package
  (let* ((property 'ecl-variant)
         (transformer
          (package-with-build-system asdf-build-system/sbcl
                                     asdf-build-system/ecl
                                     "sbcl-"
                                     "ecl-"
                                     #:variant-property property
                                     #:phases-transformer
                                     'identity)))
    (lambda (pkg)
      (transformer
       (strip-variant-as-necessary property pkg)))))

;;; asdf.scm ends here