guix/build/clojure-utils.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com>
   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 clojure-utils)
  20   #:use-module (guix build utils)
  21   #:use-module (ice-9 ftw)
  22   #:use-module (ice-9 match)
  23   #:use-module (ice-9 regex)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (srfi srfi-8)
  26   #:use-module (srfi srfi-26)
  27   #:export (@*
  28             @@*
  29             define-with-docs
  30
  31             %doc-regex
  32             install-doc
  33
  34             %source-dirs
  35             %test-dirs
  36             %compile-dir
  37             package-name->jar-names
  38             %main-class
  39             %omit-source?
  40             %aot-include
  41             %aot-exclude
  42             %tests?
  43             %test-include
  44             %test-exclude
  45
  46             %clojure-regex
  47             canonicalize-relative-path
  48             find-files*
  49             file-sans-extension
  50             relative-path->clojure-lib-string
  51             find-clojure-libs
  52             compiled-from?
  53             include-list\exclude-list
  54             eval-with-clojure
  55             create-jar))
  56
  57 (define-syntax-rule (@* module name)
  58   "Like (@ MODULE NAME), but resolves at run time."
  59   (module-ref (resolve-interface 'module) 'name))
  60
  61 (define-syntax-rule (@@* module name)
  62   "Like (@@ MODULE NAME), but resolves at run time."
  63   (module-ref (resolve-module 'module) 'name))
  64
  65 (define-syntax-rule (define-with-docs name docs val)
  66   "Create top-level variable named NAME with doc string DOCS and value VAL."
  67   (begin (define name val)
  68          (set-object-property! name 'documentation docs)))
  69
  70 (define-with-docs %doc-regex
  71   "Default regex for matching the base name of top-level documentation files."
  72   (format #f
  73           "(~a)|(\\.(html|markdown|md|txt)$)"
  74           (@@ (guix build guile-build-system)
  75               %documentation-file-regexp)))
  76
  77 (define* (install-doc #:key
  78                       doc-dirs
  79                       (doc-regex %doc-regex)
  80                       outputs
  81                       #:allow-other-keys)
  82   "Install the following to the default documentation directory:
  83
  84 1. Top-level files with base name matching DOC-REGEX.
  85 2. All files (recursively) inside DOC-DIRS.
  86
  87 DOC-REGEX can be compiled or uncompiled."
  88   (let* ((out (assoc-ref outputs "out"))
  89          (doc (assoc-ref outputs "doc"))
  90          (name-ver (strip-store-file-name out))
  91          (dest-dir (string-append (or doc out) "/share/doc/" name-ver "/"))
  92          (doc-regex* (if (string? doc-regex)
  93                          (make-regexp doc-regex)
  94                          doc-regex)))
  95     (for-each (cut install-file <> dest-dir)
  96               (remove (compose file-exists?
  97                                (cut string-append dest-dir <>))
  98                       (scandir "./" (cut regexp-exec doc-regex* <>))))
  99     (for-each (cut copy-recursively <> dest-dir)
 100               doc-dirs)
 101     #t))
 102
 103 (define-with-docs %source-dirs
 104   "A default list of source directories."
 105   '("src/"))
 106
 107 (define-with-docs %test-dirs
 108   "A default list of test directories."
 109   '("test/"))
 110
 111 (define-with-docs %compile-dir
 112   "Default directory for holding class files."
 113   "classes/")
 114
 115 (define (package-name->jar-names name)
 116   "Given NAME, a package name like \"foo-0.9.1b\",
 117 return the list of default jar names: (\"foo-0.9.1b.jar\" \"foo.jar\")."
 118   (map (cut string-append <> ".jar")
 119        (list name
 120              (receive (base-name _)
 121                  (package-name->name+version name)
 122                base-name))))
 123
 124 (define-with-docs %main-class
 125   "Default name for main class.  It should be a symbol or #f."
 126   #f)
 127
 128 (define-with-docs %omit-source?
 129   "Include source in jars by default."
 130   #f)
 131
 132 (define-with-docs %aot-include
 133   "A default list of symbols deciding what to compile.  Note that the exclude
 134 list has priority over the include list.  The special keyword #:all represents
 135 all libraries found under the source directories."
 136   '(#:all))
 137
 138 (define-with-docs %aot-exclude
 139   "A default list of symbols deciding what not to compile.
 140 See the doc string of '%aot-include' for more details."
 141   '())
 142
 143 (define-with-docs %tests?
 144   "Enable tests by default."
 145   #t)
 146
 147 (define-with-docs %test-include
 148   "A default list of symbols deciding what tests to include.  Note that the
 149 exclude list has priority over the include list.  The special keyword #:all
 150 represents all tests found under the test directories."
 151   '(#:all))
 152
 153 (define-with-docs %test-exclude
 154   "A default list of symbols deciding what tests to exclude.
 155 See the doc string of '%test-include' for more details."
 156   '())
 157
 158 (define-with-docs %clojure-regex
 159   "Default regex for matching the base name of clojure source files."
 160   "\\.cljc?$")
 161
 162 (define-with-docs canonicalize-relative-path
 163   "Like 'canonicalize-path', but for relative paths.
 164 Canonicalizations requiring the path to exist are omitted."
 165   (let ((remove.. (lambda (ls)
 166                     (fold-right (match-lambda*
 167                                   (((and comp (not "..")) (".." comps ...))
 168                                    comps)
 169                                   ((comp (comps ...))
 170                                    (cons comp comps)))
 171                                 '()
 172                                 ls))))
 173     (compose (match-lambda
 174                (() ".")
 175                (ls (string-join ls "/")))
 176              remove..
 177              (cut remove (cut member <> '("" ".")) <>)
 178              (cut string-split <> #\/))))
 179
 180 (define (find-files* base-dir . args)
 181   "Similar to 'find-files', but with BASE-DIR stripped and result
 182 canonicalized."
 183   (map canonicalize-relative-path
 184        (with-directory-excursion base-dir
 185          (apply find-files "./" args))))
 186
 187 ;;; FIXME: should be moved to (guix build utils)
 188 (define-with-docs file-sans-extension
 189   "Strip extension from path, if any."
 190   (@@ (guix build guile-build-system)
 191       file-sans-extension))
 192
 193 (define (relative-path->clojure-lib-string path)
 194   "Convert PATH to a clojure library string."
 195   (string-map (match-lambda
 196                 (#\/ #\.)
 197                 (#\_ #\-)
 198                 (chr chr))
 199               (file-sans-extension path)))
 200
 201 (define* (find-clojure-libs base-dir
 202                             #:key (clojure-regex %clojure-regex))
 203   "Return the list of clojure libraries found under BASE-DIR.
 204
 205 CLOJURE-REGEX can be compiled or uncompiled."
 206   (map (compose string->symbol
 207                 relative-path->clojure-lib-string)
 208        (find-files* base-dir clojure-regex)))
 209
 210 (define (compiled-from? class lib)
 211   "Given class file CLASS and clojure library symbol LIB, decide if CLASS
 212 results from compiling LIB."
 213   (string-prefix? (symbol->string lib)
 214                   (relative-path->clojure-lib-string class)))
 215
 216 (define* (include-list\exclude-list include-list exclude-list
 217                                     #:key all-list)
 218   "Given INCLUDE-LIST and EXCLUDE-LIST, replace all occurrences of #:all by
 219 slicing ALL-LIST into them and compute their list difference."
 220   (define (replace-#:all ls all-ls)
 221     (append-map (match-lambda
 222                   (#:all all-ls)
 223                   (x (list x)))
 224                 ls))
 225   (let ((include-list* (replace-#:all include-list all-list))
 226         (exclude-list* (replace-#:all exclude-list all-list)))
 227     (lset-difference equal? include-list* exclude-list*)))
 228
 229 (define (eval-with-clojure expr extra-paths)
 230   "Evaluate EXPR with clojure.
 231
 232 EXPR must be a s-expression writable by guile and readable by clojure.
 233 For examples, '(require '[clojure.string]) will not work,
 234 because the guile writer converts brackets to parentheses.
 235
 236 EXTRA-PATHS is a list of paths which will be appended to $CLASSPATH."
 237   (let* ((classpath (getenv "CLASSPATH"))
 238          (classpath* (string-join (cons classpath extra-paths) ":")))
 239     (invoke "java"
 240             "-classpath" classpath*
 241             "clojure.main"
 242             "--eval" (object->string expr))))
 243
 244 (define* (create-jar output-jar dir-files-alist
 245                      #:key
 246                      (verbose? #t)
 247                      (compress? #f)
 248                      (main-class %main-class))
 249   "Given DIR-FILES-ALIST, an alist of the form: ((DIR . FILES) ...)
 250 Create jar named OUTPUT-JAR from FILES with DIR stripped."
 251   (let ((grouped-options (string-append "c"
 252                                         (if verbose? "v" "")
 253                                         "f"
 254                                         (if compress? "" "0")
 255                                         (if main-class "e" ""))))
 256     (apply invoke `("jar"
 257                     ,grouped-options
 258                     ,output-jar
 259                     ,@(if main-class (list (symbol->string main-class)) '())
 260                     ,@(append-map (match-lambda
 261                                     ((dir . files)
 262                                      (append-map (lambda (file)
 263                                                    `("-C" ,dir ,file))
 264                                                  files)))
 265                                   dir-files-alist)))))