guix/build/lisp-utils.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix build lisp-utils)
  20   #:use-module (ice-9 format)
  21   #:use-module (ice-9 hash-table)
  22   #:use-module (ice-9 match)
  23   #:use-module (ice-9 regex)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-26)
  26   #:use-module (guix build utils)
  27   #:export (%lisp
  28             %lisp-type
  29             %source-install-prefix
  30             lisp-eval-program
  31             compile-system
  32             test-system
  33             replace-escaped-macros
  34             generate-executable-wrapper-system
  35             generate-executable-entry-point
  36             generate-executable-for-system
  37             %bundle-install-prefix
  38             bundle-asd-file
  39             wrap-output-translations
  40             prepend-to-source-registry
  41             build-program
  42             build-image
  43             make-asd-file
  44             valid-char-set
  45             normalize-string
  46             library-output))
  47
  48 ;;; Commentary:
  49 ;;;
  50 ;;; Tools to evaluate lisp programs within a lisp session, generate wrapper
  51 ;;; systems for executables. Compile, test, and produce images for systems and
  52 ;;; programs, and link them with their dependencies.
  53 ;;;
  54 ;;; Code:
  55
  56 (define %lisp
  57   ;; File name of the Lisp compiler.
  58   (make-parameter "lisp"))
  59
  60 (define %lisp-type
  61   ;; String representing the class of implementation being used.
  62   (make-parameter "lisp"))
  63
  64 ;; The common parent for Lisp source files, as will as the symbolic
  65 ;; link farm for system definition (.asd) files.
  66 (define %source-install-prefix "/share/common-lisp")
  67
  68 (define (%bundle-install-prefix)
  69   (string-append %source-install-prefix "/" (%lisp-type) "-bundle-systems"))
  70
  71 (define (library-output outputs)
  72   "If a `lib' output exists, build things there. Otherwise use `out'."
  73   (or (assoc-ref outputs "lib") (assoc-ref outputs "out")))
  74
  75 ;; See nix/libstore/store-api.cc#checkStoreName.
  76 (define valid-char-set
  77   (string->char-set
  78    "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+-._?="))
  79
  80 (define (normalize-string str)
  81   "Replace invalid characters in STR with a hyphen."
  82   (string-join (string-tokenize str valid-char-set) "-"))
  83
  84 (define (normalize-dependency dependency)
  85   "Normalize the name of DEPENDENCY.  Handles dependency definitions of the
  86 dependency-def form described by
  87 <https://common-lisp.net/project/asdf/asdf.html#The-defsystem-grammar>.
  88 Assume that any symbols in DEPENDENCY will be in upper-case."
  89   (match dependency
  90     ((':VERSION name rest ...)
  91      `(:version ,(normalize-string name) ,@rest))
  92     ((':FEATURE feature-specification dependency-specification)
  93      `(:feature
  94        ,feature-specification
  95        ,(normalize-dependency dependency-specification)))
  96     ((? string? name) (normalize-string name))
  97     (require-specification require-specification)))
  98
  99 (define (inputs->asd-file-map inputs)
 100   "Produce a hash table of the form (system . asd-file), where system is the
 101 name of an ASD system, and asd-file is the full path to its definition."
 102   (alist->hash-table
 103    (filter-map
 104     (match-lambda
 105       ((_ . path)
 106        (let ((prefix (string-append path (%bundle-install-prefix))))
 107          (and (directory-exists? prefix)
 108               (match (find-files prefix "\\.asd$")
 109                 ((asd-file)
 110                  (cons
 111                   (string-drop-right (basename asd-file) 4) ; drop ".asd"
 112                   asd-file))
 113                 (_ #f))))))
 114     inputs)))
 115
 116 (define (wrap-output-translations translations)
 117   `(:output-translations
 118     ,@translations
 119     :inherit-configuration))
 120
 121 (define (lisp-eval-program program)
 122   "Evaluate PROGRAM with a given LISP implementation."
 123   (define invocation (lisp-invocation program))
 124   (format #t "Invoking ~a: ~{~s ~}~%" (%lisp-type) invocation)
 125   (apply invoke invocation))
 126
 127 (define (spread-statements program argument-name)
 128   "Return a list with the statements from PROGRAM spread between
 129 ARGUMENT-NAME, a string representing the argument a lisp implementation uses
 130 to accept statements to be evaluated before starting."
 131   (append-map (lambda (statement)
 132                 (list argument-name (format #f "~S" statement)))
 133               program))
 134
 135 (define (lisp-invocation program)
 136   "Return a list of arguments for system* determining how to invoke LISP
 137 with PROGRAM."
 138   (match (%lisp-type)
 139     ("sbcl" `(,(%lisp) "--non-interactive"
 140               ,@(spread-statements program "--eval")))
 141     ("ecl" `(,(%lisp)
 142              ,@(spread-statements program "--eval")
 143              "--eval" "(quit)"))
 144     (_ (error "The LISP provided is not supported at this time."))))
 145
 146 (define (asdf-load-all systems)
 147   (map (lambda (system)
 148          `(asdf:load-system ,system))
 149        systems))
 150
 151 (define (compile-system system asd-file)
 152   "Use a lisp implementation to compile SYSTEM using asdf.  Load ASD-FILE
 153 first."
 154   (lisp-eval-program
 155    `((require :asdf)
 156      (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system))
 157      (asdf:operate 'asdf:compile-bundle-op ,system))))
 158
 159 (define (system-dependencies system asd-file)
 160   "Return the dependencies of SYSTEM, as reported by
 161 asdf:system-depends-on.  First load the system's ASD-FILE."
 162   (define deps-file ".deps.sexp")
 163   (define program
 164     `((require :asdf)
 165       (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system))
 166       (with-open-file
 167        (stream ,deps-file :direction :output)
 168        (format stream
 169                "~s~%"
 170                (asdf:system-depends-on
 171                 (asdf:find-system ,system))))))
 172
 173   (dynamic-wind
 174     (lambda _
 175       (lisp-eval-program program))
 176     (lambda _
 177       (call-with-input-file deps-file read))
 178     (lambda _
 179       (when (file-exists? deps-file)
 180         (delete-file deps-file)))))
 181
 182 (define (compiled-system system)
 183   (let ((system (basename system))) ; this is how asdf handles slashes
 184     (match (%lisp-type)
 185       ("sbcl" (string-append system "--system"))
 186       (_ system))))
 187
 188 (define* (generate-system-definition system
 189                                      #:key version dependencies component?)
 190   `(asdf:defsystem
 191     ,(normalize-string system)
 192     ,@(if component?
 193           '(:class asdf/bundle:prebuilt-system)
 194           '())
 195     :version ,version
 196     :depends-on ,dependencies
 197     ,@(if component?
 198           `(:components ((:compiled-file ,(compiled-system system))))
 199           '())
 200     ,@(if (string=? "ecl" (%lisp-type))
 201           `(:lib ,(string-append system ".a"))
 202           '())))
 203
 204 (define (test-system system asd-file test-asd-file)
 205   "Use a lisp implementation to test SYSTEM using asdf.  Load ASD-FILE first.
 206 Also load TEST-ASD-FILE if necessary."
 207   (lisp-eval-program
 208    `((require :asdf)
 209      (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system))
 210      ,@(if test-asd-file
 211            `((asdf:load-asd (truename ,test-asd-file)))
 212            ;; Try some likely files.
 213            (map (lambda (file)
 214                   `(when (uiop:file-exists-p ,file)
 215                      (asdf:load-asd (truename ,file))))
 216                 (list
 217                  (string-append system "-tests.asd")
 218                  (string-append system "-test.asd")
 219                  "tests.asd"
 220                  "test.asd")))
 221      (asdf:test-system ,system))))
 222
 223 (define (string->lisp-keyword . strings)
 224   "Return a lisp keyword for the concatenation of STRINGS."
 225   (string->symbol (apply string-append ":" strings)))
 226
 227 (define* (generate-executable-for-system type system #:key compress?)
 228   "Use LISP to generate an executable, whose TYPE can be 'asdf:image-op or
 229 'asdf:program-op.  The latter will always be standalone.  Depends on having
 230 created a \"SYSTEM-exec\" system which contains the entry program."
 231   (lisp-eval-program
 232    `((require :asdf)
 233      ;; Only SBCL supports compression as of 2019-09-02.
 234      ,(if (and compress? (string=? (%lisp-type) "sbcl"))
 235           '(defmethod asdf:perform ((o asdf:image-op) (c asdf:system))
 236                       (uiop:dump-image (asdf:output-file o c)
 237                                        :executable t
 238                                        :compression t))
 239           '())
 240      (asdf:operate ',type ,(string-append system "-exec")))))
 241
 242 (define (generate-executable-wrapper-system system dependencies)
 243   "Generates a system which can be used by asdf to produce an image or program
 244 inside the current directory.  The image or program will contain
 245 DEPENDENCIES."
 246   (with-output-to-file (string-append system "-exec.asd")
 247     (lambda _
 248       (format #t "~y~%"
 249               `(defsystem ,(string->lisp-keyword system "-exec")
 250                  :entry-point ,(string-append system "-exec:main")
 251                  :depends-on (:uiop
 252                               ,@(map string->lisp-keyword
 253                                      dependencies))
 254                  :components ((:file ,(string-append system "-exec"))))))))
 255
 256 (define (generate-executable-entry-point system entry-program)
 257   "Generates an entry point program from the list of lisp statements
 258 ENTRY-PROGRAM for SYSTEM within the current directory."
 259   (with-output-to-file (string-append system "-exec.lisp")
 260     (lambda _
 261       (let ((system (string->lisp-keyword system "-exec")))
 262         (format #t "~{~y~%~%~}"
 263                 `((defpackage ,system
 264                     (:use :cl)
 265                     (:export :main))
 266
 267                   (in-package ,system)
 268
 269                   (defun main ()
 270                     (let ((arguments uiop:*command-line-arguments*))
 271                       (declare (ignorable arguments))
 272                       ,@entry-program))))))))
 273
 274 (define (generate-dependency-links registry system)
 275   "Creates a program which populates asdf's source registry from REGISTRY, an
 276 alist of dependency names to corresponding asd files.  This allows the system
 277 to locate its dependent systems."
 278   `(progn
 279     (asdf/source-registry:ensure-source-registry)
 280     ,@(map (match-lambda
 281              ((name . asd-file)
 282               `(setf
 283                 (gethash ,name
 284                          asdf/source-registry:*source-registry*)
 285                 ,(string->symbol "#p")
 286                 ,asd-file)))
 287            registry)))
 288
 289 (define* (make-asd-file asd-file
 290                         #:key system version inputs
 291                         (system-asd-file #f))
 292   "Create an ASD-FILE for SYSTEM@VERSION, appending a program to allow the
 293 system to find its dependencies, as described by GENERATE-DEPENDENCY-LINKS."
 294   (define dependencies
 295     (let ((deps
 296            (system-dependencies system system-asd-file)))
 297       (if (eq? 'NIL deps)
 298           '()
 299           (map normalize-dependency deps))))
 300
 301   (define lisp-input-map
 302     (inputs->asd-file-map inputs))
 303
 304   (define dependency-name
 305     (match-lambda
 306       ((':version name _ ...) name)
 307       ((':feature _ dependency-specification)
 308        (dependency-name dependency-specification))
 309       ((? string? name) name)
 310       (_ #f)))
 311
 312   (define registry
 313     (filter-map hash-get-handle
 314                 (make-list (length dependencies)
 315                            lisp-input-map)
 316                 (map dependency-name dependencies)))
 317
 318   ;; Ensure directory exists, which might not be the case for an .asd without components.
 319   (mkdir-p (dirname asd-file))
 320   (call-with-output-file asd-file
 321     (lambda (port)
 322       (display
 323        (replace-escaped-macros
 324         (format #f "~y~%~y~%"
 325                 (generate-system-definition
 326                  system
 327                  #:version version
 328                  #:dependencies dependencies
 329                  ;; Some .asd don't have components, and thus they don't generate any .fasl.
 330                  #:component? (match (%lisp-type)
 331                                 ("sbcl" (pair? (find-files (dirname asd-file)
 332                                                            "--system\\.fasl$")))
 333                                 ("ecl" (pair? (find-files (dirname asd-file)
 334                                                           "\\.fasb$")))
 335                                 (_ (error "The LISP provided is not supported at this time."))))
 336                 (generate-dependency-links registry system)))
 337        port))))
 338
 339 (define (bundle-asd-file output-path original-asd-file)
 340   "Find the symlinked bundle file for ORIGINAL-ASD-FILE by looking in
 341 OUTPUT-PATH/share/common-lisp/LISP-bundle-systems/<system>.asd.  Returns two
 342 values: the asd file itself and the directory in which it resides."
 343   (let ((bundle-asd-path (string-append output-path
 344                                         (%bundle-install-prefix))))
 345     (values (string-append bundle-asd-path "/" (basename original-asd-file))
 346             bundle-asd-path)))
 347
 348 (define (replace-escaped-macros string)
 349   "Replace simple lisp forms that the guile writer escapes, for example by
 350 replacing #{#p}# with #p.  Should only be used to replace truly simple forms
 351 which are not nested."
 352   (regexp-substitute/global #f "(#\\{)(\\S*)(\\}#)" string
 353                             'pre 2 'post))
 354
 355 (define (prepend-to-source-registry path)
 356   (setenv "CL_SOURCE_REGISTRY"
 357           (string-append path ":" (or (getenv "CL_SOURCE_REGISTRY") ""))))
 358
 359 (define* (build-program program outputs #:key
 360                         (dependency-prefixes (list (library-output outputs)))
 361                         (dependencies (list (basename program)))
 362                         entry-program
 363                         compress?
 364                         #:allow-other-keys)
 365   "Generate an executable program containing all DEPENDENCIES, and which will
 366 execute ENTRY-PROGRAM.  The result is placed in PROGRAM.  When executed, it
 367 will run ENTRY-PROGRAM, a list of Common Lisp expressions in which `arguments'
 368 has been bound to the command-line arguments which were passed.  Link in any
 369 asd files from DEPENDENCY-PREFIXES to ensure references to those libraries are
 370 retained."
 371   (generate-executable program
 372                        #:dependencies dependencies
 373                        #:dependency-prefixes dependency-prefixes
 374                        #:entry-program entry-program
 375                        #:compress? compress?
 376                        #:type 'asdf:program-op)
 377   (let* ((name (basename program))
 378          (bin-directory (dirname program)))
 379     (with-directory-excursion bin-directory
 380       (rename-file (string-append name "-exec")
 381                    name)))
 382   #t)
 383
 384 (define* (build-image image outputs #:key
 385                       (dependency-prefixes (list (library-output outputs)))
 386                       (dependencies (list (basename image)))
 387                       #:allow-other-keys)
 388   "Generate an image, possibly standalone, which contains all DEPENDENCIES,
 389 placing the result in IMAGE.image.  Link in any asd files from
 390 DEPENDENCY-PREFIXES to ensure references to those libraries are retained."
 391   (generate-executable image
 392                        #:dependencies dependencies
 393                        #:dependency-prefixes dependency-prefixes
 394                        #:entry-program '(nil)
 395                        #:type 'asdf:image-op)
 396   (let* ((name (basename image))
 397          (bin-directory (dirname image)))
 398     (with-directory-excursion bin-directory
 399       (rename-file (string-append name "-exec--all-systems.image")
 400                    (string-append name ".image"))))
 401   #t)
 402
 403 (define* (generate-executable out-file #:key
 404                               dependencies
 405                               dependency-prefixes
 406                               entry-program
 407                               type
 408                               compress?
 409                               #:allow-other-keys)
 410   "Generate an executable by using asdf operation TYPE, containing whithin the
 411 image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an
 412 executable.  Link in any asd files from DEPENDENCY-PREFIXES to ensure
 413 references to those libraries are retained."
 414   (let* ((bin-directory (dirname out-file))
 415          (name (basename out-file)))
 416     (mkdir-p bin-directory)
 417     (with-directory-excursion bin-directory
 418       (generate-executable-wrapper-system name dependencies)
 419       (generate-executable-entry-point name entry-program))
 420
 421     (prepend-to-source-registry
 422      (string-append bin-directory "/"))
 423
 424     (setenv "ASDF_OUTPUT_TRANSLATIONS"
 425             (replace-escaped-macros
 426              (format
 427               #f "~S"
 428               (wrap-output-translations
 429                `(((,bin-directory :**/ :*.*.*)
 430                   (,bin-directory :**/ :*.*.*)))))))
 431
 432     (generate-executable-for-system type name #:compress? compress?)
 433
 434     (let* ((after-store-prefix-index
 435             (string-index out-file #\/
 436                           (1+ (string-length (%store-directory)))))
 437            (output (string-take out-file after-store-prefix-index))
 438            (hidden-asd-links (string-append output "/.asd-files")))
 439
 440       (mkdir-p hidden-asd-links)
 441       (for-each
 442        (lambda (path)
 443          (for-each
 444           (lambda (asd-file)
 445             (symlink asd-file
 446                      (string-append hidden-asd-links
 447                                     "/" (basename asd-file))))
 448           (find-files (string-append path (%bundle-install-prefix))
 449                       "\\.asd$")))
 450        dependency-prefixes))
 451
 452     (delete-file (string-append bin-directory "/" name "-exec.asd"))
 453     (delete-file (string-append bin-directory "/" name "-exec.lisp"))))