1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
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.
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.
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/>.
19 (define-module (guix inferior)
20 #:use-module (srfi srfi-9)
21 #:use-module (srfi srfi-9 gnu)
22 #:use-module (ice-9 match)
23 #:use-module (ice-9 popen)
32 inferior-package-version
35 inferior-package-synopsis
36 inferior-package-description))
40 ;;; This module provides a way to spawn Guix "inferior" processes and to talk
41 ;;; to them. It allows us, from one instance of Guix, to interact with
42 ;;; another instance of Guix coming from a different commit.
46 ;; Inferior Guix process.
47 (define-record-type <inferior>
48 (inferior pid socket version)
51 (socket inferior-socket)
52 (version inferior-version)) ;REPL protocol version
54 (define (inferior-pipe directory command)
55 "Return an input/output pipe on the Guix instance in DIRECTORY. This runs
56 'DIRECTORY/COMMAND repl' if it exists, or falls back to some other method if
58 (let ((pipe (with-error-to-port (%make-void-port "w")
61 (string-append directory "/" command)
62 "repl" "-t" "machine")))))
63 (if (eof-object? (peek-char pipe))
67 ;; Older versions of Guix didn't have a 'guix repl' command, so
69 (open-pipe* OPEN_BOTH "guile"
70 "-L" (string-append directory "/share/guile/site/"
72 "-C" (string-append directory "/share/guile/site/"
74 "-C" (string-append directory "/lib/guile/"
75 (effective-version) "/site-ccache")
79 (primitive-load ,(search-path %load-path
80 "guix/scripts/repl.scm"))
81 ((@ (guix scripts repl) machine-repl))))))
84 (define* (open-inferior directory #:key (command "bin/guix"))
85 "Open the inferior Guix in DIRECTORY, running 'DIRECTORY/COMMAND repl' or
86 equivalent. Return #f if the inferior could not be launched."
88 (inferior-pipe directory command))
91 ((and guile-2 (not guile-2.2)) #t)
92 (else (setvbuf pipe 'line)))
95 (('repl-version 0 rest ...)
96 (let ((result (inferior 'pipe pipe (cons 0 rest))))
97 (inferior-eval '(use-modules (guix)) result)
98 (inferior-eval '(use-modules (gnu)) result)
99 (inferior-eval '(define %package-table (make-hash-table))
105 (define (close-inferior inferior)
107 (close-pipe (inferior-socket inferior)))
109 ;; Non-self-quoting object of the inferior.
110 (define-record-type <inferior-object>
111 (inferior-object address appearance)
113 (address inferior-object-address)
114 (appearance inferior-object-appearance))
116 (define (write-inferior-object object port)
118 (($ <inferior-object> _ appearance)
119 (format port "#<inferior-object ~a>" appearance))))
121 (set-record-type-printer! <inferior-object> write-inferior-object)
123 (define (inferior-eval exp inferior)
124 "Evaluate EXP in INFERIOR."
129 (('non-self-quoting address string)
130 (inferior-object address string))))
132 (write exp (inferior-socket inferior))
133 (newline (inferior-socket inferior))
134 (match (read (inferior-socket inferior))
135 (('values objects ...)
136 (apply values (map sexp->object objects)))
137 (('exception key objects ...)
138 (apply throw key (map sexp->object objects)))))
142 ;;; Inferior packages.
145 (define-record-type <inferior-package>
146 (inferior-package inferior name version id)
148 (inferior inferior-package-inferior)
149 (name inferior-package-name)
150 (version inferior-package-version)
151 (id inferior-package-id))
153 (define (write-inferior-package package port)
155 (($ <inferior-package> _ name version)
156 (format port "#<inferior-package ~a@~a ~a>"
158 (number->string (object-address package) 16)))))
160 (set-record-type-printer! <inferior-package> write-inferior-package)
162 (define (inferior-packages inferior)
163 "Return the list of packages known to INFERIOR."
164 (let ((result (inferior-eval
165 '(fold-packages (lambda (package result)
166 (let ((id (object-address package)))
167 (hashv-set! %package-table id package)
168 (cons (list (package-name package)
169 (package-version package)
176 (inferior-package inferior name version id)))
179 (define (inferior-package-field package getter)
180 "Return the field of PACKAGE, an inferior package, accessed with GETTER."
181 (let ((inferior (inferior-package-inferior package))
182 (id (inferior-package-id package)))
183 (inferior-eval `(,getter (hashv-ref %package-table ,id))
186 (define* (inferior-package-synopsis package #:key (translate? #t))
187 "Return the Texinfo synopsis of PACKAGE, an inferior package. When
188 TRANSLATE? is true, translate it to the current locale's language."
189 (inferior-package-field package
191 '(compose (@ (guix ui) P_) package-synopsis)
194 (define* (inferior-package-description package #:key (translate? #t))
195 "Return the Texinfo description of PACKAGE, an inferior package. When
196 TRANSLATE? is true, translate it to the current locale's language."
197 (inferior-package-field package
199 '(compose (@ (guix ui) P_) package-description)
200 'package-description)))