;;; 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 lisp-utils)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:export (%lisp
            %install-prefix
            lisp-eval-program
            compile-system
            test-system
            replace-escaped-macros
            generate-executable-wrapper-system
            generate-executable-entry-point
            generate-executable-for-system
            patch-asd-file
            bundle-install-prefix
            lisp-dependencies
            bundle-asd-file
            remove-lisp-from-name))

;;; Commentary:
;;;
;;; Tools to evaluate lisp programs within a lisp session, generate wrapper
;;; systems for executables. Compile, test, and produce images for systems and
;;; programs, and link them with their dependencies.
;;;
;;; Code:

(define %lisp
  (make-parameter "lisp"))

(define %install-prefix "/share/common-lisp")

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

(define (remove-lisp-from-name name lisp)
  (string-drop name (1+ (string-length lisp))))

(define (lisp-eval-program lisp program)
  "Evaluate PROGRAM with a given LISP implementation."
  (unless (zero? (apply system*
                        (lisp-invoke lisp (format #f "~S" program))))
    (error "lisp-eval-program failed!" lisp program)))

(define (lisp-invoke lisp program)
  "Return a list of arguments for system* determining how to invoke LISP
with PROGRAM."
  (match lisp
    ("sbcl" `(,(%lisp) "--non-interactive" "--eval" ,program))
    ("ecl" `(,(%lisp) "-eval" ,program "-eval" "(quit)"))))

(define (asdf-load-all systems)
  (map (lambda (system)
         `(funcall
           (find-symbol
            (symbol-name :load-system)
            (symbol-name :asdf))
           ,system))
       systems))

(define (compile-system system lisp other-required-systems)
  "Use a lisp implementation to compile SYSTEM using asdf. Loads
OTHER-REQUIRED-SYSTEMS before beginning compilation."
  (lisp-eval-program lisp
                     `(progn
                       (require :asdf)
                       ,@(asdf-load-all other-required-systems)
                       (funcall (find-symbol
                                 (symbol-name :operate)
                                 (symbol-name :asdf))
                                (find-symbol
                                 (symbol-name :compile-bundle-op)
                                 (symbol-name :asdf))
                                ,system)
                       (funcall (find-symbol
                                 (symbol-name :operate)
                                 (symbol-name :asdf))
                                (find-symbol
                                 (symbol-name :deliver-asd-op)
                                 (symbol-name :asdf))
                                ,system))))

(define (test-system system lisp other-required-systems)
  "Use a lisp implementation to test SYSTEM using asdf. Loads
OTHER-REQUIRED-SYSTEMS before beginning to test."
  (lisp-eval-program lisp
                     `(progn
                       (require :asdf)
                       ,@(asdf-load-all other-required-systems)
                       (funcall (find-symbol
                                 (symbol-name :test-system)
                                 (symbol-name :asdf))
                                ,system))))

(define (string->lisp-keyword . strings)
  "Return a lisp keyword for the concatenation of STRINGS."
  (string->symbol (apply string-append ":" strings)))

(define (generate-executable-for-system type system lisp)
  "Use LISP to generate an executable, whose TYPE can be \"image\"
or \"program\". The latter will always be standalone. Depends on having
created a \"SYSTEM-exec\" system which contains the entry program."
  (lisp-eval-program
   lisp
   `(progn
     (require :asdf)
     (funcall (find-symbol
               (symbol-name :operate)
               (symbol-name :asdf))
              (find-symbol
               (symbol-name ,(string->lisp-keyword type "-op"))
               (symbol-name :asdf))
              ,(string-append system "-exec")))))

(define (generate-executable-wrapper-system system
                                            dependencies
                                            needs-system?)
  "Generates a system which can be used by asdf to produce an image or program
inside the current directory. The image or program will contain SYSTEM and all
other DEPENDENCIES, which may not be depended on by the SYSTEM itself. SYSTEM
will be excluded unless NEEDS-SYSTEM? is #t."
  (with-output-to-file (string-append system "-exec.asd")
    (lambda _
      (format #t "~y~%"
              `(defsystem ,(string->lisp-keyword system "-exec")
                 :entry-point ,(string-append system "-exec:main")
                 :depends-on (:uiop
                              ,@(if needs-system?
                                    `(,(string->lisp-keyword system))
                                    '())
                              ,@(map string->lisp-keyword
                                     dependencies))
                 :components ((:file ,(string-append system "-exec"))))))))

(define (generate-executable-entry-point system entry-program)
  "Generates an entry point program from the list of lisp statements
ENTRY-PROGRAM for SYSTEM within the current directory."
  (with-output-to-file (string-append system "-exec.lisp")
    (lambda _
      (let ((system (string->lisp-keyword system "-exec")))
        (format #t "~{~y~%~%~}"
                `((defpackage ,system
                    (:use :cl)
                    (:export :main))

                  (in-package ,system)

                  (defun main ()
                    (let ((arguments uiop:*command-line-arguments*))
                      (declare (ignorable arguments))
                      ,@entry-program))))))))

(define (wrap-perform-method lisp registry dependencies file-name)
  "Creates a wrapper method which allows the system to locate its dependent
systems from REGISTRY, an alist of the same form as %outputs, which contains
lisp systems which the systems is dependent on. All DEPENDENCIES which
the system depends on will the be loaded before this system."
  (let* ((system (string-drop-right (basename file-name) 4))
         (system-symbol (string->lisp-keyword system)))

    `(defmethod asdf:perform :before
       (op (c (eql (asdf:find-system ,system-symbol))))
       (asdf/source-registry:ensure-source-registry)
       ,@(map (match-lambda
                ((name . path)
                 (let ((asd-file (string-append path
                                                (bundle-install-prefix lisp)
                                                "/" name ".asd")))
                   `(setf
                     (gethash ,name
                              asdf/source-registry:*source-registry*)
                     ,(string->symbol "#p")
                     ,(bundle-asd-file path asd-file lisp)))))
              registry)
       ,@(map (lambda (system)
                `(asdf:load-system ,(string->lisp-keyword system)))
              dependencies))))

(define (patch-asd-file asd-file registry lisp dependencies)
  "Patches ASD-FILE with a perform method as described in WRAP-PERFORM-METHOD."
  (chmod asd-file #o644)
  (let ((port (open-file asd-file "a")))
    (dynamic-wind
      (lambda _ #t)
      (lambda _
        (display
         (replace-escaped-macros
          (format #f "~%~y~%"
                  (wrap-perform-method lisp registry
                                       dependencies asd-file)))
         port))
      (lambda _ (close-port port))))
  (chmod asd-file #o444))

(define (lisp-dependencies lisp inputs)
  "Determine which inputs are lisp system dependencies, by using the convention
that a lisp system dependency will resemble \"system-LISP\"."
  (filter-map (match-lambda
                ((name . value)
                 (and (string-prefix? lisp name)
                      (string<> lisp name)
                      `(,(remove-lisp-from-name name lisp)
                        . ,value))))
              inputs))

(define (bundle-asd-file output-path original-asd-file lisp)
  "Find the symlinked bundle file for ORIGINAL-ASD-FILE by looking
in OUTPUT-PATH/lib/LISP/<system>.asd. Returns two values: the asd
file itself and the directory in which it resides."
  (let ((bundle-asd-path (string-append output-path
                                        (bundle-install-prefix lisp))))
    (values (string-append bundle-asd-path "/" (basename original-asd-file))
            bundle-asd-path)))

(define (replace-escaped-macros string)
  "Replace simple lisp forms that the guile writer escapes, for
example by replacing #{#p}# with #p. Should only be used to replace
truly simple forms which are not nested."
  (regexp-substitute/global #f "(#\\{)(\\S*)(\\}#)" string
                            'pre 2 'post))