From e429566fbb6af2b65a144cc06902432bc87b9eae Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 12 Jul 2019 22:38:03 +0200 Subject: build: Use '-Wshadowed-toplevel' only when supported. * guix/build/compile.scm (supported-warning-type?): New procedure. (%warnings): Remove 'unsupported-warning', though removing it doesn't make any difference. Define 'optional', and use it to determine whether to include 'shadowed-toplevel'. --- guix/build/compile.scm | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) (limited to 'guix/build') diff --git a/guix/build/compile.scm b/guix/build/compile.scm index c8fe273f7e..29865f2f2e 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -18,6 +18,7 @@ ;;; along with GNU Guix. If not, see . (define-module (guix build compile) + #:use-module (srfi srfi-1) #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module (ice-9 threads) @@ -58,13 +59,23 @@ ((kw _ rest ...) (loop rest `(#f ,kw ,@result)))))) +(define (supported-warning-type? type) + "Return true if TYPE, a symbol, denotes a supported warning type." + (find (lambda (warning-type) + (eq? type (warning-type-name warning-type))) + %warning-types)) + (define %warnings ;; FIXME: 'format' is missing because it reports "non-literal format ;; strings" due to the fact that we use 'G_' instead of '_'. We'll need ;; help from Guile to solve this. - '(unsupported-warning unbound-variable arity-mismatch - macro-use-before-definition ;new in 2.2 - shadowed-toplevel)) ;new in 2.2.5 + (let ((optional (lambda (type) + (if (supported-warning-type? type) + (list type) + '())))) + `(unbound-variable arity-mismatch + macro-use-before-definition ;new in 2.2 + ,@(optional 'shadowed-toplevel)))) ;new in 2.2.5 (define (optimization-options file) "Return the default set of optimizations options for FILE." -- cgit v1.2.3 From 09a1f92f61d1ab11d2cf9f7a0983f4fc9f436f57 Mon Sep 17 00:00:00 2001 From: Jelle Licht Date: Tue, 23 Aug 2016 05:23:55 +0200 Subject: build: Add node-build-system. * guix/build/node-build-system.scm: New file. * guix/build-system/node.scm: New file. * guix/build/json.scm: New file. * doc/guix.texi: Document it. * Makefile.am: Added new files. Co-Authored-By: Julien Lepiller --- Makefile.am | 3 + doc/guix.texi | 11 ++ guix/build-system/node.scm | 135 ++++++++++++++ guix/build/json.scm | 387 +++++++++++++++++++++++++++++++++++++++ guix/build/node-build-system.scm | 166 +++++++++++++++++ 5 files changed, 702 insertions(+) create mode 100644 guix/build-system/node.scm create mode 100644 guix/build/json.scm create mode 100644 guix/build/node-build-system.scm (limited to 'guix/build') diff --git a/Makefile.am b/Makefile.am index 82eda6042a..9839bf27cc 100644 --- a/Makefile.am +++ b/Makefile.am @@ -125,6 +125,7 @@ MODULES = \ guix/build-system/guile.scm \ guix/build-system/haskell.scm \ guix/build-system/linux-module.scm \ + guix/build-system/node.scm \ guix/build-system/perl.scm \ guix/build-system/python.scm \ guix/build-system/ocaml.scm \ @@ -170,6 +171,7 @@ MODULES = \ guix/build/gnu-build-system.scm \ guix/build/gnu-dist.scm \ guix/build/guile-build-system.scm \ + guix/build/node-build-system.scm \ guix/build/perl-build-system.scm \ guix/build/python-build-system.scm \ guix/build/ocaml-build-system.scm \ @@ -182,6 +184,7 @@ MODULES = \ guix/build/haskell-build-system.scm \ guix/build/linux-module-build-system.scm \ guix/build/store-copy.scm \ + guix/build/json.scm \ guix/build/utils.scm \ guix/build/union.scm \ guix/build/profiles.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 458fca20af..6ed77fe267 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -6346,6 +6346,17 @@ the module (in the "arguments" form of a package using the linux-module-build-system, use the key #:linux to specify it). @end defvr +@defvr {Scheme Variable} node-build-system +This variable is exported by @code{(guix build-system node)}. It +implements the build procedure used by @uref{http://nodejs.org, +Node.js}, which implements an approximation of the @code{npm install} +command, followed by an @code{npm test} command. + +Which Node.js package is used to interpret the @code{npm} commands can +be specified with the @code{#:node} parameter which defaults to +@code{node}. +@end defvr + Lastly, for packages that do not need anything as sophisticated, a ``trivial'' build system is provided. It is trivial in the sense that it provides basically no support: it does not pull any implicit inputs, diff --git a/guix/build-system/node.scm b/guix/build-system/node.scm new file mode 100644 index 0000000000..05c24c47d5 --- /dev/null +++ b/guix/build-system/node.scm @@ -0,0 +1,135 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Jelle Licht +;;; +;;; 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-system node) + #:use-module (guix store) + #:use-module (guix build json) + #:use-module (guix build union) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (ice-9 match) + #:export (npm-meta-uri + %node-build-system-modules + node-build + node-build-system)) + +(define (npm-meta-uri name) + "Return a URI string for the metadata of node module NAME found in the npm +registry." + (string-append "https://registry.npmjs.org/" name)) + +(define %node-build-system-modules + ;; Build-side modules imported by default. + `((guix build node-build-system) + (guix build json) + (guix build union) + ,@%gnu-build-system-modules)) ;; TODO: Might be not needed + +(define (default-node) + "Return the default Node package." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((node (resolve-interface '(gnu packages node)))) + (module-ref node 'node))) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (node (default-node)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:source #:target #:node #:inputs #:native-inputs)) + + (and (not target) ;XXX: no cross-compilation + (bag + (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (build-inputs `(("node" ,node) + ,@native-inputs)) + (outputs outputs) + (build node-build) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (node-build store name inputs + #:key + (npm-flags ''()) + (tests? #t) + (phases '(@ (guix build node-build-system) + %standard-phases)) + (outputs '("out")) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %node-build-system-modules) + (modules '((guix build node-build-system) + (guix build json) + (guix build union) + (guix build utils)))) + "Build SOURCE using NODE and INPUTS." + (define builder + `(begin + (use-modules ,@modules) + (node-build #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:system ,system + #:npm-flags ,npm-flags + #:tests? ,tests? + #:phases ,phases + #:outputs %outputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:inputs inputs + #:system system + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) + +(define node-build-system + (build-system + (name 'node) + (description "The standard Node build system") + (lower lower))) diff --git a/guix/build/json.scm b/guix/build/json.scm new file mode 100644 index 0000000000..361ea76728 --- /dev/null +++ b/guix/build/json.scm @@ -0,0 +1,387 @@ +;;;; json.scm --- JSON reader/writer +;;;; Copyright (C) 2015 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + +(define-module (guix build json) ;; originally (ice-9 json) + #:use-module (ice-9 match) + #:export (read-json write-json)) + +;; Snarfed from +;; https://github.com/cwebber/activitystuff/blob/master/activitystuff/contrib/json.scm +;; + +;;; +;;; Reader +;;; + +(define (json-error port) + (throw 'json-error port)) + +(define (assert-char port char) + "Read a character from PORT and throw an invalid JSON error if the +character is not CHAR." + (unless (eqv? (read-char port) char) + (json-error port))) + +(define (whitespace? char) + "Return #t if CHAR is a whitespace character." + (char-set-contains? char-set:whitespace char)) + +(define (consume-whitespace port) + "Discard characters from PORT until a non-whitespace character is +encountered.." + (match (peek-char port) + ((? eof-object?) *unspecified*) + ((? whitespace?) + (read-char port) + (consume-whitespace port)) + (_ *unspecified*))) + +(define (make-keyword-reader keyword value) + "Parse the keyword symbol KEYWORD as VALUE." + (let ((str (symbol->string keyword))) + (lambda (port) + (let loop ((i 0)) + (cond + ((= i (string-length str)) value) + ((eqv? (string-ref str i) (read-char port)) + (loop (1+ i))) + (else (json-error port))))))) + +(define read-true (make-keyword-reader 'true #t)) +(define read-false (make-keyword-reader 'false #f)) +(define read-null (make-keyword-reader 'null #nil)) + +(define (read-hex-digit port) + "Read a hexadecimal digit from PORT." + (match (read-char port) + (#\0 0) + (#\1 1) + (#\2 2) + (#\3 3) + (#\4 4) + (#\5 5) + (#\6 6) + (#\7 7) + (#\8 8) + (#\9 9) + ((or #\A #\a) 10) + ((or #\B #\b) 11) + ((or #\C #\c) 12) + ((or #\D #\d) 13) + ((or #\E #\e) 14) + ((or #\F #\f) 15) + (_ (json-error port)))) + +(define (read-utf16-character port) + "Read a hexadecimal encoded UTF-16 character from PORT." + (integer->char + (+ (* (read-hex-digit port) (expt 16 3)) + (* (read-hex-digit port) (expt 16 2)) + (* (read-hex-digit port) 16) + (read-hex-digit port)))) + +(define (read-escape-character port) + "Read escape character from PORT." + (match (read-char port) + (#\" #\") + (#\\ #\\) + (#\/ #\/) + (#\b #\backspace) + (#\f #\page) + (#\n #\newline) + (#\r #\return) + (#\t #\tab) + (#\u (read-utf16-character port)) + (_ (json-error port)))) + +(define (read-string port) + "Read a JSON encoded string from PORT." + (assert-char port #\") + (let loop ((result '())) + (match (read-char port) + ((? eof-object?) (json-error port)) + (#\" (list->string (reverse result))) + (#\\ (loop (cons (read-escape-character port) result))) + (char (loop (cons char result)))))) + +(define char-set:json-digit + (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) + +(define (digit? char) + (char-set-contains? char-set:json-digit char)) + +(define (read-digit port) + "Read a digit 0-9 from PORT." + (match (read-char port) + (#\0 0) + (#\1 1) + (#\2 2) + (#\3 3) + (#\4 4) + (#\5 5) + (#\6 6) + (#\7 7) + (#\8 8) + (#\9 9) + (else (json-error port)))) + +(define (read-digits port) + "Read a sequence of digits from PORT." + (let loop ((result '())) + (match (peek-char port) + ((? eof-object?) + (reverse result)) + ((? digit?) + (loop (cons (read-digit port) result))) + (else (reverse result))))) + +(define (list->integer digits) + "Convert the list DIGITS to an integer." + (let loop ((i (1- (length digits))) + (result 0) + (digits digits)) + (match digits + (() result) + ((n . tail) + (loop (1- i) + (+ result (* n (expt 10 i))) + tail))))) + +(define (read-positive-integer port) + "Read a positive integer with no leading zeroes from PORT." + (match (read-digits port) + ((0 . _) + (json-error port)) ; no leading zeroes allowed + ((digits ...) + (list->integer digits)))) + +(define (read-exponent port) + "Read exponent from PORT." + (define (read-expt) + (list->integer (read-digits port))) + + (unless (memv (read-char port) '(#\e #\E)) + (json-error port)) + + (match (peek-char port) + ((? eof-object?) + (json-error port)) + (#\- + (read-char port) + (- (read-expt))) + (#\+ + (read-char port) + (read-expt)) + ((? digit?) + (read-expt)) + (_ (json-error port)))) + +(define (read-fraction port) + "Read fractional number part from PORT as an inexact number." + (let* ((digits (read-digits port)) + (numerator (list->integer digits)) + (denomenator (expt 10 (length digits)))) + (/ numerator denomenator))) + +(define (read-positive-number port) + "Read a positive number from PORT." + (let* ((integer (match (peek-char port) + ((? eof-object?) + (json-error port)) + (#\0 + (read-char port) + 0) + ((? digit?) + (read-positive-integer port)) + (_ (json-error port)))) + (fraction (match (peek-char port) + (#\. + (read-char port) + (read-fraction port)) + (_ 0))) + (exponent (match (peek-char port) + ((or #\e #\E) + (read-exponent port)) + (_ 0))) + (n (* (+ integer fraction) (expt 10 exponent)))) + + ;; Keep integers as exact numbers, but convert numbers encoded as + ;; floating point numbers to an inexact representation. + (if (zero? fraction) + n + (exact->inexact n)))) + +(define (read-number port) + "Read a number from PORT" + (match (peek-char port) + ((? eof-object?) + (json-error port)) + (#\- + (read-char port) + (- (read-positive-number port))) + ((? digit?) + (read-positive-number port)) + (_ (json-error port)))) + +(define (read-object port) + "Read key/value map from PORT." + (define (read-key+value-pair) + (let ((key (read-string port))) + (consume-whitespace port) + (assert-char port #\:) + (consume-whitespace port) + (let ((value (read-value port))) + (cons key value)))) + + (assert-char port #\{) + (consume-whitespace port) + + (if (eqv? #\} (peek-char port)) + (begin + (read-char port) + '(@)) ; empty object + (let loop ((result (list (read-key+value-pair)))) + (consume-whitespace port) + (match (peek-char port) + (#\, ; read another value + (read-char port) + (consume-whitespace port) + (loop (cons (read-key+value-pair) result))) + (#\} ; end of object + (read-char port) + (cons '@ (reverse result))) + (_ (json-error port)))))) + +(define (read-array port) + "Read array from PORT." + (assert-char port #\[) + (consume-whitespace port) + + (if (eqv? #\] (peek-char port)) + (begin + (read-char port) + '()) ; empty array + (let loop ((result (list (read-value port)))) + (consume-whitespace port) + (match (peek-char port) + (#\, ; read another value + (read-char port) + (consume-whitespace port) + (loop (cons (read-value port) result))) + (#\] ; end of array + (read-char port) + (reverse result)) + (_ (json-error port)))))) + +(define (read-value port) + "Read a JSON value from PORT." + (consume-whitespace port) + (match (peek-char port) + ((? eof-object?) (json-error port)) + (#\" (read-string port)) + (#\{ (read-object port)) + (#\[ (read-array port)) + (#\t (read-true port)) + (#\f (read-false port)) + (#\n (read-null port)) + ((or #\- (? digit?)) + (read-number port)) + (_ (json-error port)))) + +(define (read-json port) + "Read JSON text from port and return an s-expression representation." + (let ((result (read-value port))) + (consume-whitespace port) + (unless (eof-object? (peek-char port)) + (json-error port)) + result)) + + +;;; +;;; Writer +;;; + +(define (write-string str port) + "Write STR to PORT in JSON string format." + (define (escape-char char) + (display (match char + (#\" "\\\"") + (#\\ "\\\\") + (#\/ "\\/") + (#\backspace "\\b") + (#\page "\\f") + (#\newline "\\n") + (#\return "\\r") + (#\tab "\\t") + (_ char)) + port)) + + (display "\"" port) + (string-for-each escape-char str) + (display "\"" port)) + +(define (write-object alist port) + "Write ALIST to PORT in JSON object format." + ;; Keys may be strings or symbols. + (define key->string + (match-lambda + ((? string? key) key) + ((? symbol? key) (symbol->string key)))) + + (define (write-pair pair) + (match pair + ((key . value) + (write-string (key->string key) port) + (display ":" port) + (write-json value port)))) + + (display "{" port) + (match alist + (() #f) + ((front ... end) + (for-each (lambda (pair) + (write-pair pair) + (display "," port)) + front) + (write-pair end))) + (display "}" port)) + +(define (write-array lst port) + "Write LST to PORT in JSON array format." + (display "[" port) + (match lst + (() #f) + ((front ... end) + (for-each (lambda (val) + (write-json val port) + (display "," port)) + front) + (write-json end port))) + (display "]" port)) + +(define (write-json exp port) + "Write EXP to PORT in JSON format." + (match exp + (#t (display "true" port)) + (#f (display "false" port)) + ;; Differentiate #nil from '(). + ((and (? boolean? ) #nil) (display "null" port)) + ((? string? s) (write-string s port)) + ((? real? n) (display n port)) + (('@ . alist) (write-object alist port)) + ((vals ...) (write-array vals port)))) diff --git a/guix/build/node-build-system.scm b/guix/build/node-build-system.scm new file mode 100644 index 0000000000..3c0ac2a12b --- /dev/null +++ b/guix/build/node-build-system.scm @@ -0,0 +1,166 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2015 David Thompson +;;; Copyright © 2016 Jelle Licht +;;; +;;; 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 node-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build json) + #:use-module (guix build union) + #:use-module (guix build utils) + #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + node-build)) + +;; Commentary: +;; +;; Builder-side code of the standard Node/npm package build procedure. +;; +;; Code: + +(define* (read-package-data #:key (filename "package.json")) + (call-with-input-file filename + (lambda (port) + (read-json port)))) + +(define* (build #:key inputs #:allow-other-keys) + (define (build-from-package-json? package-file) + (let* ((package-data (read-package-data #:filename package-file)) + (scripts (assoc-ref package-data "scripts"))) + (assoc-ref scripts "build"))) + "Build a new node module using the appropriate build system." + ;; XXX: Develop a more robust heuristic, allow override + (cond ((file-exists? "gulpfile.js") + (invoke "gulp")) + ((file-exists? "gruntfile.js") + (invoke "grunt")) + ((file-exists? "Makefile") + (invoke "make")) + ((and (file-exists? "package.json") + (build-from-package-json? "package.json")) + (invoke "npm" "run" "build"))) + #t) + +(define* (link-npm-dependencies #:key inputs #:allow-other-keys) + (define (inputs->node-inputs inputs) + "Filter the directory part from INPUTS." + (filter (lambda (input) + (match input + ((name . _) (node-package? name)))) + inputs)) + (define (inputs->directories inputs) + "Extract the directory part from INPUTS." + (match inputs + (((names . directories) ...) + directories))) + (define (make-node-path root) + (string-append root "/lib/node_modules/")) + + (let ((input-node-directories (inputs->directories + (inputs->node-inputs inputs)))) + (union-build "node_modules" + (map make-node-path input-node-directories)) + #t)) + +(define configure link-npm-dependencies) + +(define* (check #:key tests? #:allow-other-keys) + "Run 'npm test' if TESTS?" + (if tests? + ;; Should only be enabled once we know that there are tests + (invoke "npm" "test")) + #t) + +(define (node-package? name) + "Check if NAME correspond to the name of an Node package." + (string-prefix? "node-" name)) + +(define* (install #:key outputs inputs #:allow-other-keys) + "Install the node module to the output store item. The module itself is +installed in a subdirectory of @file{node_modules} and its runtime dependencies +as defined by @file{package.json} are symlinked into a @file{node_modules} +subdirectory of the module's directory. Additionally, binaries are installed in +the @file{bin} directory." + (let* ((out (assoc-ref outputs "out")) + (target (string-append out "/lib")) + (binaries (string-append out "/bin")) + (data (read-package-data)) + (modulename (assoc-ref data "name")) + (binary-configuration (match (assoc-ref data "bin") + (('@ configuration ...) configuration) + ((? string? configuration) configuration) + (#f #f))) + (dependencies (match (assoc-ref data "dependencies") + (('@ deps ...) deps) + (#f #f)))) + (mkdir-p target) + (copy-recursively "." (string-append target "/node_modules/" modulename)) + ;; Remove references to dependencies + (delete-file-recursively + (string-append target "/node_modules/" modulename "/node_modules")) + (cond + ((string? binary-configuration) + (begin + (mkdir-p binaries) + (symlink (string-append target "/node_modules/" modulename "/" + binary-configuration) + (string-append binaries "/" modulename)))) + ((list? binary-configuration) + (for-each + (lambda (conf) + (match conf + ((key . value) + (begin + (mkdir-p (dirname (string-append binaries "/" key))) + (symlink (string-append target "/node_modules/" modulename "/" + value) + (string-append binaries "/" key)))))) + binary-configuration)) + (else + (symlink (string-append target "/node_modules/" modulename "/bin") + binaries))) + (when dependencies + (mkdir-p + (string-append target "/node_modules/" modulename "/node_modules")) + (for-each + (lambda (dependency) + (let ((dependency (car dependency))) + (symlink + (string-append (assoc-ref inputs (string-append "node-" dependency)) + "/lib/node_modules/" dependency) + (string-append target "/node_modules/" modulename + "/node_modules/" dependency)))) + dependencies)) + #t)) + + +(define %standard-phases + (modify-phases gnu:%standard-phases + (replace 'configure configure) + (replace 'build build) + (replace 'install install) + (delete 'check) + (add-after 'install 'check check) + (delete 'strip))) + +(define* (node-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) -- cgit v1.2.3 From 8eb0ba532ebbebef23180e666e0607ea735f9c1a Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Sun, 14 Jul 2019 14:50:21 +0200 Subject: guix: node-build-system: Use guile-json instead of a custom parser. * guix/build/json.scm: Remove file. * Makefile.am: Remove it. * guix/build/node-build-system.scm: Use (json parser) instead of (guix build json). * guix/build-system/node.scm: Idem. --- Makefile.am | 1 - guix/build-system/node.scm | 10 +- guix/build/json.scm | 387 --------------------------------------- guix/build/node-build-system.scm | 28 +-- 4 files changed, 20 insertions(+), 406 deletions(-) delete mode 100644 guix/build/json.scm (limited to 'guix/build') diff --git a/Makefile.am b/Makefile.am index 9839bf27cc..38f2d7e690 100644 --- a/Makefile.am +++ b/Makefile.am @@ -184,7 +184,6 @@ MODULES = \ guix/build/haskell-build-system.scm \ guix/build/linux-module-build-system.scm \ guix/build/store-copy.scm \ - guix/build/json.scm \ guix/build/utils.scm \ guix/build/union.scm \ guix/build/profiles.scm \ diff --git a/guix/build-system/node.scm b/guix/build-system/node.scm index 05c24c47d5..dad492dc95 100644 --- a/guix/build-system/node.scm +++ b/guix/build-system/node.scm @@ -18,7 +18,6 @@ (define-module (guix build-system node) #:use-module (guix store) - #:use-module (guix build json) #:use-module (guix build union) #:use-module (guix utils) #:use-module (guix packages) @@ -27,6 +26,7 @@ #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (ice-9 match) + #:use-module (json parser) #:export (npm-meta-uri %node-build-system-modules node-build @@ -40,8 +40,8 @@ registry." (define %node-build-system-modules ;; Build-side modules imported by default. `((guix build node-build-system) - (guix build json) (guix build union) + (json parser) ,@%gnu-build-system-modules)) ;; TODO: Might be not needed (define (default-node) @@ -88,9 +88,9 @@ registry." (guile #f) (imported-modules %node-build-system-modules) (modules '((guix build node-build-system) - (guix build json) - (guix build union) - (guix build utils)))) + (guix build union) + (guix build utils) + (json parser)))) "Build SOURCE using NODE and INPUTS." (define builder `(begin diff --git a/guix/build/json.scm b/guix/build/json.scm deleted file mode 100644 index 361ea76728..0000000000 --- a/guix/build/json.scm +++ /dev/null @@ -1,387 +0,0 @@ -;;;; json.scm --- JSON reader/writer -;;;; Copyright (C) 2015 Free Software Foundation, Inc. -;;;; -;;;; This library is free software; you can redistribute it and/or -;;;; modify it under the terms of the GNU Lesser General Public -;;;; License as published by the Free Software Foundation; either -;;;; version 3 of the License, or (at your option) any later version. -;;;; -;;;; This library 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 -;;;; Lesser General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU Lesser General Public -;;;; License along with this library; if not, write to the Free Software -;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA -;;;; - -(define-module (guix build json) ;; originally (ice-9 json) - #:use-module (ice-9 match) - #:export (read-json write-json)) - -;; Snarfed from -;; https://github.com/cwebber/activitystuff/blob/master/activitystuff/contrib/json.scm -;; - -;;; -;;; Reader -;;; - -(define (json-error port) - (throw 'json-error port)) - -(define (assert-char port char) - "Read a character from PORT and throw an invalid JSON error if the -character is not CHAR." - (unless (eqv? (read-char port) char) - (json-error port))) - -(define (whitespace? char) - "Return #t if CHAR is a whitespace character." - (char-set-contains? char-set:whitespace char)) - -(define (consume-whitespace port) - "Discard characters from PORT until a non-whitespace character is -encountered.." - (match (peek-char port) - ((? eof-object?) *unspecified*) - ((? whitespace?) - (read-char port) - (consume-whitespace port)) - (_ *unspecified*))) - -(define (make-keyword-reader keyword value) - "Parse the keyword symbol KEYWORD as VALUE." - (let ((str (symbol->string keyword))) - (lambda (port) - (let loop ((i 0)) - (cond - ((= i (string-length str)) value) - ((eqv? (string-ref str i) (read-char port)) - (loop (1+ i))) - (else (json-error port))))))) - -(define read-true (make-keyword-reader 'true #t)) -(define read-false (make-keyword-reader 'false #f)) -(define read-null (make-keyword-reader 'null #nil)) - -(define (read-hex-digit port) - "Read a hexadecimal digit from PORT." - (match (read-char port) - (#\0 0) - (#\1 1) - (#\2 2) - (#\3 3) - (#\4 4) - (#\5 5) - (#\6 6) - (#\7 7) - (#\8 8) - (#\9 9) - ((or #\A #\a) 10) - ((or #\B #\b) 11) - ((or #\C #\c) 12) - ((or #\D #\d) 13) - ((or #\E #\e) 14) - ((or #\F #\f) 15) - (_ (json-error port)))) - -(define (read-utf16-character port) - "Read a hexadecimal encoded UTF-16 character from PORT." - (integer->char - (+ (* (read-hex-digit port) (expt 16 3)) - (* (read-hex-digit port) (expt 16 2)) - (* (read-hex-digit port) 16) - (read-hex-digit port)))) - -(define (read-escape-character port) - "Read escape character from PORT." - (match (read-char port) - (#\" #\") - (#\\ #\\) - (#\/ #\/) - (#\b #\backspace) - (#\f #\page) - (#\n #\newline) - (#\r #\return) - (#\t #\tab) - (#\u (read-utf16-character port)) - (_ (json-error port)))) - -(define (read-string port) - "Read a JSON encoded string from PORT." - (assert-char port #\") - (let loop ((result '())) - (match (read-char port) - ((? eof-object?) (json-error port)) - (#\" (list->string (reverse result))) - (#\\ (loop (cons (read-escape-character port) result))) - (char (loop (cons char result)))))) - -(define char-set:json-digit - (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) - -(define (digit? char) - (char-set-contains? char-set:json-digit char)) - -(define (read-digit port) - "Read a digit 0-9 from PORT." - (match (read-char port) - (#\0 0) - (#\1 1) - (#\2 2) - (#\3 3) - (#\4 4) - (#\5 5) - (#\6 6) - (#\7 7) - (#\8 8) - (#\9 9) - (else (json-error port)))) - -(define (read-digits port) - "Read a sequence of digits from PORT." - (let loop ((result '())) - (match (peek-char port) - ((? eof-object?) - (reverse result)) - ((? digit?) - (loop (cons (read-digit port) result))) - (else (reverse result))))) - -(define (list->integer digits) - "Convert the list DIGITS to an integer." - (let loop ((i (1- (length digits))) - (result 0) - (digits digits)) - (match digits - (() result) - ((n . tail) - (loop (1- i) - (+ result (* n (expt 10 i))) - tail))))) - -(define (read-positive-integer port) - "Read a positive integer with no leading zeroes from PORT." - (match (read-digits port) - ((0 . _) - (json-error port)) ; no leading zeroes allowed - ((digits ...) - (list->integer digits)))) - -(define (read-exponent port) - "Read exponent from PORT." - (define (read-expt) - (list->integer (read-digits port))) - - (unless (memv (read-char port) '(#\e #\E)) - (json-error port)) - - (match (peek-char port) - ((? eof-object?) - (json-error port)) - (#\- - (read-char port) - (- (read-expt))) - (#\+ - (read-char port) - (read-expt)) - ((? digit?) - (read-expt)) - (_ (json-error port)))) - -(define (read-fraction port) - "Read fractional number part from PORT as an inexact number." - (let* ((digits (read-digits port)) - (numerator (list->integer digits)) - (denomenator (expt 10 (length digits)))) - (/ numerator denomenator))) - -(define (read-positive-number port) - "Read a positive number from PORT." - (let* ((integer (match (peek-char port) - ((? eof-object?) - (json-error port)) - (#\0 - (read-char port) - 0) - ((? digit?) - (read-positive-integer port)) - (_ (json-error port)))) - (fraction (match (peek-char port) - (#\. - (read-char port) - (read-fraction port)) - (_ 0))) - (exponent (match (peek-char port) - ((or #\e #\E) - (read-exponent port)) - (_ 0))) - (n (* (+ integer fraction) (expt 10 exponent)))) - - ;; Keep integers as exact numbers, but convert numbers encoded as - ;; floating point numbers to an inexact representation. - (if (zero? fraction) - n - (exact->inexact n)))) - -(define (read-number port) - "Read a number from PORT" - (match (peek-char port) - ((? eof-object?) - (json-error port)) - (#\- - (read-char port) - (- (read-positive-number port))) - ((? digit?) - (read-positive-number port)) - (_ (json-error port)))) - -(define (read-object port) - "Read key/value map from PORT." - (define (read-key+value-pair) - (let ((key (read-string port))) - (consume-whitespace port) - (assert-char port #\:) - (consume-whitespace port) - (let ((value (read-value port))) - (cons key value)))) - - (assert-char port #\{) - (consume-whitespace port) - - (if (eqv? #\} (peek-char port)) - (begin - (read-char port) - '(@)) ; empty object - (let loop ((result (list (read-key+value-pair)))) - (consume-whitespace port) - (match (peek-char port) - (#\, ; read another value - (read-char port) - (consume-whitespace port) - (loop (cons (read-key+value-pair) result))) - (#\} ; end of object - (read-char port) - (cons '@ (reverse result))) - (_ (json-error port)))))) - -(define (read-array port) - "Read array from PORT." - (assert-char port #\[) - (consume-whitespace port) - - (if (eqv? #\] (peek-char port)) - (begin - (read-char port) - '()) ; empty array - (let loop ((result (list (read-value port)))) - (consume-whitespace port) - (match (peek-char port) - (#\, ; read another value - (read-char port) - (consume-whitespace port) - (loop (cons (read-value port) result))) - (#\] ; end of array - (read-char port) - (reverse result)) - (_ (json-error port)))))) - -(define (read-value port) - "Read a JSON value from PORT." - (consume-whitespace port) - (match (peek-char port) - ((? eof-object?) (json-error port)) - (#\" (read-string port)) - (#\{ (read-object port)) - (#\[ (read-array port)) - (#\t (read-true port)) - (#\f (read-false port)) - (#\n (read-null port)) - ((or #\- (? digit?)) - (read-number port)) - (_ (json-error port)))) - -(define (read-json port) - "Read JSON text from port and return an s-expression representation." - (let ((result (read-value port))) - (consume-whitespace port) - (unless (eof-object? (peek-char port)) - (json-error port)) - result)) - - -;;; -;;; Writer -;;; - -(define (write-string str port) - "Write STR to PORT in JSON string format." - (define (escape-char char) - (display (match char - (#\" "\\\"") - (#\\ "\\\\") - (#\/ "\\/") - (#\backspace "\\b") - (#\page "\\f") - (#\newline "\\n") - (#\return "\\r") - (#\tab "\\t") - (_ char)) - port)) - - (display "\"" port) - (string-for-each escape-char str) - (display "\"" port)) - -(define (write-object alist port) - "Write ALIST to PORT in JSON object format." - ;; Keys may be strings or symbols. - (define key->string - (match-lambda - ((? string? key) key) - ((? symbol? key) (symbol->string key)))) - - (define (write-pair pair) - (match pair - ((key . value) - (write-string (key->string key) port) - (display ":" port) - (write-json value port)))) - - (display "{" port) - (match alist - (() #f) - ((front ... end) - (for-each (lambda (pair) - (write-pair pair) - (display "," port)) - front) - (write-pair end))) - (display "}" port)) - -(define (write-array lst port) - "Write LST to PORT in JSON array format." - (display "[" port) - (match lst - (() #f) - ((front ... end) - (for-each (lambda (val) - (write-json val port) - (display "," port)) - front) - (write-json end port))) - (display "]" port)) - -(define (write-json exp port) - "Write EXP to PORT in JSON format." - (match exp - (#t (display "true" port)) - (#f (display "false" port)) - ;; Differentiate #nil from '(). - ((and (? boolean? ) #nil) (display "null" port)) - ((? string? s) (write-string s port)) - ((? real? n) (display n port)) - (('@ . alist) (write-object alist port)) - ((vals ...) (write-array vals port)))) diff --git a/guix/build/node-build-system.scm b/guix/build/node-build-system.scm index 3c0ac2a12b..231e60488a 100644 --- a/guix/build/node-build-system.scm +++ b/guix/build/node-build-system.scm @@ -19,12 +19,12 @@ (define-module (guix build node-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) - #:use-module (guix build json) #:use-module (guix build union) #:use-module (guix build utils) #:use-module (ice-9 match) #:use-module (ice-9 popen) #:use-module (ice-9 regex) + #:use-module (json parser) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases @@ -39,12 +39,12 @@ (define* (read-package-data #:key (filename "package.json")) (call-with-input-file filename (lambda (port) - (read-json port)))) + (json->scm port)))) (define* (build #:key inputs #:allow-other-keys) (define (build-from-package-json? package-file) (let* ((package-data (read-package-data #:filename package-file)) - (scripts (assoc-ref package-data "scripts"))) + (scripts (hash-ref package-data "scripts"))) (assoc-ref scripts "build"))) "Build a new node module using the appropriate build system." ;; XXX: Develop a more robust heuristic, allow override @@ -103,13 +103,15 @@ the @file{bin} directory." (target (string-append out "/lib")) (binaries (string-append out "/bin")) (data (read-package-data)) - (modulename (assoc-ref data "name")) - (binary-configuration (match (assoc-ref data "bin") - (('@ configuration ...) configuration) - ((? string? configuration) configuration) - (#f #f))) - (dependencies (match (assoc-ref data "dependencies") - (('@ deps ...) deps) + (modulename (hash-ref data "name")) + (binary-configuration (match (hash-ref data "bin") + ((? hash-table? hash-table) + (hash-map->list cons hash-table)) + ((? string? configuration) configuration) + (#f #f))) + (dependencies (match (hash-ref data "dependencies") + ((? hash-table? hash-table) + (hash-map->list cons hash-table)) (#f #f)))) (mkdir-p target) (copy-recursively "." (string-append target "/node_modules/" modulename)) @@ -121,7 +123,7 @@ the @file{bin} directory." (begin (mkdir-p binaries) (symlink (string-append target "/node_modules/" modulename "/" - binary-configuration) + binary-configuration) (string-append binaries "/" modulename)))) ((list? binary-configuration) (for-each @@ -131,12 +133,12 @@ the @file{bin} directory." (begin (mkdir-p (dirname (string-append binaries "/" key))) (symlink (string-append target "/node_modules/" modulename "/" - value) + value) (string-append binaries "/" key)))))) binary-configuration)) (else (symlink (string-append target "/node_modules/" modulename "/bin") - binaries))) + binaries))) (when dependencies (mkdir-p (string-append target "/node_modules/" modulename "/node_modules")) -- cgit v1.2.3 From a4bb18921099b2ec8c1699e08a73ca0fa78d0486 Mon Sep 17 00:00:00 2001 From: Julien Lepiller Date: Sun, 14 Jul 2019 20:16:19 +0200 Subject: Revert "guix: node-build-system: Use guile-json instead of a custom parser." MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The effect of this change was to import the (json parser) from the host side into the build side. The solution here would be to do the equivalent of ‘with-extensions’ for gexps. Since we don't use gexps for build systems just yet, revert this for now. This reverts commit 8eb0ba532ebbebef23180e666e0607ea735f9c1a. --- Makefile.am | 1 + guix/build-system/node.scm | 10 +- guix/build/json.scm | 387 +++++++++++++++++++++++++++++++++++++++ guix/build/node-build-system.scm | 28 ++- 4 files changed, 406 insertions(+), 20 deletions(-) create mode 100644 guix/build/json.scm (limited to 'guix/build') diff --git a/Makefile.am b/Makefile.am index 38f2d7e690..9839bf27cc 100644 --- a/Makefile.am +++ b/Makefile.am @@ -184,6 +184,7 @@ MODULES = \ guix/build/haskell-build-system.scm \ guix/build/linux-module-build-system.scm \ guix/build/store-copy.scm \ + guix/build/json.scm \ guix/build/utils.scm \ guix/build/union.scm \ guix/build/profiles.scm \ diff --git a/guix/build-system/node.scm b/guix/build-system/node.scm index dad492dc95..05c24c47d5 100644 --- a/guix/build-system/node.scm +++ b/guix/build-system/node.scm @@ -18,6 +18,7 @@ (define-module (guix build-system node) #:use-module (guix store) + #:use-module (guix build json) #:use-module (guix build union) #:use-module (guix utils) #:use-module (guix packages) @@ -26,7 +27,6 @@ #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (ice-9 match) - #:use-module (json parser) #:export (npm-meta-uri %node-build-system-modules node-build @@ -40,8 +40,8 @@ registry." (define %node-build-system-modules ;; Build-side modules imported by default. `((guix build node-build-system) + (guix build json) (guix build union) - (json parser) ,@%gnu-build-system-modules)) ;; TODO: Might be not needed (define (default-node) @@ -88,9 +88,9 @@ registry." (guile #f) (imported-modules %node-build-system-modules) (modules '((guix build node-build-system) - (guix build union) - (guix build utils) - (json parser)))) + (guix build json) + (guix build union) + (guix build utils)))) "Build SOURCE using NODE and INPUTS." (define builder `(begin diff --git a/guix/build/json.scm b/guix/build/json.scm new file mode 100644 index 0000000000..361ea76728 --- /dev/null +++ b/guix/build/json.scm @@ -0,0 +1,387 @@ +;;;; json.scm --- JSON reader/writer +;;;; Copyright (C) 2015 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library 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 +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;;; + +(define-module (guix build json) ;; originally (ice-9 json) + #:use-module (ice-9 match) + #:export (read-json write-json)) + +;; Snarfed from +;; https://github.com/cwebber/activitystuff/blob/master/activitystuff/contrib/json.scm +;; + +;;; +;;; Reader +;;; + +(define (json-error port) + (throw 'json-error port)) + +(define (assert-char port char) + "Read a character from PORT and throw an invalid JSON error if the +character is not CHAR." + (unless (eqv? (read-char port) char) + (json-error port))) + +(define (whitespace? char) + "Return #t if CHAR is a whitespace character." + (char-set-contains? char-set:whitespace char)) + +(define (consume-whitespace port) + "Discard characters from PORT until a non-whitespace character is +encountered.." + (match (peek-char port) + ((? eof-object?) *unspecified*) + ((? whitespace?) + (read-char port) + (consume-whitespace port)) + (_ *unspecified*))) + +(define (make-keyword-reader keyword value) + "Parse the keyword symbol KEYWORD as VALUE." + (let ((str (symbol->string keyword))) + (lambda (port) + (let loop ((i 0)) + (cond + ((= i (string-length str)) value) + ((eqv? (string-ref str i) (read-char port)) + (loop (1+ i))) + (else (json-error port))))))) + +(define read-true (make-keyword-reader 'true #t)) +(define read-false (make-keyword-reader 'false #f)) +(define read-null (make-keyword-reader 'null #nil)) + +(define (read-hex-digit port) + "Read a hexadecimal digit from PORT." + (match (read-char port) + (#\0 0) + (#\1 1) + (#\2 2) + (#\3 3) + (#\4 4) + (#\5 5) + (#\6 6) + (#\7 7) + (#\8 8) + (#\9 9) + ((or #\A #\a) 10) + ((or #\B #\b) 11) + ((or #\C #\c) 12) + ((or #\D #\d) 13) + ((or #\E #\e) 14) + ((or #\F #\f) 15) + (_ (json-error port)))) + +(define (read-utf16-character port) + "Read a hexadecimal encoded UTF-16 character from PORT." + (integer->char + (+ (* (read-hex-digit port) (expt 16 3)) + (* (read-hex-digit port) (expt 16 2)) + (* (read-hex-digit port) 16) + (read-hex-digit port)))) + +(define (read-escape-character port) + "Read escape character from PORT." + (match (read-char port) + (#\" #\") + (#\\ #\\) + (#\/ #\/) + (#\b #\backspace) + (#\f #\page) + (#\n #\newline) + (#\r #\return) + (#\t #\tab) + (#\u (read-utf16-character port)) + (_ (json-error port)))) + +(define (read-string port) + "Read a JSON encoded string from PORT." + (assert-char port #\") + (let loop ((result '())) + (match (read-char port) + ((? eof-object?) (json-error port)) + (#\" (list->string (reverse result))) + (#\\ (loop (cons (read-escape-character port) result))) + (char (loop (cons char result)))))) + +(define char-set:json-digit + (char-set #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) + +(define (digit? char) + (char-set-contains? char-set:json-digit char)) + +(define (read-digit port) + "Read a digit 0-9 from PORT." + (match (read-char port) + (#\0 0) + (#\1 1) + (#\2 2) + (#\3 3) + (#\4 4) + (#\5 5) + (#\6 6) + (#\7 7) + (#\8 8) + (#\9 9) + (else (json-error port)))) + +(define (read-digits port) + "Read a sequence of digits from PORT." + (let loop ((result '())) + (match (peek-char port) + ((? eof-object?) + (reverse result)) + ((? digit?) + (loop (cons (read-digit port) result))) + (else (reverse result))))) + +(define (list->integer digits) + "Convert the list DIGITS to an integer." + (let loop ((i (1- (length digits))) + (result 0) + (digits digits)) + (match digits + (() result) + ((n . tail) + (loop (1- i) + (+ result (* n (expt 10 i))) + tail))))) + +(define (read-positive-integer port) + "Read a positive integer with no leading zeroes from PORT." + (match (read-digits port) + ((0 . _) + (json-error port)) ; no leading zeroes allowed + ((digits ...) + (list->integer digits)))) + +(define (read-exponent port) + "Read exponent from PORT." + (define (read-expt) + (list->integer (read-digits port))) + + (unless (memv (read-char port) '(#\e #\E)) + (json-error port)) + + (match (peek-char port) + ((? eof-object?) + (json-error port)) + (#\- + (read-char port) + (- (read-expt))) + (#\+ + (read-char port) + (read-expt)) + ((? digit?) + (read-expt)) + (_ (json-error port)))) + +(define (read-fraction port) + "Read fractional number part from PORT as an inexact number." + (let* ((digits (read-digits port)) + (numerator (list->integer digits)) + (denomenator (expt 10 (length digits)))) + (/ numerator denomenator))) + +(define (read-positive-number port) + "Read a positive number from PORT." + (let* ((integer (match (peek-char port) + ((? eof-object?) + (json-error port)) + (#\0 + (read-char port) + 0) + ((? digit?) + (read-positive-integer port)) + (_ (json-error port)))) + (fraction (match (peek-char port) + (#\. + (read-char port) + (read-fraction port)) + (_ 0))) + (exponent (match (peek-char port) + ((or #\e #\E) + (read-exponent port)) + (_ 0))) + (n (* (+ integer fraction) (expt 10 exponent)))) + + ;; Keep integers as exact numbers, but convert numbers encoded as + ;; floating point numbers to an inexact representation. + (if (zero? fraction) + n + (exact->inexact n)))) + +(define (read-number port) + "Read a number from PORT" + (match (peek-char port) + ((? eof-object?) + (json-error port)) + (#\- + (read-char port) + (- (read-positive-number port))) + ((? digit?) + (read-positive-number port)) + (_ (json-error port)))) + +(define (read-object port) + "Read key/value map from PORT." + (define (read-key+value-pair) + (let ((key (read-string port))) + (consume-whitespace port) + (assert-char port #\:) + (consume-whitespace port) + (let ((value (read-value port))) + (cons key value)))) + + (assert-char port #\{) + (consume-whitespace port) + + (if (eqv? #\} (peek-char port)) + (begin + (read-char port) + '(@)) ; empty object + (let loop ((result (list (read-key+value-pair)))) + (consume-whitespace port) + (match (peek-char port) + (#\, ; read another value + (read-char port) + (consume-whitespace port) + (loop (cons (read-key+value-pair) result))) + (#\} ; end of object + (read-char port) + (cons '@ (reverse result))) + (_ (json-error port)))))) + +(define (read-array port) + "Read array from PORT." + (assert-char port #\[) + (consume-whitespace port) + + (if (eqv? #\] (peek-char port)) + (begin + (read-char port) + '()) ; empty array + (let loop ((result (list (read-value port)))) + (consume-whitespace port) + (match (peek-char port) + (#\, ; read another value + (read-char port) + (consume-whitespace port) + (loop (cons (read-value port) result))) + (#\] ; end of array + (read-char port) + (reverse result)) + (_ (json-error port)))))) + +(define (read-value port) + "Read a JSON value from PORT." + (consume-whitespace port) + (match (peek-char port) + ((? eof-object?) (json-error port)) + (#\" (read-string port)) + (#\{ (read-object port)) + (#\[ (read-array port)) + (#\t (read-true port)) + (#\f (read-false port)) + (#\n (read-null port)) + ((or #\- (? digit?)) + (read-number port)) + (_ (json-error port)))) + +(define (read-json port) + "Read JSON text from port and return an s-expression representation." + (let ((result (read-value port))) + (consume-whitespace port) + (unless (eof-object? (peek-char port)) + (json-error port)) + result)) + + +;;; +;;; Writer +;;; + +(define (write-string str port) + "Write STR to PORT in JSON string format." + (define (escape-char char) + (display (match char + (#\" "\\\"") + (#\\ "\\\\") + (#\/ "\\/") + (#\backspace "\\b") + (#\page "\\f") + (#\newline "\\n") + (#\return "\\r") + (#\tab "\\t") + (_ char)) + port)) + + (display "\"" port) + (string-for-each escape-char str) + (display "\"" port)) + +(define (write-object alist port) + "Write ALIST to PORT in JSON object format." + ;; Keys may be strings or symbols. + (define key->string + (match-lambda + ((? string? key) key) + ((? symbol? key) (symbol->string key)))) + + (define (write-pair pair) + (match pair + ((key . value) + (write-string (key->string key) port) + (display ":" port) + (write-json value port)))) + + (display "{" port) + (match alist + (() #f) + ((front ... end) + (for-each (lambda (pair) + (write-pair pair) + (display "," port)) + front) + (write-pair end))) + (display "}" port)) + +(define (write-array lst port) + "Write LST to PORT in JSON array format." + (display "[" port) + (match lst + (() #f) + ((front ... end) + (for-each (lambda (val) + (write-json val port) + (display "," port)) + front) + (write-json end port))) + (display "]" port)) + +(define (write-json exp port) + "Write EXP to PORT in JSON format." + (match exp + (#t (display "true" port)) + (#f (display "false" port)) + ;; Differentiate #nil from '(). + ((and (? boolean? ) #nil) (display "null" port)) + ((? string? s) (write-string s port)) + ((? real? n) (display n port)) + (('@ . alist) (write-object alist port)) + ((vals ...) (write-array vals port)))) diff --git a/guix/build/node-build-system.scm b/guix/build/node-build-system.scm index 231e60488a..3c0ac2a12b 100644 --- a/guix/build/node-build-system.scm +++ b/guix/build/node-build-system.scm @@ -19,12 +19,12 @@ (define-module (guix build node-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build json) #:use-module (guix build union) #:use-module (guix build utils) #:use-module (ice-9 match) #:use-module (ice-9 popen) #:use-module (ice-9 regex) - #:use-module (json parser) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases @@ -39,12 +39,12 @@ (define* (read-package-data #:key (filename "package.json")) (call-with-input-file filename (lambda (port) - (json->scm port)))) + (read-json port)))) (define* (build #:key inputs #:allow-other-keys) (define (build-from-package-json? package-file) (let* ((package-data (read-package-data #:filename package-file)) - (scripts (hash-ref package-data "scripts"))) + (scripts (assoc-ref package-data "scripts"))) (assoc-ref scripts "build"))) "Build a new node module using the appropriate build system." ;; XXX: Develop a more robust heuristic, allow override @@ -103,15 +103,13 @@ the @file{bin} directory." (target (string-append out "/lib")) (binaries (string-append out "/bin")) (data (read-package-data)) - (modulename (hash-ref data "name")) - (binary-configuration (match (hash-ref data "bin") - ((? hash-table? hash-table) - (hash-map->list cons hash-table)) - ((? string? configuration) configuration) - (#f #f))) - (dependencies (match (hash-ref data "dependencies") - ((? hash-table? hash-table) - (hash-map->list cons hash-table)) + (modulename (assoc-ref data "name")) + (binary-configuration (match (assoc-ref data "bin") + (('@ configuration ...) configuration) + ((? string? configuration) configuration) + (#f #f))) + (dependencies (match (assoc-ref data "dependencies") + (('@ deps ...) deps) (#f #f)))) (mkdir-p target) (copy-recursively "." (string-append target "/node_modules/" modulename)) @@ -123,7 +121,7 @@ the @file{bin} directory." (begin (mkdir-p binaries) (symlink (string-append target "/node_modules/" modulename "/" - binary-configuration) + binary-configuration) (string-append binaries "/" modulename)))) ((list? binary-configuration) (for-each @@ -133,12 +131,12 @@ the @file{bin} directory." (begin (mkdir-p (dirname (string-append binaries "/" key))) (symlink (string-append target "/node_modules/" modulename "/" - value) + value) (string-append binaries "/" key)))))) binary-configuration)) (else (symlink (string-append target "/node_modules/" modulename "/bin") - binaries))) + binaries))) (when dependencies (mkdir-p (string-append target "/node_modules/" modulename "/node_modules")) -- cgit v1.2.3 From 38302bd9392cc9518b04e2726cf6a38ee75922cc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 14 Jul 2019 17:07:09 +0200 Subject: compile: Report the name of the file that cannot be compiled. Fixes . Reported by Robert Vollmert . * guix/build/compile.scm (call/exit-on-exception): Add 'file' parameter and honor it. (exit-on-exception): Likewise. (compile-files): Pass FILE to 'exit-on-exception'. --- guix/build/compile.scm | 15 ++++++++++----- 1 file changed, 10 insertions(+), 5 deletions(-) (limited to 'guix/build') diff --git a/guix/build/compile.scm b/guix/build/compile.scm index 29865f2f2e..c127456fd0 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -129,8 +129,9 @@ front." (lambda () (set! path initial-value))))) -(define (call/exit-on-exception thunk) - "Evaluate THUNK and exit right away if an exception is thrown." +(define (call/exit-on-exception file thunk) + "Evaluate THUNK and exit right away if an exception is thrown. Report FILE +as the file that was being compiled when the exception was thrown." (catch #t thunk (const #f) @@ -141,15 +142,18 @@ front." (stack (make-stack #t)) (depth (stack-length stack)) (frame (and (> depth 1) (stack-ref stack 1)))) + (newline port) + (format port "error: failed to compile '~a':~%~%" file) (false-if-exception (display-backtrace stack port)) (print-exception port frame key args))) ;; Don't go any further. (primitive-exit 1)))) -(define-syntax-rule (exit-on-exception exp ...) - "Evaluate EXP and exit if an exception is thrown." - (call/exit-on-exception (lambda () exp ...))) +(define-syntax-rule (exit-on-exception file exp ...) + "Evaluate EXP and exit if an exception is thrown. Report FILE as the faulty +file when an exception is thrown." + (call/exit-on-exception file (lambda () exp ...))) (define* (compile-files source-directory build-directory files #:key @@ -173,6 +177,7 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"." ;; Exit as soon as something goes wrong. (exit-on-exception + file (with-target host (lambda () (let ((relative (relative-file source-directory file))) -- cgit v1.2.3 From 456c7ade095cce96f47389c37a4fe3b0390047fd Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 15 Jul 2019 09:56:27 +0200 Subject: syscalls: Use 'define-as-needed' for 'AT_' constants introduced in Guile 2.2.5. * guix/build/syscalls.scm (AT_FDCWD, AT_SYMLINK_NOFOLLOW, AT_REMOVEDIR) (AT_SYMLINK_FOLLOW, AT_NO_AUTOMOUNT, AT_EMPTY_PATH): Define using 'define-as-needed'. --- guix/build/syscalls.scm | 19 ++++++------------- 1 file changed, 6 insertions(+), 13 deletions(-) (limited to 'guix/build') diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index eb045cbd1c..3c84d3893f 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -48,13 +48,6 @@ MNT_EXPIRE UMOUNT_NOFOLLOW - AT_FDCWD - AT_SYMLINK_NOFOLLOW - AT_REMOVEDIR - AT_SYMLINK_FOLLOW - AT_NO_AUTOMOUNT - AT_EMPTY_PATH - restart-on-EINTR mount-points swapon @@ -686,12 +679,12 @@ mounted at FILE." ;; Flags for the *at command, notably the 'utime' procedure of libguile. ;; From . -(define AT_FDCWD -100) -(define AT_SYMLINK_NOFOLLOW #x100) -(define AT_REMOVEDIR #x200) -(define AT_SYMLINK_FOLLOW #x400) -(define AT_NO_AUTOMOUNT #x800) -(define AT_EMPTY_PATH #x1000) +(define-as-needed AT_FDCWD -100) +(define-as-needed AT_SYMLINK_NOFOLLOW #x100) +(define-as-needed AT_REMOVEDIR #x200) +(define-as-needed AT_SYMLINK_FOLLOW #x400) +(define-as-needed AT_NO_AUTOMOUNT #x800) +(define-as-needed AT_EMPTY_PATH #x1000) (define-syntax BLKRRPART ; (identifier-syntax #x125F)) -- cgit v1.2.3 From c82c16a6f3cfeec82ba8bd7572b11852a6152c7e Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Mon, 15 Jul 2019 21:41:53 +0200 Subject: build/cargo-build-system: Set CARGO_HOME early. * guix/build/cargo-build-system.scm (configure): Set CARGO_HOME. (install): No longer set CARGO_HOME. Signed-off-by: Danny Milosavljevic --- guix/build/cargo-build-system.scm | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) (limited to 'guix/build') diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index 1f36304b15..e4e62dd838 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -99,6 +99,7 @@ Cargo.toml file present at its root." inputs) ;; Configure cargo to actually use this new directory. + (setenv "CARGO_HOME" (string-append (getcwd) "/.cargo")) (mkdir-p ".cargo") (let ((port (open-file ".cargo/config" "w" #:encoding "utf-8"))) (display " @@ -148,9 +149,6 @@ directory = '" port) ;; Make cargo reuse all the artifacts we just built instead ;; of defaulting to making a new temp directory (setenv "CARGO_TARGET_DIR" "./target") - ;; Force cargo to honor our .cargo/config definitions - ;; https://github.com/rust-lang/cargo/issues/6397 - (setenv "CARGO_HOME" ".") ;; Only install crates which include binary targets, ;; otherwise cargo will raise an error. -- cgit v1.2.3 From 4fde0030d42068b347d7af58ed3b746c5ea2f877 Mon Sep 17 00:00:00 2001 From: Robert Vollmert Date: Mon, 15 Jul 2019 21:41:55 +0200 Subject: build/cargo-build-system: Use bundled json instead of guile-json. * guix/build/cargo-build-system.scm: Use (gnu build json) instead of (json parser). * guix/build-system/cargo.scm: Import (gnu build json) instead of (json parser). Signed-off-by: Danny Milosavljevic --- guix/build-system/cargo.scm | 2 +- guix/build/cargo-build-system.scm | 8 ++++---- 2 files changed, 5 insertions(+), 5 deletions(-) (limited to 'guix/build') diff --git a/guix/build-system/cargo.scm b/guix/build-system/cargo.scm index fa211d456d..10a1bac844 100644 --- a/guix/build-system/cargo.scm +++ b/guix/build-system/cargo.scm @@ -61,7 +61,7 @@ to NAME and VERSION." (define %cargo-build-system-modules ;; Build-side modules imported by default. `((guix build cargo-build-system) - (json parser) + (guix build json) ,@%cargo-utils-modules)) (define* (cargo-build store name inputs diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm index e4e62dd838..f38de16cf7 100644 --- a/guix/build/cargo-build-system.scm +++ b/guix/build/cargo-build-system.scm @@ -20,6 +20,7 @@ (define-module (guix build cargo-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build json) #:use-module (guix build utils) #:use-module (guix build cargo-utils) #:use-module (ice-9 popen) @@ -27,7 +28,6 @@ #:use-module (ice-9 ftw) #:use-module (ice-9 format) #:use-module (ice-9 match) - #:use-module (json parser) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:export (%standard-phases @@ -42,15 +42,15 @@ (define (manifest-targets) "Extract all targets from the Cargo.toml manifest" (let* ((port (open-input-pipe "cargo read-manifest")) - (data (json->scm port)) - (targets (hash-ref data "targets" '()))) + (data (read-json port)) + (targets (or (assoc-ref data "targets") '()))) (close-port port) targets)) (define (has-executable-target?) "Check if the current cargo project declares any binary targets." (let* ((bin? (lambda (kind) (string=? kind "bin"))) - (get-kinds (lambda (dep) (hash-ref dep "kind"))) + (get-kinds (lambda (dep) (assoc-ref dep "kind"))) (bin-dep? (lambda (dep) (find bin? (get-kinds dep))))) (find bin-dep? (manifest-targets)))) -- cgit v1.2.3