;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Andy Patterson <ajpatter@uwaterloo.ca>
;;;
;;; 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 asdf-build-system)
  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  #:use-module (guix build utils)
  #:use-module (guix build lisp-utils)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 rdelim)
  #:use-module (ice-9 receive)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 match)
  #:use-module (ice-9 format)
  #:export (%standard-phases/sbcl
            %standard-phases/ecl
            %standard-phases/source
            asdf-build
            asdf-build/source))

;; Commentary:
;;
;; System for building ASDF packages; creating executable programs and images
;; from them.
;;
;; Code:

(define %object-prefix "/lib")

(define %source-install-prefix
  (string-append %install-prefix "/source"))

(define %system-install-prefix
  (string-append %install-prefix "/systems"))

(define (output-path->package-name path)
  (package-name->name+version (strip-store-file-name path)))

(define (outputs->name outputs)
  (output-path->package-name
   (assoc-ref outputs "out")))

(define (wrap-source-registry registry)
  `(:source-registry
    ,@registry
    :inherit-configuration))

(define (wrap-output-translations translations)
  `(:output-translations
    ,@translations
    :inherit-configuration))

(define (source-directory output name)
  (string-append output %source-install-prefix "/" name))

(define (library-directory output lisp)
  (string-append output %object-prefix
                 "/" lisp))

(define (output-translation source-output
                            source-name
                            object-output
                            lisp)
  "Return a translation for the system's source output
to it's binary output."
  `((,(source-directory source-output source-name)
     :**/ :*.*.*)
    (,(library-directory object-output lisp)
     :**/ :*.*.*)))

(define (source-registry source-path)
  `(:tree ,source-path))

(define (lisp-dependency-names lisp inputs)
  (map first (lisp-dependencies lisp inputs)))

(define (copy-files-to-output outputs output name)
  "Copy all files from OUTPUT to \"out\". Create an extra link to any
system-defining files in the source to a convenient location. This is done
before any compiling so that the compiled source locations will be valid."
  (let* ((out (assoc-ref outputs output))
         (source (getcwd))
         (target (source-directory out name))
         (system-path (string-append out %system-install-prefix)))
    (copy-recursively source target)
    (mkdir-p system-path)
    (for-each
     (lambda (file)
       (symlink file
                (string-append system-path "/" (basename file))))
     (find-files target "\\.asd$"))
    #t))

(define* (install #:key outputs #:allow-other-keys)
  "Copy and symlink all the source files."
  (copy-files-to-output outputs "out" (outputs->name outputs)))

(define* (copy-source #:key outputs build-in-tree lisp
                      image? binary?
                      #:allow-other-keys)
  "Copy the source to the output named by BUILD-IN-TREE."
  (when (and build-in-tree (not image?) (not binary?))
    (let* ((out (assoc-ref outputs "out"))
           (name (remove-lisp-from-name (output-path->package-name out) lisp)))
      (copy-files-to-output outputs build-in-tree name)))
  #t)

(define* (build #:key outputs inputs lisp
                compile-dependencies
                source-input
                build-in-tree
                image?
                binary?
                #:allow-other-keys)
  "Compile the system."

  (unless (or binary? image?)
    (let* ((out (assoc-ref outputs "out"))
           (name (remove-lisp-from-name (output-path->package-name out) lisp))
           (source (cond
                    (source-input
                     (assoc-ref inputs source-input))
                    (build-in-tree (assoc-ref outputs build-in-tree))
                    (else (assoc-ref inputs name))))
           (source-name (or source-input name))
           (source-path (string-append source %source-install-prefix "/"
                                       source-name))
           (translations (wrap-output-translations
                          `(,(output-translation source
                                                 source-name
                                                 out
                                                 lisp))))
           (registry (map (match-lambda
                            ((_ . path) (source-registry path)))
                          (lisp-dependencies lisp inputs))))

      (setenv "ASDF_OUTPUT_TRANSLATIONS"
              (replace-escaped-macros (format #f "~S" translations)))
      (setenv "CL_SOURCE_REGISTRY"
              (replace-escaped-macros
               (format #f "~S" (wrap-source-registry
                                `(,(source-registry source-path)
                                  ,@registry)))))

      (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache

      (parameterize ((%lisp (string-append
                             (assoc-ref inputs lisp) "/bin/" lisp)))
        (compile-system name lisp compile-dependencies))

      ;; As above, ecl will sometimes create this even though it doesn't use it

      (let ((cache-directory (string-append out "/.cache")))
        (when (directory-exists? cache-directory)
          (delete-file-recursively cache-directory)))))
  #t)

(define* (check #:key lisp tests? outputs inputs
                compile-dependencies
                image?
                binary?
                #:allow-other-keys)
  "Test the system."

  (if (and tests? (not image?) (not binary?))
      (parameterize ((%lisp (string-append
                             (assoc-ref inputs lisp) "/bin/" lisp)))
        (test-system
         (remove-lisp-from-name (outputs->name outputs) lisp)
         lisp
         compile-dependencies))
      (format #t "test suite not run~%"))
  #t)

(define* (patch-asd-files #:key outputs
                          inputs
                          lisp
                          special-dependencies
                          image?
                          binary?
                          test-only-systems
                          #:allow-other-keys)
  "Patch any asd files created by the compilation process so that they
can find their dependencies. Exclude any TEST-ONLY-SYSTEMS which were only
included to run tests. Add any SPECIAL-DEPENDENCIES which the LISP
implementation itself provides."
  (unless (or image? binary?)
    (let* ((out (assoc-ref outputs "out"))
           (name (remove-lisp-from-name (output-path->package-name out) lisp))
           (registry (lset-difference
                      (lambda (input system)
                        (match input
                          ((name . path) (string=? name system))))
                      (lisp-dependencies lisp inputs)
                      test-only-systems))
           (lisp-systems (map first registry)))

      (for-each
       (lambda (asd-file)
         (patch-asd-file asd-file registry lisp
                         (append lisp-systems special-dependencies)))
       (find-files out "\\.asd$"))))
  #t)

(define* (symlink-asd-files #:key outputs lisp
                            image? binary?
                            #:allow-other-keys)
  "Create an extra reference to the system in a convenient location."
  (unless (or image? binary?)
    (let* ((out (assoc-ref outputs "out")))
      (for-each
       (lambda (asd-file)
         (receive (new-asd-file asd-file-directory)
             (bundle-asd-file out asd-file lisp)
           (mkdir-p asd-file-directory)
           (symlink asd-file new-asd-file)))

       (find-files out "\\.asd$"))))
  #t)

(define* (generate-binary #:key outputs
                          inputs
                          image-dependencies
                          entry-program
                          lisp
                          binary?
                          #:allow-other-keys)
  "Generate a binary program for the system, either in \"bin\" if the package
also contains a library system, or in \"out\" otherwise."
  (define output (if binary? "out" "bin"))
  (generate-executable #:outputs outputs
                       #:inputs inputs
                       #:image-dependencies image-dependencies
                       #:entry-program entry-program
                       #:lisp lisp
                       #:output output
                       #:needs-own-system? (not binary?)
                       #:type "program")
  (and=>
   (assoc-ref outputs output)
   (lambda (bin)
     (let* ((full-name (outputs->name outputs))
            (name (if binary? full-name
                      (remove-lisp-from-name full-name lisp)))
            (bin-directory (string-append bin "/bin")))
       (with-directory-excursion bin-directory
         (rename-file (string-append name "-exec")
                      name)))))
  #t)

(define* (generate-image #:key outputs
                         inputs
                         image-dependencies
                         lisp
                         image?
                         #:allow-other-keys)
  "Generate an image for the system, possibly standalone, either in \"image\"
if the package also contains a library system, or in \"out\" otherwise."
  (define output (if image? "out" "image"))
  (generate-executable #:outputs outputs
                       #:inputs inputs
                       #:image-dependencies image-dependencies
                       #:entry-program '(nil)
                       #:lisp lisp
                       #:output output
                       #:needs-own-system? (not image?)
                       #:type "image")
  (and=>
   (assoc-ref outputs output)
   (lambda (image)
     (let* ((full-name (outputs->name outputs))
            (name (if image? full-name
                      (remove-lisp-from-name full-name lisp)))
            (bin-directory (string-append image "/bin")))
       (with-directory-excursion bin-directory
         (rename-file (string-append name "-exec--all-systems.image")
                      (string-append name ".image"))))))
  #t)

(define* (generate-executable #:key outputs
                              image-dependencies
                              entry-program
                              lisp
                              output
                              inputs
                              type
                              needs-own-system?
                              #:allow-other-keys)
  "Generate an executable by using asdf's TYPE-op, containing whithin the
image all IMAGE-DEPNDENCIES, and running ENTRY-PROGRAM in the case of an
executable."
  (and=>
   (assoc-ref outputs output)
   (lambda (out)
     (let* ((bin-directory (string-append out "/bin"))
            (full-name (outputs->name outputs))
            (name (if needs-own-system?
                      (remove-lisp-from-name full-name lisp)
                      full-name)))
       (mkdir-p out)
       (with-directory-excursion out
         (generate-executable-wrapper-system name
                                             image-dependencies
                                             needs-own-system?)
         (generate-executable-entry-point name entry-program))

       (setenv "CL_SOURCE_REGISTRY"
               (replace-escaped-macros
                (format
                 #f "~S"
                 (wrap-source-registry
                  `(,(source-registry (assoc-ref outputs "out"))
                    ,(source-registry out)
                    ,@(map (lambda (dependency)
                             (source-registry (assoc-ref inputs dependency)))
                           image-dependencies))))))

       (setenv "ASDF_OUTPUT_TRANSLATIONS"
               (replace-escaped-macros
                (format
                 #f "~S"
                 (wrap-output-translations
                  `(((,out :**/ :*.*.*)
                     (,bin-directory :**/ :*.*.*)))))))

       (parameterize ((%lisp (string-append
                              (assoc-ref inputs lisp) "/bin/" lisp)))
         (generate-executable-for-system type name lisp))

       (delete-file (string-append out "/" name "-exec.asd"))
       (delete-file (string-append out "/" name "-exec.lisp"))))))

(define* (cleanup-files/sbcl #:key outputs binary? image? lisp
                             #:allow-other-keys)
  "Remove any compiled files which are not a part of the final bundle."
  (unless (or binary? image?)
    (let ((out (assoc-ref outputs "out")))
      (for-each
       (lambda (file)
         (unless (string-suffix? "--system.fasl" file)
           (delete-file file)))
       (find-files out "\\.fasl$"))))
  #t)

(define* (cleanup-files/ecl #:key outputs binary? image?
                             #:allow-other-keys)
  "Remove any compiled files which are not a part of the final bundle."
  (unless (or binary? image?)
    (let ((out (assoc-ref outputs "out")))
      (for-each delete-file
                (append (find-files out "\\.fas$")
                        (find-files out "\\.o$")))))
  #t)

(define %standard-phases/source
  (modify-phases gnu:%standard-phases
    (delete 'configure)
    (delete 'check)
    (delete 'build)
    (replace 'install install)))

(define %standard-phases
  (modify-phases gnu:%standard-phases
    (delete 'configure)
    (delete 'install)
    (replace 'build build)
    (add-before 'build 'copy-source copy-source)
    (replace 'check check)
    (add-after 'check 'link-dependencies patch-asd-files)
    (add-after 'link-dependencies 'create-symlinks symlink-asd-files)
    (add-after 'create-symlinks 'cleanup cleanup-files/sbcl)
    (add-after 'cleanup 'generate-binary generate-binary)
    (add-after 'generate-binary 'generate-image generate-image)))

(define %standard-phases/sbcl
  (modify-phases %standard-phases
    ;; stripping sbcl binaries removes their entry program and extra systems
    (delete 'strip)))

(define %standard-phases/ecl
  (modify-phases %standard-phases
    (replace 'cleanup cleanup-files/ecl)))

(define* (asdf-build #:key inputs
                     (phases %standard-phases)
                     #:allow-other-keys
                     #:rest args)
  (apply gnu:gnu-build
         #:inputs inputs
         #:phases phases
         args))

(define* (asdf-build/source #:key inputs
                            (phases %standard-phases/source)
                            #:allow-other-keys
                            #:rest args)
  (apply gnu:gnu-build
         #:inputs inputs
         #:phases phases
         args))

;;; asdf-build-system.scm ends here