Crediting Alex Matthews as a code contributor

PiperOrigin-RevId: 360859332
2026-05-30 04:05:27 +08:00 · 2021-03-04 09:28:30 +00:00
parent 7e6fd889e4
commit ca532c106c
32 changed files with 5580 additions and 1 deletions
@@ -0,0 +1,96 @@
+#lang racket/base
+
+;***************************************************************************************;
+;****                           User Interaction Commands                           ****;
+;***************************************************************************************;
+
+(require (for-syntax racket/base syntax/parse)
+         racket/format
+         racket/list
+         racket/match
+         racket/port)
+
+(provide (all-defined-out))
+
+;; Notice: variables set via eval or only set locally, in the local namespace,
+;; and not in the main namespace.
+;; variables set via the (list 'var val) pattern are set in the main namespace.
+;; Even though the namespace is at the module level, the variables
+;; are set in the namespace with their value so they can be used with eval.
+;; TODO: When a ns-anchor is given, commands are eval'ed by default, and to directly modify
+;;   variables one must use ! (where the second argument is evaled)
+(define-syntax (interact stx)
+  (syntax-parse stx
+    #:literals (list)
+    [(_ (~alt (~optional (~seq #:prompt prompt:expr)) ; must evaluate to a string, default "> "
+              (~optional (~seq #:command command:expr))
+              (~optional (~seq #:namespace-anchor ns-anchor:expr)) ; default #false
+              (~optional (~seq #:variables (var:id ...))) ; must be bound identifiers
+              (~optional (~seq #:readline? readline?:expr))) ; start with readline enabled? (#false)
+        ...
+        [(list pat ...) help-string body ...+] ...) ; match patterns
+     (with-syntax ([(var ...) #'(~? (var ...) ())])
+       #'(begin
+           (define names (list 'var ...))
+           (define nsa (~? ns-anchor #false))
+           (define ns (and nsa (namespace-anchor->namespace nsa)))
+           (when (~? readline? #false) (eval '(require readline) ns))
+           (when ns
+             (namespace-set-variable-value! 'var var #false ns) ...
+             (void)) ; to avoid bad 'when' form if no variable
+           (define the-prompt (~? prompt "> "))
+           (let loop ()
+             (with-handlers ([exn:fail? (λ (e)
+                                          (displayln (exn-message e))
+                                          (loop))])
+               (define cmd (~? command #false))
+               (when (and cmd (not (string? cmd)))
+                 (error "command must be a string"))
+               (unless cmd (display the-prompt))
+               (define cmd-str (or cmd (read-line)))
+               (unless (eof-object? cmd-str)
+                 (define cmd (with-input-from-string (string-append "(" cmd-str ")") read))
+                 (match cmd
+                   ['() (void)]
+                   ['(help)
+                    (unless (empty? names)
+                      (printf "Available variables: ~a\n" names))
+                    (displayln "Other commands:")
+                    (parameterize ([print-reader-abbreviations #true]
+                                   [print-as-expression #false])
+                      (void)
+                      (begin
+                        (displayln (string-append "  " (apply ~v '(pat ...) #:separator " ")))
+                        (displayln (string-append "    " help-string)))
+                      ...)
+                    (when ns
+                      (displayln "  eval expr")
+                      (displayln
+                       "    Evaluate expr in a namespace that is local to this interaction loop."))
+                    (loop)]
+                   [(list 'eval cmd)
+                    (if ns
+                        (call-with-values (λ () (eval cmd ns))
+                                          (λ l (if (= 1 (length l))
+                                                   (unless (void? (first l))
+                                                     (displayln (first l)))
+                                                   (for-each displayln l))))
+                        (displayln "Cannot use eval without a namespace-anchor"))
+                    (loop)]
+                   ['(var) (println var) (loop)] ...
+                   [(list 'var val) (set! var val) (loop)] ...
+                   [(list pat ...) body ... (loop)] ...
+                   [else (printf "Unknown command: ~a\n" cmd)
+                         (loop)]))))))]))
+
+(module+ drracket
+  (define-namespace-anchor ns-anchor) ; optional, to use the eval command
+
+  (let ([x 3] [y 'a])
+    (interact
+     #:prompt ">> "
+     #:namespace-anchor ns-anchor
+     #:variables (x y)
+     ;; All patterns must be of the form (list ....)
+     [(list 'yo) "prints yo" (displayln "yo")]
+     [(list 'yo (? number? n)) "prints multiple yos" (displayln (make-list n 'yo))])))