From 60f22c978fd89c1106a0aa6578baa8730de14620 Mon Sep 17 00:00:00 2001 From: Lassi Kortela Date: Fri, 27 Dec 2019 21:01:23 +0200 Subject: [PATCH] Add (chibi apropos) module --- lib/chibi/apropos.scm | 33 +++++++++++++++++++++++++++++++++ lib/chibi/apropos.sld | 4 ++++ 2 files changed, 37 insertions(+) create mode 100644 lib/chibi/apropos.scm create mode 100644 lib/chibi/apropos.sld diff --git a/lib/chibi/apropos.scm b/lib/chibi/apropos.scm new file mode 100644 index 00000000..be383309 --- /dev/null +++ b/lib/chibi/apropos.scm @@ -0,0 +1,33 @@ +(define (list-bindings env) + (let parents ((env env) (binds '())) + (if (not env) binds + (let symbols ((syms (env-exports env)) (binds binds)) + (if (null? syms) (parents (env-parent env) binds) + (symbols (cdr syms) (if (assv (car syms) binds) binds + (cons (cons (car syms) env) + binds)))))))) + +(define (apropos-list-bindings query) + (cond ((symbol? query) (set! query (symbol->string query))) + ((not (string? query)) + (error "Apropos query must be a symbol or a string"))) + (sort (filter (lambda (binding) + (string-contains (symbol->string (car binding)) query)) + (list-bindings (interaction-environment))) + (lambda (a b) (stringstring (car a)) + (symbol->string (car b)))))) + +(define (apropos-list query) (map car (apropos-list-bindings query))) + +(define (apropos-prefix sym env) + (let ((p "procedure ") + (s "syntax ") + (v "variable ")) + (guard (_ (else s)) (if (procedure? (eval sym env)) p v)))) + +(define (apropos query) + (for-each (lambda (bind) + (display (apropos-prefix (car bind) (cdr bind))) + (write (car bind)) + (newline)) + (apropos-list-bindings query))) diff --git a/lib/chibi/apropos.sld b/lib/chibi/apropos.sld new file mode 100644 index 00000000..1fb20050 --- /dev/null +++ b/lib/chibi/apropos.sld @@ -0,0 +1,4 @@ +(define-library (chibi apropos) + (export apropos apropos-list) + (import (scheme base) (chibi) (chibi string) (srfi 1) (srfi 95)) + (include "apropos.scm"))