diff options
Diffstat (limited to 'guix/self.scm')
| -rw-r--r-- | guix/self.scm | 414 |
1 files changed, 354 insertions, 60 deletions
diff --git a/guix/self.scm b/guix/self.scm index 6220efb397..e71e086cdc 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -34,6 +34,7 @@ #:use-module (srfi srfi-9) #:use-module (ice-9 match) #:export (make-config.scm + whole-package ;for internal use in 'guix pull' compiled-guix guix-derivation reload-guix)) @@ -82,6 +83,7 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." ("guile-json" (ref '(gnu packages guile) 'guile-json)) ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh)) ("guile-git" (ref '(gnu packages guile) 'guile-git)) + ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3)) ("libgcrypt" (ref '(gnu packages gnupg) 'libgcrypt)) ("zlib" (ref '(gnu packages compression) 'zlib)) ("gzip" (ref '(gnu packages compression) 'gzip)) @@ -92,6 +94,7 @@ GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." ("guile2.0-json" (ref '(gnu packages guile) 'guile2.0-json)) ("guile2.0-ssh" (ref '(gnu packages ssh) 'guile2.0-ssh)) ("guile2.0-git" (ref '(gnu packages guile) 'guile2.0-git)) + ;; XXX: No "guile2.0-sqlite3". (_ #f)))) ;no such package @@ -167,7 +170,8 @@ must be present in the search path." (source (imported-files (string-append name "-source") (append module-files extra-files)))) (node name modules source dependencies - (compiled-modules name source modules + (compiled-modules name source + (map car module-files) (map node-source dependencies) (map node-compiled dependencies) #:extensions extensions @@ -189,7 +193,229 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." (file-name->module-name (string-drop file prefix))) (scheme-files (string-append directory "/" sub-directory))))) +(define* (sub-directory item sub-directory) + "Return SUB-DIRECTORY within ITEM, which may be a file name or a file-like +object." + (match item + ((? string?) + ;; This is the optimal case: we return a new "source". Thus, a + ;; derivation that depends on this sub-directory does not depend on ITEM + ;; itself. + (local-file (string-append item "/" sub-directory) + #:recursive? #t)) + ;; TODO: Add 'local-file?' case. + (_ + ;; In this case, anything that refers to the result also depends on ITEM, + ;; which isn't great. + (file-append item "/" sub-directory)))) + +(define* (locale-data source domain + #:optional (directory domain)) + "Return the locale data from 'po/DIRECTORY' in SOURCE, corresponding to +DOMAIN, a gettext domain." + (define gettext + (module-ref (resolve-interface '(gnu packages gettext)) + 'gettext-minimal)) + + (define build + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils) + (srfi srfi-26) + (ice-9 match) (ice-9 ftw)) + + (define po-directory + #+(sub-directory source (string-append "po/" directory))) + + (define (compile language) + (let ((gmo (string-append #$output "/" language "/LC_MESSAGES/" + #$domain ".mo"))) + (mkdir-p (dirname gmo)) + (invoke #+(file-append gettext "/bin/msgfmt") + "-c" "--statistics" "--verbose" + "-o" gmo + (string-append po-directory "/" language ".po")))) + + (define (linguas) + ;; Return the list of languages. Note: don't read 'LINGUAS' + ;; because it contains things like 'en@boldquot' that do not have + ;; a corresponding .po file. + (map (cut basename <> ".po") + (scandir po-directory + (cut string-suffix? ".po" <>)))) + + (for-each compile (linguas))))) + + (computed-file (string-append "guix-locale-" domain) + build)) + +(define (info-manual source) + "Return the Info manual built from SOURCE." + (define texinfo + (module-ref (resolve-interface '(gnu packages texinfo)) + 'texinfo)) + + (define graphviz + (module-ref (resolve-interface '(gnu packages graphviz)) + 'graphviz)) + + (define documentation + (sub-directory source "doc")) + + (define examples + (sub-directory source "gnu/system/examples")) + + (define build + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + + (mkdir #$output) + + ;; Create 'version.texi'. + ;; XXX: Can we use a more meaningful version string yet one that + ;; doesn't change at each commit? + (call-with-output-file "version.texi" + (lambda (port) + (let ((version "0.0-git)")) + (format port " +@set UPDATED 1 January 1970 +@set UPDATED-MONTH January 1970 +@set EDITION ~a +@set VERSION ~a\n" version version)))) + + ;; Copy configuration templates that the manual includes. + (for-each (lambda (template) + (copy-file template + (string-append + "os-config-" + (basename template ".tmpl") + ".texi"))) + (find-files #$examples "\\.tmpl$")) + + ;; Build graphs. + (mkdir-p (string-append #$output "/images")) + (for-each (lambda (dot-file) + (invoke #+(file-append graphviz "/bin/dot") + "-Tpng" "-Gratio=.9" "-Gnodesep=.005" + "-Granksep=.00005" "-Nfontsize=9" + "-Nheight=.1" "-Nwidth=.1" + "-o" (string-append #$output "/images/" + (basename dot-file ".dot") + ".png") + dot-file)) + (find-files (string-append #$documentation "/images") + "\\.dot$")) + + ;; Copy other PNGs. + (for-each (lambda (png-file) + (install-file png-file + (string-append #$output "/images"))) + (find-files (string-append #$documentation "/images") + "\\.png$")) + + ;; Finally build the manual. Copy it the Texinfo files to $PWD and + ;; add a symlink to the 'images' directory so that 'makeinfo' can + ;; see those images and produce image references in the Info output. + (copy-recursively #$documentation "." + #:log (%make-void-port "w")) + (delete-file-recursively "images") + (symlink (string-append #$output "/images") "images") + + (for-each (lambda (texi) + (unless (string=? "guix.texi" texi) + ;; Create 'version-LL.texi'. + (let* ((base (basename texi ".texi")) + (dot (string-index base #\.)) + (tag (string-drop base (+ 1 dot)))) + (symlink "version.texi" + (string-append "version-" tag ".texi")))) + + (invoke #+(file-append texinfo "/bin/makeinfo") + texi "-I" #$documentation + "-I" "." + "-o" (string-append #$output "/" + (basename texi ".texi") + ".info"))) + (cons "guix.texi" + (find-files "." "^guix\\.[a-z]{2}\\.texi$")))))) + + (computed-file "guix-manual" build)) + +(define* (guix-command modules #:key source (dependencies '()) + (guile-version (effective-version))) + "Return the 'guix' command such that it adds MODULES and DEPENDENCIES in its +load path." + (program-file "guix-command" + #~(begin + (set! %load-path + (append '#$(map (lambda (package) + (file-append package + "/share/guile/site/" + guile-version)) + dependencies) + %load-path)) + + (set! %load-compiled-path + (append '#$(map (lambda (package) + (file-append package "/lib/guile/" + guile-version + "/site-ccache")) + dependencies) + %load-compiled-path)) + + (set! %load-path (cons #$modules %load-path)) + (set! %load-compiled-path + (cons #$modules %load-compiled-path)) + + (let ((guix-main (module-ref (resolve-interface '(guix ui)) + 'guix-main))) + #$(if source + #~(begin + (bindtextdomain "guix" + #$(locale-data source "guix")) + (bindtextdomain "guix-packages" + #$(locale-data source + "guix-packages" + "packages"))) + #t) + + ;; XXX: It would be more convenient to change it to: + ;; (exit (apply guix-main (command-line))) + (apply guix-main (command-line)))))) + +(define* (whole-package name modules dependencies + #:key + (guile-version (effective-version)) + info + (command (guix-command modules + #:dependencies dependencies + #:guile-version guile-version))) + "Return the whole Guix package NAME that uses MODULES, a derivation of all +the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the +'guix' program to use; INFO is the Info manual." + ;; TODO: Move compiled modules to 'lib/guile' instead of 'share/guile'. + (computed-file name + (with-imported-modules '((guix build utils)) + #~(begin + (use-modules (guix build utils)) + (mkdir-p (string-append #$output "/bin")) + (symlink #$command + (string-append #$output "/bin/guix")) + + (let ((modules (string-append #$output + "/share/guile/site/" + (effective-version))) + (info #$info)) + (mkdir-p (dirname modules)) + (symlink #$modules modules) + (when info + (symlink #$info + (string-append #$output + "/share/info")))))))) + (define* (compiled-guix source #:key (version %guix-version) + (pull-version 1) (name (string-append "guix-" version)) (guile-version (effective-version)) (guile-for-build (guile-for-build guile-version)) @@ -215,12 +441,16 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." "guile-git" "guile2.0-git")) + (define guile-sqlite3 + (package-for-guile guile-version + "guile-sqlite3" + "guile2.0-sqlite3")) (define dependencies (match (append-map (lambda (package) (cons (list "x" package) - (package-transitive-inputs package))) - (list guile-git guile-json guile-ssh)) + (package-transitive-propagated-inputs package))) + (list guile-git guile-json guile-ssh guile-sqlite3)) (((labels packages _ ...) ...) packages))) @@ -248,25 +478,37 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." (specification->package "libgcrypt")))) + ;; (guix man-db) is needed at build-time by (guix profiles) + ;; but we don't need to compile it; not compiling it allows + ;; us to avoid an extra dependency on guile-gdbm-ffi. + #:extra-files + `(("guix/man-db.scm" ,(local-file "../guix/man-db.scm"))) + #:guile-for-build guile-for-build)) (define *extra-modules* (scheme-node "guix-extra" (filter-map (match-lambda (('guix 'scripts _ ..1) #f) + (('guix 'man-db) #f) (name name)) (scheme-modules* source "guix")) (list *core-modules*) #:extensions dependencies #:guile-for-build guile-for-build)) - (define *package-modules* - (scheme-node "guix-packages" + (define *core-package-modules* + (scheme-node "guix-packages-base" `((gnu packages) - ,@(scheme-modules* source "gnu/packages")) + (gnu packages base)) (list *core-modules* *extra-modules*) #:extensions dependencies - #:extra-files ;all the non-Scheme files + + ;; Add all the non-Scheme files here. We must do it here so + ;; that 'search-patches' & co. can find them. Ideally we'd + ;; keep them next to the .scm files that use them but it's + ;; difficult to do (XXX). + #:extra-files (file-imports source "gnu/packages" (lambda (file stat) (and (eq? 'regular (stat:type stat)) @@ -276,23 +518,37 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." (not (string-suffix? "~" file))))) #:guile-for-build guile-for-build)) + (define *package-modules* + (scheme-node "guix-packages" + (scheme-modules* source "gnu/packages") + (list *core-modules* *extra-modules* *core-package-modules*) + #:extensions dependencies + #:guile-for-build guile-for-build)) + (define *system-modules* (scheme-node "guix-system" `((gnu system) (gnu services) ,@(scheme-modules* source "gnu/system") ,@(scheme-modules* source "gnu/services")) - (list *package-modules* *extra-modules* *core-modules*) + (list *core-package-modules* *package-modules* + *extra-modules* *core-modules*) #:extensions dependencies #:extra-files - (file-imports source "gnu/system/examples" (const #t)) + (append (file-imports source "gnu/system/examples" + (const #t)) + + ;; Build-side code that we don't build. Some of + ;; these depend on guile-rsvg, the Shepherd, etc. + (file-imports source "gnu/build" (const #t))) #:guile-for-build guile-for-build)) (define *cli-modules* (scheme-node "guix-cli" (scheme-modules* source "/guix/scripts") - (list *core-modules* *extra-modules* *package-modules* + (list *core-modules* *extra-modules* + *core-package-modules* *package-modules* *system-modules*) #:extensions dependencies #:guile-for-build guile-for-build)) @@ -318,31 +574,52 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." %guix-home-page-url))) #:guile-for-build guile-for-build)) - (directory-union name - (append-map (lambda (node) - (list (node-source node) - (node-compiled node))) - - ;; Note: *CONFIG* comes first so that it - ;; overrides the (guix config) module that - ;; comes with *CORE-MODULES*. - (list *config* - *cli-modules* - *system-modules* - *package-modules* - *extra-modules* - *core-modules*)) - - ;; Silently choose the first entry upon collision so that - ;; we choose *CONFIG*. - #:resolve-collision 'first - - ;; When we do (add-to-store "utils.scm"), "utils.scm" must - ;; be a regular file, not a symlink. Thus, arrange so that - ;; regular files appear as regular files in the final - ;; output. - #:copy? #t - #:quiet? #t)) + (define built-modules + (directory-union (string-append name "-modules") + (append-map (lambda (node) + (list (node-source node) + (node-compiled node))) + + ;; Note: *CONFIG* comes first so that it + ;; overrides the (guix config) module that + ;; comes with *CORE-MODULES*. + (list *config* + *cli-modules* + *system-modules* + *package-modules* + *core-package-modules* + *extra-modules* + *core-modules*)) + + ;; Silently choose the first entry upon collision so that + ;; we choose *CONFIG*. + #:resolve-collision 'first + + ;; When we do (add-to-store "utils.scm"), "utils.scm" must + ;; be a regular file, not a symlink. Thus, arrange so that + ;; regular files appear as regular files in the final + ;; output. + #:copy? #t + #:quiet? #t)) + + ;; Version 0 of 'guix pull' meant we'd just return Scheme modules. + ;; Version 1 is when we return the full package. + (cond ((= 1 pull-version) + ;; The whole package, with a standard file hierarchy. + (let ((command (guix-command built-modules + #:source source + #:dependencies dependencies + #:guile-version guile-version))) + (whole-package name built-modules dependencies + #:command command + #:info (info-manual source) + #:guile-version guile-version))) + ((= 0 pull-version) + ;; Legacy 'guix pull': just return the compiled modules. + built-modules) + (else + ;; Unsupported 'guix pull' version. + #f))) ;;; @@ -451,6 +728,11 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." (define (imported-files name files) ;; This is a non-monadic, simplified version of 'imported-files' from (guix ;; gexp). + (define same-target? + (match-lambda* + (((file1 . _) (file2 . _)) + (string=? file1 file2)))) + (define build (with-imported-modules (source-module-closure '((guix build utils))) @@ -467,14 +749,15 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." ;; symlinks, as this makes a difference for ;; 'add-to-store'. (copy-file store-path final-path))) - '#$files)))) + '#$(delete-duplicates files same-target?))))) ;; We're just copying files around, no need to substitute or offload it. (computed-file name build #:options '(#:local-build? #t - #:substitutable? #f))) + #:substitutable? #f + #:env-vars (("COLUMNS" . "200"))))) -(define* (compiled-modules name module-tree modules +(define* (compiled-modules name module-tree module-files #:optional (dependencies '()) (dependencies-compiled '()) @@ -482,6 +765,9 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." (extensions '()) ;full-blown Guile packages parallel? guile-for-build) + "Build all the MODULE-FILES from MODULE-TREE. MODULE-FILES must be a list +like '(\"guix/foo.scm\" \"gnu/bar.scm\") and MODULE-TREE is the directory +containing MODULE-FILES and possibly other files as well." ;; This is a non-monadic, enhanced version of 'compiled-file' from (guix ;; gexp). (define build @@ -512,16 +798,13 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." (* 100. (/ completed total)) total) (force-output)) - (define (process-directory directory output) - (let ((files (find-files directory "\\.scm$")) - (prefix (+ 1 (string-length directory)))) - ;; Hide compilation warnings. - (parameterize ((current-warning-port (%make-void-port "w"))) - (compile-files directory #$output - (map (cut string-drop <> prefix) files) - #:workers (parallel-job-count) - #:report-load report-load - #:report-compilation report-compilation)))) + (define (process-directory directory files output) + ;; Hide compilation warnings. + (parameterize ((current-warning-port (%make-void-port "w"))) + (compile-files directory #$output files + #:workers (parallel-job-count) + #:report-load report-load + #:report-compilation report-compilation))) (setvbuf (current-output-port) _IONBF) (setvbuf (current-error-port) _IONBF) @@ -549,7 +832,7 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." (mkdir #$output) (chdir #+module-tree) - (process-directory "." #$output) + (process-directory "." '#+module-files #$output) (newline)))) (computed-file name build @@ -558,7 +841,11 @@ list of file-name/file-like objects suitable as inputs to 'imported-files'." `(#:local-build? #f ;allow substitutes ;; Don't annoy people about _IONBF deprecation. - #:env-vars (("GUILE_WARN_DEPRECATED" . "no"))))) + ;; Initialize 'terminal-width' in (system repl debug) + ;; to a large-enough value to make backtrace more + ;; verbose. + #:env-vars (("GUILE_WARN_DEPRECATED" . "no") + ("COLUMNS" . "200"))))) ;;; @@ -586,9 +873,12 @@ running Guile." 'guile-2.0)))) (define* (guix-derivation source version - #:optional (guile-version (effective-version))) + #:optional (guile-version (effective-version)) + #:key (pull-version 0)) "Return, as a monadic value, the derivation to build the Guix from SOURCE -for GUILE-VERSION. Use VERSION as the version string." +for GUILE-VERSION. Use VERSION as the version string. PULL-VERSION specifies +the version of the 'guix pull' protocol. Return #f if this PULL-VERSION value +is not supported." (define (shorten version) (if (and (string-every char-set:hex-digit version) (> (string-length version) 9)) @@ -600,11 +890,15 @@ for GUILE-VERSION. Use VERSION as the version string." (mbegin %store-monad (set-guile-for-build guile) - (lower-object (compiled-guix source - #:version version - #:name (string-append "guix-" - (shorten version)) - #:guile-version (match guile-version - ("2.2.2" "2.2") - (version version)) - #:guile-for-build guile)))) + (let ((guix (compiled-guix source + #:version version + #:name (string-append "guix-" + (shorten version)) + #:pull-version pull-version + #:guile-version (match guile-version + ("2.2.2" "2.2") + (version version)) + #:guile-for-build guile))) + (if guix + (lower-object guix) + (return #f))))) |