* [PATCH] Allow user-defined meta-commands (take #2)
@ 2010-11-20 18:29 Andreas Rottmann
2010-11-20 22:33 ` Ludovic Courtès
0 siblings, 1 reply; 2+ messages in thread
From: Andreas Rottmann @ 2010-11-20 18:29 UTC (permalink / raw)
To: Guile Development
[-- Attachment #1: Type: text/plain, Size: 341 bytes --]
[ Re-sent after rebasing on current HEAD ]
Besides allowing user-defined meta-commands, this change also refactors
the meta-command machinery to split reading a command's arguments from
the procedure actually implementing it, and hence allows nesting
meta-commands. As an example of such a command, ",in" is added as a new
meta-command.
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: eval-meta-command.diff --]
[-- Type: text/x-diff, Size: 11352 bytes --]
From: Andreas Rottmann <a.rottmann@gmx.at>
Subject: Allow user-defined meta-commands
Besides allowing user-defined meta-commands, this change also refactors
the meta-command machinery to split reading a command's arguments from
the procedure actually implementing it, and hence allows nesting
meta-commands. As an example of such a command, ",in" is added as a new
meta-command.
* module/system/repl/command.scm: Export `define-meta-command'.
(*command-module*): Replaced by the hash table `*command-infos*'.
(command-info, make-command-info, command-info-procedure)
(command-info-arguments-reader): New procedures, encapsulating the
information about a meta-command.
(command-procedure): Adapted to use the `command-info' lookup
procedure.
(read-command-arguments): New auxiliary procedure invoking a command's
argument reader procedure.
(meta-command): Adapted to the split of reading arguments and
executing a command.
(add-meta-command!): New auxiliary procedure, registers a meta
command's procedure and argument reader into `*command-infos* and
`*command-table*.
(define-meta-command): Extended to allow specification of the command's
category; split the argument reader and actual command procedure.
(guile:apropos, guile:load, guile:compile-file, guile:gc): Remove these
aliases, they are unnecessary as we now use a hash table instead of the
module to store the commands.
(in): New meta-command, which evaluates an expression, or alternatively
executes another meta-command, in the context of a specific module.
* doc/ref/scheme-using.texi (Module Commands): Document the `in'
meta-command.
---
doc/ref/scheme-using.texi | 7 ++
module/system/repl/command.scm | 135 +++++++++++++++++++++++++++------------
2 files changed, 100 insertions(+), 42 deletions(-)
diff --git a/doc/ref/scheme-using.texi b/doc/ref/scheme-using.texi
index 223295c..7700cbe 100644
--- a/doc/ref/scheme-using.texi
+++ b/doc/ref/scheme-using.texi
@@ -227,6 +227,13 @@ Load a file in the current module.
List current bindings.
@end deffn
+@deffn {REPL Command} in module expression
+@deffnx {REPL Command} in module command [args ...]
+Evaluate an expression, or alternatively, execute another meta-command
+in the context of a module. For example, @samp{,in (foo bar) ,binding}
+will show the bindings in the module @code{(foo bar)}.
+@end deffn
+
@node Language Commands
@subsubsection Language Commands
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 94bb863..08f1c9e 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -41,7 +41,7 @@
#:use-module ((ice-9 pretty-print) #:select ((pretty-print . pp)))
#:use-module ((system vm inspect) #:select ((inspect . %inspect)))
#:use-module (statprof)
- #:export (meta-command))
+ #:export (meta-command define-meta-command))
\f
;;;
@@ -50,7 +50,7 @@
(define *command-table*
'((help (help h) (show) (apropos a) (describe d))
- (module (module m) (import use) (load l) (binding b))
+ (module (module m) (import use) (load l) (binding b) (in))
(language (language L))
(compile (compile c) (compile-file cc)
(disassemble x) (disassemble-file xx))
@@ -74,12 +74,22 @@
(define (group-name g) (car g))
(define (group-commands g) (cdr g))
-(define *command-module* (current-module))
+(define *command-infos* (make-hash-table))
(define (command-name c) (car c))
(define (command-abbrevs c) (cdr c))
-(define (command-procedure c) (module-ref *command-module* (command-name c)))
+(define (command-info c) (hashq-ref *command-infos* (command-name c)))
+(define (command-procedure c) (command-info-procedure (command-info c)))
(define (command-doc c) (procedure-documentation (command-procedure c)))
+(define (make-command-info proc arguments-reader)
+ (cons proc arguments-reader))
+
+(define (command-info-procedure info)
+ (car info))
+
+(define (command-info-arguments-reader info)
+ (cdr info))
+
(define (command-usage c)
(let ((doc (command-doc c)))
(substring doc 0 (string-index doc #\newline))))
@@ -148,6 +158,9 @@
(force-output)
*unspecified*)))
+(define (read-command-arguments c repl)
+ ((command-info-arguments-reader (command-info c)) repl))
+
(define (meta-command repl)
(let ((command (read-command repl)))
(cond
@@ -155,40 +168,56 @@
((not (symbol? command))
(format #t "Meta-command not a symbol: ~s~%" command))
((lookup-command command)
- => (lambda (c) ((command-procedure c) repl)))
+ => (lambda (c)
+ (and=> (read-command-arguments c repl)
+ (lambda (args) (apply (command-procedure c) repl args)))))
(else
(format #t "Unknown meta command: ~A~%" command)))))
+(define (add-meta-command! name category proc argument-reader)
+ (hashq-set! *command-infos* name (make-command-info proc argument-reader))
+ (if category
+ (let ((entry (assq category *command-table*)))
+ (if entry
+ (set-cdr! entry (append (cdr entry) (list (list name))))
+ (set! *command-table*
+ (append *command-table*
+ (list (list category (list name)))))))))
+
(define-syntax define-meta-command
(syntax-rules ()
- ((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...)
- (define (name repl)
- docstring
- (define (handle-read-error form-name key args)
- (pmatch args
- ((,subr ,msg ,args . ,rest)
- (format #t "Throw to key `~a' while reading ~@[argument `~A' of ~]command `~A':\n"
- key form-name 'name)
- (display-error #f (current-output-port) subr msg args rest))
- (else
- (format #t "Throw to key `~a' with args `~s' while reading ~@[ argument `~A' of ~]command `~A'.\n"
- key args form-name 'name)))
- (abort))
-
- (% (let* ((expression0
- (catch #t
- (lambda ()
- (repl-reader
- ""
- (lambda* (#:optional (port (current-input-port)))
- ((language-reader (repl-language repl))
- port (current-module)))))
- (lambda (k . args)
- (handle-read-error 'expression0 k args))))
- ...)
- (apply (lambda* datums
- b0 b1 ...)
+ ((_ ((name category) repl (expression0 ...) . datums) docstring b0 b1 ...)
+ (add-meta-command!
+ 'name
+ 'category
+ (lambda* (repl expression0 ... . datums)
+ docstring
+ b0 b1 ...)
+ (lambda (repl)
+ (define (handle-read-error form-name key args)
+ (pmatch args
+ ((,subr ,msg ,args . ,rest)
+ (format #t "Throw to key `~a' while reading ~@[argument `~A' of ~]command `~A':\n"
+ key form-name 'name)
+ (display-error #f (current-output-port) subr msg args rest))
+ (else
+ (format #t "Throw to key `~a' with args `~s' while reading ~@[ argument `~A' of ~]command `~A'.\n"
+ key args form-name 'name)))
+ (abort))
+ (% (let* ((expression0
(catch #t
+ (lambda ()
+ (repl-reader
+ ""
+ (lambda* (#:optional (port (current-input-port)))
+ ((language-reader (repl-language repl))
+ port (current-module)))))
+ (lambda (k . args)
+ (handle-read-error 'expression0 k args))))
+ ...)
+ (append
+ (list expression0 ...)
+ (catch #t
(lambda ()
(let ((port (open-input-string (read-line))))
(let lp ((out '()))
@@ -198,10 +227,18 @@
(lp (cons x out)))))))
(lambda (k . args)
(handle-read-error #f k args)))))
- (lambda (k) #f)))) ; the abort handler
+ (lambda (k) #f))))) ; the abort handler
+
+ ((_ ((name category) repl . datums) docstring b0 b1 ...)
+ (define-meta-command ((name category) repl () . datums)
+ docstring b0 b1 ...))
+
+ ((_ (name repl (expression0 ...) . datums) docstring b0 b1 ...)
+ (define-meta-command ((name #f) repl (expression0 ...) . datums)
+ docstring b0 b1 ...))
((_ (name repl . datums) docstring b0 b1 ...)
- (define-meta-command (name repl () . datums)
+ (define-meta-command ((name #f) repl () . datums)
docstring b0 b1 ...))))
@@ -292,11 +329,10 @@ Version information."
(display *version*)
(newline))
-(define guile:apropos apropos)
(define-meta-command (apropos repl regexp)
"apropos REGEXP
Find bindings/modules/packages."
- (guile:apropos (->string regexp)))
+ (apropos (->string regexp)))
(define-meta-command (describe repl (form))
"describe OBJ
@@ -350,11 +386,10 @@ Import modules / List those imported."
(for-each puts (map module-name (module-uses (current-module))))
(for-each use args))))
-(define guile:load load)
(define-meta-command (load repl file)
"load FILE
Load a file in the current module."
- (guile:load (->string file)))
+ (load (->string file)))
(define-meta-command (binding repl)
"binding
@@ -362,6 +397,24 @@ List current bindings."
(module-for-each (lambda (k v) (format #t "~23A ~A\n" k v))
(current-module)))
+(define-meta-command (in repl module command-or-expression . args)
+ "in MODULE COMMAND-OR-EXPRESSION
+Evaluate an expression or command in the context of module."
+ (let ((m (resolve-module module #:ensure #f)))
+ (if m
+ (pmatch command-or-expression
+ (('unquote ,command) (guard (lookup-command command))
+ (save-module-excursion
+ (lambda ()
+ (set-current-module m)
+ (apply (command-procedure (lookup-command command)) repl args))))
+ (,expression
+ (guard (null? args))
+ (repl-print repl (eval expression m)))
+ (else
+ (format #t "Invalid arguments to `in': expected a single expression or a command.\n")))
+ (format #t "No such module: ~s\n" module))))
+
\f
;;;
;;; Language commands
@@ -388,11 +441,10 @@ Generate compiled code."
(cond ((objcode? x) (guile:disassemble x))
(else (repl-print repl x)))))
-(define guile:compile-file compile-file)
(define-meta-command (compile-file repl file . opts)
"compile-file FILE
Compile a file."
- (guile:compile-file (->string file) #:opts opts))
+ (compile-file (->string file) #:opts opts))
(define (guile:disassemble x)
((@ (language assembly disassemble) disassemble) x))
@@ -775,11 +827,10 @@ Pretty-print the result(s) of evaluating EXP."
;;; System commands
;;;
-(define guile:gc gc)
(define-meta-command (gc repl)
"gc
Garbage collection."
- (guile:gc))
+ (gc))
(define-meta-command (statistics repl)
"statistics
--
tg: (1c20cf1..) t/eval-meta-command (depends on: master)
[-- Attachment #3: Type: text/plain, Size: 63 bytes --]
Regards, Rotty
--
Andreas Rottmann -- <http://rotty.yi.org/>
^ permalink raw reply related [flat|nested] 2+ messages in thread* Re: [PATCH] Allow user-defined meta-commands (take #2)
2010-11-20 18:29 [PATCH] Allow user-defined meta-commands (take #2) Andreas Rottmann
@ 2010-11-20 22:33 ` Ludovic Courtès
0 siblings, 0 replies; 2+ messages in thread
From: Ludovic Courtès @ 2010-11-20 22:33 UTC (permalink / raw)
To: guile-devel
Hi!
Andreas Rottmann <a.rottmann@gmx.at> writes:
> Besides allowing user-defined meta-commands, this change also refactors
> the meta-command machinery to split reading a command's arguments from
> the procedure actually implementing it, and hence allows nesting
> meta-commands. As an example of such a command, ",in" is added as a new
> meta-command.
Great, applied!
It would have been even better for review if each change was in its own
patch. Next time! ;-)
Thanks!
Ludo’.
^ permalink raw reply [flat|nested] 2+ messages in thread
end of thread, other threads:[~2010-11-20 22:33 UTC | newest]
Thread overview: 2+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2010-11-20 18:29 [PATCH] Allow user-defined meta-commands (take #2) Andreas Rottmann
2010-11-20 22:33 ` Ludovic Courtès
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).