;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2018 Alex Vong ;;; ;;; 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 . (define-module (guix build clojure-utils) #:use-module (guix build utils) #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:use-module (srfi srfi-8) #:use-module (srfi srfi-26) #:export (@* @@* define-with-docs %doc-regex install-doc %source-dirs %test-dirs %compile-dir package-name->jar-names %main-class %omit-source? %aot-include %aot-exclude %tests? %test-include %test-exclude %clojure-regex canonicalize-relative-path find-files* file-sans-extension relative-path->clojure-lib-string find-clojure-libs compiled-from? include-list\exclude-list eval-with-clojure create-jar)) (define-syntax-rule (@* module name) "Like (@ MODULE NAME), but resolves at run time." (module-ref (resolve-interface 'module) 'name)) (define-syntax-rule (@@* module name) "Like (@@ MODULE NAME), but resolves at run time." (module-ref (resolve-module 'module) 'name)) (define-syntax-rule (define-with-docs name docs val) "Create top-level variable named NAME with doc string DOCS and value VAL." (begin (define name val) (set-object-property! name 'documentation docs))) (define-with-docs %doc-regex "Default regex for matching the base name of top-level documentation files." "^(README.*|.*\\.html|.*\\.org|.*\\.md|\\.markdown|\\.txt)$") (define* (install-doc #:key doc-dirs (doc-regex %doc-regex) outputs #:allow-other-keys) "Install the following to the default documentation directory: 1. Top-level files with base name matching DOC-REGEX. 2. All files (recursively) inside DOC-DIRS. DOC-REGEX can be compiled or uncompiled." (let* ((out (assoc-ref outputs "out")) (doc (assoc-ref outputs "doc")) (name-ver (strip-store-file-name out)) (dest-dir (string-append (or doc out) "/share/doc/" name-ver "/")) (doc-regex* (if (string? doc-regex) (make-regexp doc-regex) doc-regex))) (for-each (cut install-file <> dest-dir) (remove (compose file-exists? (cut string-append dest-dir <>)) (scandir "./" (cut regexp-exec doc-regex* <>)))) (for-each (cut copy-recursively <> dest-dir) doc-dirs) #t)) (define-with-docs %source-dirs "A default list of source directories." '("src/")) (define-with-docs %test-dirs "A default list of test directories." '("test/")) (define-with-docs %compile-dir "Default directory for holding class files." "classes/") (define (package-name->jar-names name) "Given NAME, a package name like \"foo-0.9.1b\", return the list of default jar names: (\"foo-0.9.1b.jar\" \"foo.jar\")." (map (cut string-append <> ".jar") (list name (receive (base-name _) (package-name->name+version name) base-name)))) (define-with-docs %main-class "Default name for main class. It should be a symbol or #f." #f) (define-with-docs %omit-source? "Include source in jars by default." #f) (define-with-docs %aot-include "A default list of symbols deciding what to compile. Note that the exclude list has priority over the include list. The special keyword #:all represents all libraries found under the source directories." '(#:all)) (define-with-docs %aot-exclude "A default list of symbols deciding what not to compile. See the doc string of '%aot-include' for more details." '()) (define-with-docs %tests? "Enable tests by default." #t) (define-with-docs %test-include "A default list of symbols deciding what tests to include. Note that the exclude list has priority over the include list. The special keyword #:all represents all tests found under the test directories." '(#:all)) (define-with-docs %test-exclude "A default list of symbols deciding what tests to exclude. See the doc string of '%test-include' for more details." '()) (define-with-docs %clojure-regex "Default regex for matching the base name of clojure source files." "\\.cljc?$") (define-with-docs canonicalize-relative-path "Like 'canonicalize-path', but for relative paths. Canonicalizations requiring the path to exist are omitted." (let ((remove.. (lambda (ls) (fold-right (match-lambda* (((and comp (not "..")) (".." comps ...)) comps) ((comp (comps ...)) (cons comp comps))) '() ls)))) (compose (match-lambda (() ".") (ls (string-join ls "/"))) remove.. (cut remove (cut member <> '("" ".")) <>) (cut string-split <> #\/)))) (define (find-files* base-dir . args) "Similar to 'find-files', but with BASE-DIR stripped and result canonicalized." (map canonicalize-relative-path (with-directory-excursion base-dir (apply find-files "./" args)))) ;;; FIXME: should be moved to (guix build utils) (define (file-sans-extension file) ;TODO: factorize "Return the substring of FILE without its extension, if any." (let ((dot (string-rindex file #\.))) (if dot (substring file 0 dot) file))) (define (relative-path->clojure-lib-string path) "Convert PATH to a clojure library string." (string-map (match-lambda (#\/ #\.) (#\_ #\-) (chr chr)) (file-sans-extension path))) (define* (find-clojure-libs base-dir #:key (clojure-regex %clojure-regex)) "Return the list of clojure libraries found under BASE-DIR. CLOJURE-REGEX can be compiled or uncompiled." (map (compose string->symbol relative-path->clojure-lib-string) (find-files* base-dir clojure-regex))) (define (compiled-from? class lib) "Given class file CLASS and clojure library symbol LIB, decide if CLASS results from compiling LIB." (string-prefix? (symbol->string lib) (relative-path->clojure-lib-string class))) (define* (include-list\exclude-list include-list exclude-list #:key all-list) "Given INCLUDE-LIST and EXCLUDE-LIST, replace all occurrences of #:all by slicing ALL-LIST into them and compute their list difference." (define (replace-#:all ls all-ls) (append-map (match-lambda (#:all all-ls) (x (list x))) ls)) (let ((include-list* (replace-#:all include-list all-list)) (exclude-list* (replace-#:all exclude-list all-list))) (lset-difference equal? include-list* exclude-list*))) (define (eval-with-clojure expr extra-paths) "Evaluate EXPR with clojure. EXPR must be a s-expression writable by guile and readable by clojure. For examples, '(require '[clojure.string]) will not work, because the guile writer converts brackets to parentheses. EXTRA-PATHS is a list of paths which will be appended to $CLASSPATH." (let* ((classpath (getenv "CLASSPATH")) (classpath* (string-join (cons classpath extra-paths) ":"))) (invoke "java" "-classpath" classpath* "clojure.main" "--eval" (object->string expr)))) (define* (create-jar output-jar dir-files-alist #:key (verbose? #t) (compress? #f) (main-class %main-class)) "Given DIR-FILES-ALIST, an alist of the form: ((DIR . FILES) ...) Create jar named OUTPUT-JAR from FILES with DIR stripped." (let ((grouped-options (string-append "c" (if verbose? "v" "") "f" (if compress? "" "0") (if main-class "e" "")))) (apply invoke `("jar" ,grouped-options ,output-jar ,@(if main-class (list (symbol->string main-class)) '()) ,@(append-map (match-lambda ((dir . files) (append-map (lambda (file) `("-C" ,dir ,file)) files))) dir-files-alist)))))