guix/repl.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
   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 repl)
  20   #:use-module (srfi srfi-1)
  21   #:use-module (srfi srfi-26)
  22   #:use-module (ice-9 match)
  23   #:export (send-repl-response
  24             machine-repl))
  25
  26 ;;; Commentary:
  27 ;;;
  28 ;;; This module implements the "machine-readable" REPL provided by
  29 ;;; 'guix repl -t machine'.  It's a lightweight module meant to be
  30 ;;; embedded in any Guile process providing REPL functionality.
  31 ;;;
  32 ;;; Code:
  33
  34 (define (self-quoting? x)
  35   "Return #t if X is self-quoting."
  36   (letrec-syntax ((one-of (syntax-rules ()
  37                             ((_) #f)
  38                             ((_ pred rest ...)
  39                              (or (pred x)
  40                                  (one-of rest ...))))))
  41     (one-of symbol? string? keyword? pair? null? array?
  42             number? boolean? char?)))
  43
  44 (define repl-prompt
  45   ;; Current REPL prompt or #f.
  46   (make-parameter #f))
  47
  48 (define (stack->frames stack)
  49   "Return STACK's frames as a list."
  50   (unfold (cute >= <> (stack-length stack))
  51           (cut stack-ref stack <>)
  52           1+
  53           0))
  54
  55 (define* (send-repl-response exp output
  56                              #:key (version '(0 0)))
  57   "Write the response corresponding to the evaluation of EXP to PORT, an
  58 output port.  VERSION is the client's protocol version we are targeting."
  59   (define (value->sexp value)
  60     (if (self-quoting? value)
  61         `(value ,value)
  62         `(non-self-quoting ,(object-address value)
  63                            ,(object->string value))))
  64
  65   (define (frame->sexp frame)
  66     `(,(frame-procedure-name frame)
  67       ,(match (frame-source frame)
  68          ((_ (? string? file) (? integer? line) . (? integer? column))
  69           (list file line column))
  70          (_
  71           '(#f #f #f)))))
  72
  73   (define (handle-exception key . args)
  74     (define reply
  75       (match version
  76         ((0 1 (? positive?) _ ...)
  77          ;; Protocol (0 1 1) and later.
  78          (let ((stack (if (repl-prompt)
  79                           (make-stack #t handle-exception (repl-prompt))
  80                           (make-stack #t))))
  81            `(exception (arguments ,key ,@(map value->sexp args))
  82                        (stack ,@(map frame->sexp (stack->frames stack))))))
  83         (_
  84          ;; Protocol (0 0).
  85          `(exception ,key ,@(map value->sexp args)))))
  86
  87     (write reply output)
  88     (newline output)
  89     (force-output output))
  90
  91   (catch #t
  92     (lambda ()
  93       (let ((results (call-with-values
  94                          (lambda ()
  95                            (primitive-eval exp))
  96                        list)))
  97         (write `(values ,@(map value->sexp results))
  98                output)
  99         (newline output)
 100         (force-output output)))
 101     (const #t)
 102     handle-exception))
 103
 104 (define* (machine-repl #:optional
 105                        (input (current-input-port))
 106                        (output (current-output-port)))
 107   "Run a machine-usable REPL over ports INPUT and OUTPUT.
 108
 109 The protocol of this REPL is meant to be machine-readable and provides proper
 110 support to represent multiple-value returns, exceptions, objects that lack a
 111 read syntax, and so on.  As such it is more convenient and robust than parsing
 112 Guile's REPL prompt."
 113   (define tag
 114     (make-prompt-tag "repl-prompt"))
 115
 116   (define (loop exp version)
 117     (match exp
 118       ((? eof-object?) #t)
 119       (exp
 120        (send-repl-response exp output
 121                            #:version version)
 122        (loop (read input) version))))
 123
 124   (write `(repl-version 0 1 1) output)
 125   (newline output)
 126   (force-output output)
 127
 128   ;; In protocol version (0 0), clients would not send their supported
 129   ;; protocol version.  Thus, the code below checks for two case: (1) a (0 0)
 130   ;; client that directly sends an expression to evaluate, and (2) a more
 131   ;; recent client that sends (() repl-version ...).  This form is chosen to
 132   ;; be unambiguously distinguishable from a regular Scheme expression.
 133
 134   (call-with-prompt tag
 135     (lambda ()
 136       (parameterize ((repl-prompt tag))
 137         (match (read input)
 138           ((() 'repl-version version ...)
 139            (loop (read input) version))
 140           (exp
 141            (loop exp '(0 0))))))
 142     (const #f)))