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)
 190   `(asdf:defsystem
 191     ,(normalize-string system)
 192     :class asdf/bundle:prebuilt-system
 193     :version ,version
 194     :depends-on ,dependencies
 195     :components ((:compiled-file ,(compiled-system system)))
 196     ,@(if (string=? "ecl" (%lisp-type))
 197           `(:lib ,(string-append system ".a"))
 198           '())))
 199
 200 (define (test-system system asd-file test-asd-file)
 201   "Use a lisp implementation to test SYSTEM using asdf.  Load ASD-FILE first.
 202 Also load TEST-ASD-FILE if necessary."
 203   (lisp-eval-program
 204    `((require :asdf)
 205      (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system))
 206      ,@(if test-asd-file
 207            `((asdf:load-asd (truename ,test-asd-file)))
 208            ;; Try some likely files.
 209            (map (lambda (file)
 210                   `(when (uiop:file-exists-p ,file)
 211                      (asdf:load-asd (truename ,file))))
 212                 (list
 213                  (string-append system "-tests.asd")
 214                  (string-append system "-test.asd")
 215                  "tests.asd"
 216                  "test.asd")))
 217      (asdf:test-system ,system))))
 218
 219 (define (string->lisp-keyword . strings)
 220   "Return a lisp keyword for the concatenation of STRINGS."
 221   (string->symbol (apply string-append ":" strings)))
 222
 223 (define (generate-executable-for-system type system)
 224   "Use LISP to generate an executable, whose TYPE can be 'asdf:image-op or
 225 'asdf:program-op.  The latter will always be standalone.  Depends on having
 226 created a \"SYSTEM-exec\" system which contains the entry program."
 227   (lisp-eval-program
 228    `((require :asdf)
 229      (asdf:operate ',type ,(string-append system "-exec")))))
 230
 231 (define (generate-executable-wrapper-system system dependencies)
 232   "Generates a system which can be used by asdf to produce an image or program
 233 inside the current directory.  The image or program will contain
 234 DEPENDENCIES."
 235   (with-output-to-file (string-append system "-exec.asd")
 236     (lambda _
 237       (format #t "~y~%"
 238               `(defsystem ,(string->lisp-keyword system "-exec")
 239                  :entry-point ,(string-append system "-exec:main")
 240                  :depends-on (:uiop
 241                               ,@(map string->lisp-keyword
 242                                      dependencies))
 243                  :components ((:file ,(string-append system "-exec"))))))))
 244
 245 (define (generate-executable-entry-point system entry-program)
 246   "Generates an entry point program from the list of lisp statements
 247 ENTRY-PROGRAM for SYSTEM within the current directory."
 248   (with-output-to-file (string-append system "-exec.lisp")
 249     (lambda _
 250       (let ((system (string->lisp-keyword system "-exec")))
 251         (format #t "~{~y~%~%~}"
 252                 `((defpackage ,system
 253                     (:use :cl)
 254                     (:export :main))
 255
 256                   (in-package ,system)
 257
 258                   (defun main ()
 259                     (let ((arguments uiop:*command-line-arguments*))
 260                       (declare (ignorable arguments))
 261                       ,@entry-program))))))))
 262
 263 (define (generate-dependency-links registry system)
 264   "Creates a program which populates asdf's source registry from REGISTRY, an
 265 alist of dependency names to corresponding asd files.  This allows the system
 266 to locate its dependent systems."
 267   `(progn
 268     (asdf/source-registry:ensure-source-registry)
 269     ,@(map (match-lambda
 270              ((name . asd-file)
 271               `(setf
 272                 (gethash ,name
 273                          asdf/source-registry:*source-registry*)
 274                 ,(string->symbol "#p")
 275                 ,asd-file)))
 276            registry)))
 277
 278 (define* (make-asd-file asd-file
 279                         #:key system version inputs
 280                         (system-asd-file #f))
 281   "Create an ASD-FILE for SYSTEM@VERSION, appending a program to allow the
 282 system to find its dependencies, as described by GENERATE-DEPENDENCY-LINKS."
 283   (define dependencies
 284     (let ((deps
 285            (system-dependencies system system-asd-file)))
 286       (if (eq? 'NIL deps)
 287           '()
 288           (map normalize-dependency deps))))
 289
 290   (define lisp-input-map
 291     (inputs->asd-file-map inputs))
 292
 293   (define dependency-name
 294     (match-lambda
 295       ((':version name _ ...) name)
 296       ((':feature _ dependency-specification)
 297        (dependency-name dependency-specification))
 298       ((? string? name) name)
 299       (_ #f)))
 300
 301   (define registry
 302     (filter-map hash-get-handle
 303                 (make-list (length dependencies)
 304                            lisp-input-map)
 305                 (map dependency-name dependencies)))
 306
 307   (call-with-output-file asd-file
 308     (lambda (port)
 309       (display
 310        (replace-escaped-macros
 311         (format #f "~y~%~y~%"
 312                 (generate-system-definition system
 313                                             #:version version
 314                                             #:dependencies dependencies)
 315                 (generate-dependency-links registry system)))
 316        port))))
 317
 318 (define (bundle-asd-file output-path original-asd-file)
 319   "Find the symlinked bundle file for ORIGINAL-ASD-FILE by looking in
 320 OUTPUT-PATH/share/common-lisp/LISP-bundle-systems/<system>.asd.  Returns two
 321 values: the asd file itself and the directory in which it resides."
 322   (let ((bundle-asd-path (string-append output-path
 323                                         (%bundle-install-prefix))))
 324     (values (string-append bundle-asd-path "/" (basename original-asd-file))
 325             bundle-asd-path)))
 326
 327 (define (replace-escaped-macros string)
 328   "Replace simple lisp forms that the guile writer escapes, for example by
 329 replacing #{#p}# with #p.  Should only be used to replace truly simple forms
 330 which are not nested."
 331   (regexp-substitute/global #f "(#\\{)(\\S*)(\\}#)" string
 332                             'pre 2 'post))
 333
 334 (define (prepend-to-source-registry path)
 335   (setenv "CL_SOURCE_REGISTRY"
 336           (string-append path ":" (or (getenv "CL_SOURCE_REGISTRY") ""))))
 337
 338 (define* (build-program program outputs #:key
 339                         (dependency-prefixes (list (library-output outputs)))
 340                         (dependencies (list (basename program)))
 341                         entry-program
 342                         #:allow-other-keys)
 343   "Generate an executable program containing all DEPENDENCIES, and which will
 344 execute ENTRY-PROGRAM.  The result is placed in PROGRAM.  When executed, it
 345 will run ENTRY-PROGRAM, a list of Common Lisp expressions in which `arguments'
 346 has been bound to the command-line arguments which were passed.  Link in any
 347 asd files from DEPENDENCY-PREFIXES to ensure references to those libraries are
 348 retained."
 349   (generate-executable program
 350                        #:dependencies dependencies
 351                        #:dependency-prefixes dependency-prefixes
 352                        #:entry-program entry-program
 353                        #:type 'asdf:program-op)
 354   (let* ((name (basename program))
 355          (bin-directory (dirname program)))
 356     (with-directory-excursion bin-directory
 357       (rename-file (string-append name "-exec")
 358                    name)))
 359   #t)
 360
 361 (define* (build-image image outputs #:key
 362                       (dependency-prefixes (list (library-output outputs)))
 363                       (dependencies (list (basename image)))
 364                       #:allow-other-keys)
 365   "Generate an image, possibly standalone, which contains all DEPENDENCIES,
 366 placing the result in IMAGE.image.  Link in any asd files from
 367 DEPENDENCY-PREFIXES to ensure references to those libraries are retained."
 368   (generate-executable image
 369                        #:dependencies dependencies
 370                        #:dependency-prefixes dependency-prefixes
 371                        #:entry-program '(nil)
 372                        #:type 'asdf:image-op)
 373   (let* ((name (basename image))
 374          (bin-directory (dirname image)))
 375     (with-directory-excursion bin-directory
 376       (rename-file (string-append name "-exec--all-systems.image")
 377                    (string-append name ".image"))))
 378   #t)
 379
 380 (define* (generate-executable out-file #:key
 381                               dependencies
 382                               dependency-prefixes
 383                               entry-program
 384                               type
 385                               #:allow-other-keys)
 386   "Generate an executable by using asdf operation TYPE, containing whithin the
 387 image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an
 388 executable.  Link in any asd files from DEPENDENCY-PREFIXES to ensure
 389 references to those libraries are retained."
 390   (let* ((bin-directory (dirname out-file))
 391          (name (basename out-file)))
 392     (mkdir-p bin-directory)
 393     (with-directory-excursion bin-directory
 394       (generate-executable-wrapper-system name dependencies)
 395       (generate-executable-entry-point name entry-program))
 396
 397     (prepend-to-source-registry
 398      (string-append bin-directory "/"))
 399
 400     (setenv "ASDF_OUTPUT_TRANSLATIONS"
 401             (replace-escaped-macros
 402              (format
 403               #f "~S"
 404               (wrap-output-translations
 405                `(((,bin-directory :**/ :*.*.*)
 406                   (,bin-directory :**/ :*.*.*)))))))
 407
 408     (generate-executable-for-system type name)
 409
 410     (let* ((after-store-prefix-index
 411             (string-index out-file #\/
 412                           (1+ (string-length (%store-directory)))))
 413            (output (string-take out-file after-store-prefix-index))
 414            (hidden-asd-links (string-append output "/.asd-files")))
 415
 416       (mkdir-p hidden-asd-links)
 417       (for-each
 418        (lambda (path)
 419          (for-each
 420           (lambda (asd-file)
 421             (symlink asd-file
 422                      (string-append hidden-asd-links
 423                                     "/" (basename asd-file))))
 424           (find-files (string-append path (%bundle-install-prefix))
 425                       "\\.asd$")))
 426        dependency-prefixes))
 427
 428     (delete-file (string-append bin-directory "/" name "-exec.asd"))
 429     (delete-file (string-append bin-directory "/" name "-exec.lisp"))))