[jackhill/guix/guix.git] / guix / build / clojure-utils.scm

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