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            ;; Note: 'make-stack' returns #f if there's no 'handle-exception'
  82            ;; stack frame, which is the case when this file is being
  83            ;; interpreted as with 'primitive-load'.
  84            `(exception (arguments ,key ,@(map value->sexp args))
  85                        (stack ,@(map frame->sexp
  86                                      (if stack
  87                                          (stack->frames stack)
  88                                          '()))))))
  89         (_
  90          ;; Protocol (0 0).
  91          `(exception ,key ,@(map value->sexp args)))))
  92
  93     (write reply output)
  94     (newline output)
  95     (force-output output))
  96
  97   (catch #t
  98     (lambda ()
  99       (let ((results (call-with-values
 100                          (lambda ()
 101                            (primitive-eval exp))
 102                        list)))
 103         (write `(values ,@(map value->sexp results))
 104                output)
 105         (newline output)
 106         (force-output output)))
 107     (const #t)
 108     handle-exception))
 109
 110 (define* (machine-repl #:optional
 111                        (input (current-input-port))
 112                        (output (current-output-port)))
 113   "Run a machine-usable REPL over ports INPUT and OUTPUT.
 114
 115 The protocol of this REPL is meant to be machine-readable and provides proper
 116 support to represent multiple-value returns, exceptions, objects that lack a
 117 read syntax, and so on.  As such it is more convenient and robust than parsing
 118 Guile's REPL prompt."
 119   (define tag
 120     (make-prompt-tag "repl-prompt"))
 121
 122   (define (loop exp version)
 123     (match exp
 124       ((? eof-object?) #t)
 125       (exp
 126        (send-repl-response exp output
 127                            #:version version)
 128        (loop (read input) version))))
 129
 130   (write `(repl-version 0 1 1) output)
 131   (newline output)
 132   (force-output output)
 133
 134   ;; In protocol version (0 0), clients would not send their supported
 135   ;; protocol version.  Thus, the code below checks for two case: (1) a (0 0)
 136   ;; client that directly sends an expression to evaluate, and (2) a more
 137   ;; recent client that sends (() repl-version ...).  This form is chosen to
 138   ;; be unambiguously distinguishable from a regular Scheme expression.
 139
 140   (call-with-prompt tag
 141     (lambda ()
 142       (parameterize ((repl-prompt tag))
 143         (match (read input)
 144           ((() 'repl-version version ...)
 145            (loop (read input) version))
 146           (exp
 147            (loop exp '(0 0))))))
 148     (const #f)))