asdf-build-system.scm 11 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292
  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
  3. ;;; Copyright © 2020, 2021 Guillaume Le Vaillant <glv@posteo.net>
  4. ;;;
  5. ;;; This file is part of GNU Guix.
  6. ;;;
  7. ;;; GNU Guix is free software; you can redistribute it and/or modify it
  8. ;;; under the terms of the GNU General Public License as published by
  9. ;;; the Free Software Foundation; either version 3 of the License, or (at
  10. ;;; your option) any later version.
  11. ;;;
  12. ;;; GNU Guix is distributed in the hope that it will be useful, but
  13. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. ;;; GNU General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
  19. (define-module (guix build asdf-build-system)
  20. #:use-module ((guix build gnu-build-system) #:prefix gnu:)
  21. #:use-module (guix build utils)
  22. #:use-module (guix build union)
  23. #:use-module (guix build lisp-utils)
  24. #:use-module (srfi srfi-1)
  25. #:use-module (srfi srfi-11)
  26. #:use-module (srfi srfi-26)
  27. #:use-module (ice-9 rdelim)
  28. #:use-module (ice-9 receive)
  29. #:use-module (ice-9 regex)
  30. #:use-module (ice-9 match)
  31. #:use-module (ice-9 format)
  32. #:use-module (ice-9 ftw)
  33. #:export (%standard-phases
  34. %standard-phases/source
  35. asdf-build
  36. asdf-build/source))
  37. ;; Commentary:
  38. ;;
  39. ;; System for building ASDF packages; creating executable programs and images
  40. ;; from them.
  41. ;;
  42. ;; Code:
  43. (define %object-prefix "/lib/common-lisp")
  44. (define (%lisp-source-install-prefix)
  45. (string-append %source-install-prefix "/" (%lisp-type)))
  46. (define %system-install-prefix
  47. (string-append %source-install-prefix "/systems"))
  48. (define (main-system-name output)
  49. ;; FIXME: Find a more reliable way to get the main system name.
  50. (let* ((full-name (strip-store-file-name output))
  51. (lisp-prefix (string-append (%lisp-type) "-"))
  52. (package-name (if (string-prefix? lisp-prefix full-name)
  53. (string-drop full-name (string-length lisp-prefix))
  54. full-name)))
  55. (package-name->name+version package-name)))
  56. (define (lisp-source-directory output name)
  57. (string-append output (%lisp-source-install-prefix) "/" name))
  58. (define (source-directory output name)
  59. (string-append output %source-install-prefix "/source/" name))
  60. (define (library-directory output)
  61. (string-append output %object-prefix
  62. "/" (%lisp-type)))
  63. (define (output-translation source-path
  64. object-output)
  65. "Return a translation for the system's source path
  66. to it's binary output."
  67. `((,source-path
  68. :**/ :*.*.*)
  69. (,(library-directory object-output)
  70. :**/ :*.*.*)))
  71. (define (source-asd-file output name asd-file)
  72. (string-append (lisp-source-directory output name) "/" asd-file))
  73. (define (find-asd-files output name asd-files)
  74. (if (null? asd-files)
  75. (find-files (lisp-source-directory output name) "\\.asd$")
  76. (map (lambda (asd-file)
  77. (source-asd-file output name asd-file))
  78. asd-files)))
  79. (define (copy-files-to-output out name)
  80. "Copy all files from the current directory to OUT. Create an extra link to
  81. any system-defining files in the source to a convenient location. This is
  82. done before any compiling so that the compiled source locations will be
  83. valid."
  84. (let ((source (getcwd))
  85. (target (source-directory out name))
  86. (system-path (string-append out %system-install-prefix)))
  87. ;; SBCL keeps the modification time of the source file in the compiled
  88. ;; file, and the source files might just have been patched by a custom
  89. ;; phase. Therefore we reset the modification time of all the source
  90. ;; files before compiling.
  91. (for-each (lambda (file)
  92. (let ((s (lstat file)))
  93. (unless (or (eq? (stat:type s) 'symlink)
  94. (not (access? file W_OK)))
  95. (utime file 0 0 0 0))))
  96. (find-files source #:directories? #t))
  97. (copy-recursively source target #:keep-mtime? #t)
  98. (mkdir-p system-path)
  99. (for-each
  100. (lambda (file)
  101. (symlink file
  102. (string-append system-path "/" (basename file))))
  103. (find-files target "\\.asd$"))
  104. #t))
  105. (define* (install #:key inputs outputs #:allow-other-keys)
  106. "Copy and symlink all the source files.
  107. The source files are taken from the corresponding compile package (e.g. SBCL)
  108. if it's present in the native-inputs."
  109. (define output (assoc-ref outputs "out"))
  110. (define package-name
  111. (package-name->name+version
  112. (strip-store-file-name output)))
  113. (define (no-prefix pkgname)
  114. (let ((index (string-index pkgname #\-)))
  115. (if index
  116. (string-drop pkgname (1+ index))
  117. pkgname)))
  118. (define parent
  119. (match (assoc package-name inputs
  120. (lambda (key alist-car)
  121. (let* ((alt-key (no-prefix key))
  122. (alist-car (no-prefix alist-car)))
  123. (or (string=? alist-car key)
  124. (string=? alist-car alt-key)))))
  125. (#f #f)
  126. (p (cdr p))))
  127. (define parent-name
  128. (and parent
  129. (package-name->name+version (strip-store-file-name parent))))
  130. (define parent-source
  131. (and parent
  132. (string-append parent "/share/common-lisp/"
  133. (let ((index (string-index parent-name #\-)))
  134. (if index
  135. (string-take parent-name index)
  136. parent-name)))))
  137. (define (first-subdirectory directory) ; From gnu-build-system.
  138. "Return the file name of the first sub-directory of DIRECTORY."
  139. (match (scandir directory
  140. (lambda (file)
  141. (and (not (member file '("." "..")))
  142. (file-is-directory? (string-append directory "/"
  143. file)))))
  144. ((first . _) first)))
  145. (define source-directory
  146. (if (and parent-source
  147. (file-exists? parent-source))
  148. (string-append parent-source "/" (first-subdirectory parent-source))
  149. "."))
  150. (with-directory-excursion source-directory
  151. (copy-files-to-output output package-name)))
  152. (define* (copy-source #:key outputs asd-systems #:allow-other-keys)
  153. "Copy the source to the library output."
  154. (let* ((out (library-output outputs))
  155. (install-path (string-append out %source-install-prefix))
  156. (system-name (main-system-name out)))
  157. (copy-files-to-output out system-name)
  158. ;; Hide the files from asdf
  159. (with-directory-excursion install-path
  160. (rename-file "source" (%lisp-type))
  161. (delete-file-recursively "systems")))
  162. #t)
  163. (define* (configure #:key inputs #:allow-other-keys)
  164. ;; Create a directory having the configuration files for
  165. ;; all the dependencies in 'etc/common-lisp/'.
  166. (let ((out (string-append (getcwd) "/.cl-union")))
  167. (match inputs
  168. (((name . directories) ...)
  169. (union-build out (filter directory-exists? directories)
  170. #:create-all-directories? #t
  171. #:log-port (%make-void-port "w"))))
  172. (setenv "CL_UNION" out)
  173. (setenv "XDG_CONFIG_DIRS" (string-append out "/etc")))
  174. #t)
  175. (define* (build #:key outputs inputs asd-files asd-systems
  176. #:allow-other-keys)
  177. "Compile the system."
  178. (let* ((out (library-output outputs))
  179. (system-name (main-system-name out))
  180. (source-path (string-append out (%lisp-source-install-prefix)))
  181. (translations (wrap-output-translations
  182. `(,(output-translation source-path
  183. out))))
  184. (asd-files (find-asd-files out system-name asd-files)))
  185. (setenv "ASDF_OUTPUT_TRANSLATIONS"
  186. (replace-escaped-macros (format #f "~S" translations)))
  187. (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache
  188. (compile-systems asd-systems asd-files))
  189. #t)
  190. (define* (check #:key tests? outputs inputs asd-files asd-systems
  191. test-asd-file
  192. #:allow-other-keys)
  193. "Test the system."
  194. (let* ((out (library-output outputs))
  195. (system-name (main-system-name out))
  196. (asd-files (find-asd-files out system-name asd-files))
  197. (test-asd-file
  198. (and=> test-asd-file
  199. (cut source-asd-file out system-name <>))))
  200. (if tests?
  201. (test-system (first asd-systems) asd-files test-asd-file)
  202. (format #t "test suite not run~%")))
  203. #t)
  204. (define* (create-asdf-configuration #:key inputs outputs #:allow-other-keys)
  205. "Create the ASDF configuration files for the built systems."
  206. (let* ((system-name (main-system-name (assoc-ref outputs "out")))
  207. (out (library-output outputs))
  208. (conf-dir (string-append out "/etc/common-lisp"))
  209. (deps-conf-dir (string-append (getenv "CL_UNION") "/etc/common-lisp"))
  210. (source-dir (lisp-source-directory out system-name))
  211. (lib-dir (string-append (library-directory out) "/" system-name)))
  212. (make-asdf-configuration system-name conf-dir deps-conf-dir
  213. source-dir lib-dir)
  214. #t))
  215. (define* (cleanup-files #:key outputs
  216. #:allow-other-keys)
  217. "Remove any compiled files which are not a part of the final bundle."
  218. (let* ((out (library-output outputs))
  219. (cache-directory (string-append out "/.cache")))
  220. ;; Remove the cache directory in case the lisp implementation wrote
  221. ;; something in there when compiling or testing a system.
  222. (when (directory-exists? cache-directory)
  223. (delete-file-recursively cache-directory)))
  224. #t)
  225. (define* (strip #:rest args)
  226. ;; stripping sbcl binaries removes their entry program and extra systems
  227. (or (string=? (%lisp-type) "sbcl")
  228. (apply (assoc-ref gnu:%standard-phases 'strip) args)))
  229. (define %standard-phases/source
  230. (modify-phases gnu:%standard-phases
  231. (delete 'bootstrap)
  232. (delete 'configure)
  233. (delete 'check)
  234. (delete 'build)
  235. (replace 'install install)))
  236. (define %standard-phases
  237. (modify-phases gnu:%standard-phases
  238. (delete 'bootstrap)
  239. (replace 'configure configure)
  240. (add-before 'configure 'copy-source copy-source)
  241. (replace 'build build)
  242. (replace 'check check)
  243. (add-after 'check 'create-asdf-configuration create-asdf-configuration)
  244. (add-after 'create-asdf-configuration 'cleanup cleanup-files)
  245. (delete 'install)
  246. (replace 'strip strip)))
  247. (define* (asdf-build #:key inputs
  248. (phases %standard-phases)
  249. #:allow-other-keys
  250. #:rest args)
  251. (apply gnu:gnu-build
  252. #:inputs inputs
  253. #:phases phases
  254. args))
  255. (define* (asdf-build/source #:key inputs
  256. (phases %standard-phases/source)
  257. #:allow-other-keys
  258. #:rest args)
  259. (apply gnu:gnu-build
  260. #:inputs inputs
  261. #:phases phases
  262. args))
  263. ;;; asdf-build-system.scm ends here