265 lines
9.4 KiB
Scheme
265 lines
9.4 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
|
;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com>
|
|
;;;
|
|
;;; 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 <http://www.gnu.org/licenses/>.
|
|
|
|
(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)))))
|