;; -*- scheme -*- #| Written by Eli Barzilay This file provides some useful facilities for interactive use of racket. It is best used as (or loaded from) a ".racketrc" file or "racketrc.ss" on Windows (evaluate `(find-system-path 'init-file)' to know where this file is on your system). Some highlights are: * Defines a 'debug module (can also be used as '* for brevity) that provides a few useful utilities for use in code while debugging: > (eeprintf fmt arg ...) Like `eprintf', but uses the original error port. Useful for printouts from code where `current-error-port' might be redirected. > (warn ...) Same interface as `error', but only prints the error message. > *** > (*** value) > (*** fmt args ...) This is macro that is useful for debugging printouts: the first form prints (on stderr) the source file and line number, the second also prints a value (and returns it), and the third uses a format string. For example, to see where a problem happens in a function, you spread ***s around, and the printout will show a trace of location (and possibly values). > (define*** (name args ...) ...) Macro that defines `name' as a traced function. (The idea is that you append a `***' to `define' for functions that you want to trace.) This is a cheap hack: it kills tail-recursiveness. The `***' is supposed to be a token that stands out textually in *your* code while you're debugging it, so it is customizable: set the `MZ_DEBUGGER_TOKEN' environment variable to whatever you want -- for example, set it to "@@" and you'll get bindings for `@@' and `define@@' instead of the above. The following REPL functionality is used only when the REPL is actually used, so non-interactive code is not affected (but note that .racketrc is not read in such cases anyway). * Uses the readline library if you're running in an xterm (and if it's present). (Again, triggered by repl interaction.) * Toplevel commands, in the form of ",cmd". These commands make it convenient to perform many otherwise-tedious operations in Racket. Use ",help" for a list of available commands and for help on a specific command. Note that some of these commands look similar to existing racket functionality, but are extended. In addition, these commands are always available -- for example, ",doc" is similar to `help' (from racket/init), but can be used even when you're in a language without that binding. Most commands consume arguments, ",h" will tell you about the relevant syntax. Note that arguments usually do not need to be quoted, for example ",cd .." goes up a directory; this is also relevant for commands that consume an expression, a require specification, a symbol, etc. Some highlights: - ,cd ,pwd ,sh ,ls ,git etc: convenient shell-related functionality - ,time: improved timing output, and can run an expression multiple times - ,require: if you use it with an argument that looks like a file, it will do the right thing to require that file - ,syntax: not only is this a poor man's syntax stepper -- it can actually use the real syntax stepper - ,apropos: search available bindings; ,describe: tell you how you got some binding or describe a module's imports/exports; ,doc: browse the racket documentation for a binding - ,require-reloadable ,reload ,enter: require a module so it can be reloaded later, and a convenient command for `enter!' (with the prompt showing you where you are) - ,trace ,untrace ,errortrace ,profile: convenient commands for those features you always knew how to use but was lazy to actually type what's needed - ,coverage and ,execution-counts: annotate code with execution information via errortrace or a sandbox - ,switch-namespace: easily switch between toplevel namespaces * Previous toplevel results are accessible: `^' is the last result, `^^' is the second to last (or the second value of the last multiple-value result) etc. This is done in a way that is trying to avoid clobbering a binding that you already have for these identifiers. |# ;; ============================================================================ ;; convenient debugging utilities (module debug racket/base (require racket/list (for-syntax racket/base)) ;; either change this line, or set the "MZ_DEBUGGER_TOKEN" environment var (define-for-syntax debug-token (or (getenv "MZ_DEBUGGER_TOKEN") "***")) (provide eeprintf warn) (define eeprintf (let ([e (current-error-port)]) (lambda (fmt . args) (apply fprintf e fmt args)))) (define (warn who . fmt/args) (parameterize ([current-output-port (current-error-port)]) (display who) (when (pair? fmt/args) (if (symbol? who) (begin (display ": ") (apply printf fmt/args)) (for ([x fmt/args]) (printf " ~s" x)))) (newline))) (define token (let-syntax ([token (lambda (stx) (datum->syntax stx debug-token stx))]) token)) (define-syntax (define-debug-syntax stx) (syntax-case stx () [(_ (pfx stx) body ...) #'(define-debug-syntax pfx (lambda (stx) body ...))] [(_ pfx expr) (identifier? #'pfx) (with-syntax ([id (datum->syntax #'pfx (string->symbol (string-append (symbol->string (syntax-e #'pfx)) debug-token)) #'pfx)]) #'(begin (provide id) (define-syntax id expr)))])) (define-debug-syntax (|| stx) (syntax-case stx () [(_ fmt arg ...) (string? (syntax-e #'fmt)) #`(dprint '#,(syntax-source stx) '#,(syntax-position stx) '#,(syntax-line stx) fmt (list (lambda () arg) ...) '(arg ...))] [(_ arg ...) #`(dprint '#,(syntax-source stx) '#,(syntax-position stx) '#,(syntax-line stx) #f (list (lambda () arg) ...) '(arg ...))] [else #`(dprint '#,(syntax-source stx) '#,(syntax-position stx) '#,(syntax-line stx) #f '() '())])) (define-debug-syntax define (syntax-rules () [(_ (name x ...) body ...) (define (name x ...) (indent) (eprintf "{~a~a~a\n" 'name token (string-append (format " ~s" x) ...)) (let ([r (parameterize ([indentation (cons " " (indentation))]) body ...)]) (indent) (eprintf " ~a~a -> ~s}\n" 'name token r) r))])) (define indentation (make-parameter '())) (define (indent) (for-each eprintf (indentation))) (define (dprint source pos line fmt thunks exprs) (define error? #f) (define retval (void)) (define args (map (lambda (thunk) (with-handlers ([void (lambda (e) (set! error? (or error? e)) (format "ERROR(~a)" (exn-message e)))]) (let ([r (thunk)]) (set! retval r) r))) thunks)) (indent) (let* ([source (cond [(symbol? source) source] [source (regexp-replace #rx"^.*/" (if (string? source) source (format "~a" source)) "")] [else #f])] [marker (cond [(and source line) (format "~a~a:~a" token source line)] [(and source pos) (format "~a~a:#~a" token source pos)] [source (format "~a~a" token source)] [else token])] [line (if fmt (apply format fmt args) args)]) (parameterize ([current-output-port (current-error-port)]) (display marker) (unless (null? line) (display ">") (parameterize ([error-print-width 30]) (if (pair? line) (for ([x args] [expr exprs]) (display " ") (when (or (symbol? expr) (and (pair? expr) (not (memq (car expr) '(quasiquote quote))))) (printf "~e=" expr)) (write x)) (begin (display " ") (display line))))) (printf "\n"))) (if error? (raise error?) retval)) ;; An improved `time' variant with number of repetitions (provide time*) (define (time** thunk times) (define throw (if (<= times 0) (error 'time "bad count: ~e" times) (floor (* times 2/7)))) (define results #f) (define timings '()) (define (run n) (when (<= n times) (when (> times 1) (printf ";; run #~a..." n) (flush-output)) (let ([r (call-with-values (lambda () (time-apply thunk '())) list)]) (set! results (car r)) (set! timings (cons (cdr r) timings)) (when (> times 1) (printf " ->") (if (null? results) (printf " (0 values returned)") (begin (for ([r results]) (printf " ~s" r)) (newline)))) (run (add1 n))))) (collect-garbage) (collect-garbage) (collect-garbage) (run 1) (set! timings (sort timings < #:key car)) ; sort by cpu-time (set! timings (drop timings throw)) ; throw extreme bests (set! timings (take timings (- (length timings) throw))) ; and worsts (set! timings (let ([n (length timings)]) ; average (map (lambda (x) (round (/ x n))) (apply map + timings)))) (let-values ([(cpu real gc) (apply values timings)]) (when (> times 1) (printf ";; ~a runs, ~a best/worst removed, ~a left for average:\n" times throw (- times throw throw))) (printf ";; cpu time: ~sms = ~sms + ~sms gc; real time: ~sms\n" cpu (- cpu gc) gc real)) (apply values results)) (define-syntax time* (syntax-rules () [(_ n expr) (time** (lambda () expr) n)] [(_ expr) (time** (lambda () expr) 1)])) ) ;; use '* as a convenient alias (module * racket/base (require 'debug) (provide (all-from-out 'debug))) ;; ============================================================================ (module interactive racket/base ;; ---------------------------------------------------------------------------- ;; configuration (define toplevel-prompt (make-parameter #"-")) ; when not in a module (define saved-values-number (make-parameter 5)) (define saved-values-char (make-parameter #\^)) ;; you may want to disable inlining to allow redefinitions ;; (compile-enforce-module-constants #f) ;; ---------------------------------------------------------------------------- (require racket/string racket/list racket/function racket/match racket/promise 'debug) (provide (all-from-out 'debug)) ; can't specify the names of debug tokens (define autoloaded-specs (make-hasheq)) (define (autoloaded? sym) (hash-ref autoloaded-specs sym #f)) (define-syntax-rule (defautoload id libspec) (define (id . args) (set! id (dynamic-require 'libspec 'id)) (hash-set! autoloaded-specs 'libspec #t) (hash-set! autoloaded-specs 'id #t) (apply id args))) (defautoload system racket/system) (defautoload path->name setup/private/path-utils) (defautoload find-relative-path racket/path) ;; ---------------------------------------------------------------------------- ;; toplevel "," commands management (define-struct command (names blurb desc handler)) (define commands (make-hasheq)) (define commands-list '()) ; for help displays, in definition order (define current-command (make-parameter #f)) (define (register-command! names blurb desc handler) (let* ([names (if (list? names) names (list names))] [cmd (make-command names blurb desc handler)]) (for ([n names]) (if (hash-ref commands n #f) (error 'defcommand "duplicate command name: ~s" n) (hash-set! commands n cmd))) (set! commands-list (cons cmd commands-list)))) (define-syntax-rule (defcommand cmd+aliases blurb (desc ...) body0 body ...) (register-command! `cmd+aliases `blurb `(desc ...) (lambda () body0 body ...))) (define (cmderror fmt #:default-who [dwho #f] . args) (let ([cmd (current-command)]) (raise-user-error (or (and cmd (string->symbol (format ",~a" cmd))) dwho '???) (apply format fmt args)))) ;; convenient require spec (define last-require-modspecs #f) ; last arg to ,require (define (process-reqspec spec0) ;; translates names that are existing paths to proper `file' specs (let* ([spec (if (syntax? spec0) (syntax->datum spec0) spec0)] [spec (and (symbol? spec) (symbol->string spec))] [spec (and spec (path->string (expand-user-path spec)))] [spec (and spec (file-exists? spec) spec)] [spec (and spec (if (absolute-path? spec) `(file ,spec) spec))] [spec (and spec (if (syntax? spec0) (datum->syntax spec0 spec spec0) spec))]) (or spec spec0))) (define (getarg kind0 [flag #f]) (unless (memq flag '(#f opt list list+)) (error 'getarg "unknown flag: ~e" flag)) (define (missing) (cmderror #:default-who 'getarg "missing ~a argument" kind0)) (define (translate arg convert) (and arg (if (list? arg) (map convert arg) (convert arg)))) (define (get read) (let loop ([flag flag]) (case flag [(#f) (let ([x (read)]) (if (eof-object? x) (missing) x))] [(opt) (and (not (memq (peek-char) '(#\newline #\return))) ; imm. EOLs (not (regexp-try-match #rx"^[ \t]*?\r?\n" (current-input-port))) (loop #f))] ;; a list means everything on the current line [(list) (parameterize ([current-input-port (open-input-string (read-line))]) (let loop ([r '()]) (let ([x (read)]) (if (eof-object? x) (reverse r) (loop (cons x r))))))] [(list+) (let ([l (loop 'list)]) (if (null? l) (missing) l))]))) (define (read-string-arg) (let ([m (regexp-match #px#"\\S+" (current-input-port))]) (if m (bytes->string/utf-8 (car m)) eof))) (define (get-modspecs spec/s) (cond [(memq flag '(list list+)) (if (pair? spec/s) (begin (set! last-require-modspecs spec/s) spec/s) (or last-require-modspecs (cmderror #:default-who 'getarg "no require spec given, and no previous spec")))] [spec/s ; set last (set! last-require-modspecs (list spec/s)) spec/s] [(eq? flag 'opt) spec/s] ; optional => return ;; otherwise try to get it from the lasts [(and last-require-modspecs (= 1 (length last-require-modspecs))) (car last-require-modspecs)] [else (cmderror #:default-who 'getarg "no require spec given and no single spec used last")])) (let loop ([kind kind0]) (case kind [(line) (regexp-replace* #px"^\\s+|\\s+$" (get read-line) "")] [(string) (get read-string-arg)] [(path) (translate (loop 'string) expand-user-path)] [(sexpr) (get read)] [(syntax) (translate (get read-syntax) namespace-syntax-introduce)] [(modspec) (get-modspecs (translate (loop 'syntax) process-reqspec))] [else (error 'getarg "unknown arg kind: ~e" kind)]))) (define (run-command command) (with-handlers ([void (lambda (e) (if (exn? e) (eprintf "~a\n" (exn-message e)) (eprintf "~s\n" e)))]) (let ([cmd (hash-ref commands command #f)]) (if cmd (parameterize ([current-command command]) ((command-handler cmd))) (eprintf "Unknown command: ~s\n" command))))) ;; like `eval', but accepts any number of expressions (define (eval* . exprs) (let loop ([r (list (void))] [exprs exprs]) (if (null? exprs) (apply values r) (loop (call-with-values (lambda () (eval (car exprs))) list) (cdr exprs))))) (defcommand (help h ?) "display available commands" (> "[]" "Lists known commands and their help; use with a command name to get" "additional information for that command.") (let* ([arg (getarg 'sexpr 'opt)] [arg (match arg [(list 'unquote x) x] [_ arg])] [cmd (and arg (hash-ref commands arg (lambda () (printf "*** Unknown command: `~s'\n" arg) #f)))]) (define (show-cmd cmd) (let* ([names (command-names cmd)] [name (car names)] [aliases (cdr names)] [blurb (command-blurb cmd)] [header (format " ~a~a:" name (if (pair? aliases) (format " ~a" aliases) ""))] [blurb (if (and (string? blurb) (< 70 (+ (string-length blurb) (string-length header)))) (list blurb) blurb)]) (if (list? blurb) (begin (printf "~a\n" header) (for ([h blurb]) (printf " ~a\n" h))) (printf "~a ~a\n" header blurb)))) (if cmd (let ([desc (command-desc cmd)]) (show-cmd cmd) (let loop ([ds (if (list? desc) desc (list desc))]) (when (pair? ds) (loop (if (eq? (car ds) '>) (begin (printf " > ,~a ~a\n" arg (cadr ds)) (cddr ds)) (begin (printf " ~a\n" (car ds)) (cdr ds))))))) (begin (printf "Available commands:\n") (for-each show-cmd (reverse commands-list)))))) ;; ---------------------------------------------------------------------------- ;; generic commands (defcommand (exit quit ex) "Exit Racket" (> "[]" "Optional argument specifies exit code.") (cond [(getarg 'sexpr 'opt) => exit] [else (exit)])) (define last-2dirs (let ([d (current-directory)]) (cons d d))) (defcommand cd "change the current directory" (> "[]" "Sets `current-directory'; expands user paths. With no arguments, goes" "to your home directory. An argument of `-' indicates the previous" "directory.") (let* ([arg (or (getarg 'path 'opt) (find-system-path 'home-dir))] [arg (if (equal? arg (string->path "-")) (cdr last-2dirs) arg)]) (if (directory-exists? arg) (current-directory arg) (warn 'cd "no such directory: ~a" arg)) ;; no need to report where we are -- the prompt handler will do that )) (defcommand pwd "read the current directory" (> "" "Displays the value of `current-directory'.") (printf ";; now in ~a\n" (current-directory))) (defcommand (shell sh ls cp mv rm md rd git svn) "run a shell command" (> "" "`sh' runs a shell command (via `system'), the aliases run a few useful" "unix commands. (Note: `ls' has some default arguments set.)") (let* ([arg (getarg 'line)] [arg (if (equal? "" arg) #f arg)] [cmd (current-command)]) (case cmd [(ls) (set! cmd "ls -F")] [(shell) (set! cmd 'sh)]) (let ([cmd (cond [(eq? 'sh cmd) #f] [(symbol? cmd) (symbol->string cmd)] [else cmd])]) (system (cond [(and (not cmd) (not arg)) (getenv "SHELL")] [(not cmd) arg] [(not arg) cmd] [else (string-append cmd " " arg)]))))) ;; ---------------------------------------------------------------------------- ;; binding related commands (defcommand (apropos ap) "look for a binding" (> " ..." "An argument can be used to restrict matches shown (it is a simple" "string search, no regexps).") (let* ([arg (map (compose regexp regexp-quote) (getarg 'string 'list))] [arg (and (pair? arg) (lambda (str) (andmap (lambda (rx) (regexp-match? rx str)) arg)))] [syms (map (lambda (sym) (cons sym (symbol->string sym))) (namespace-mapped-symbols))] [syms (if arg (filter (compose arg cdr) syms) syms)] [syms (sort syms string "[] " "For a bound identifier, describe where is it coming from; for a known" "module, describe its imports and exports. You can use this command with" "several identifiers. You can provide a numeric argument first to use a" "different phase identifier.") (define ids/mods (getarg 'syntax 'list)) (define level 0) (when (and (pair? ids/mods) (number? (syntax-e (car ids/mods)))) (set! level (syntax-e (car ids/mods))) (set! ids/mods (cdr ids/mods))) (for ([id/mod (in-list ids/mods)]) (define dtm (syntax->datum id/mod)) (define mod (with-handlers ([exn:fail? (lambda (_) #f)]) ((current-module-name-resolver) dtm #f #f))) (define bind (cond [(identifier? id/mod) (identifier-binding id/mod level)] [mod #f] [else (cmderror "not an identifier or a known module: ~s" dtm)])) (define bind? (or bind (not mod))) (when bind? (describe-binding dtm bind)) (when mod (describe-module dtm mod bind?)))) (define (describe-binding sym b) (cond [(not b) (printf ";; `~s' is a toplevel (or unbound) identifier\n" sym)] [(eq? b 'lexical) (printf ";; `~s' is a lexical identifier\n" sym)] [(or (not (list? b)) (not (= 7 (length b)))) (cmderror "*** internal error, racket changed ***")] [else (define-values [src-mod src-id nominal-src-mod nominal-src-id src-phase import-phase nominal-export-phase] (apply values b)) (define (mpi* mpi) (define p (resolved-module-path-name (module-path-index-resolve mpi))) (if (path? p) (path->name p) p)) (set! src-mod (mpi* src-mod)) (set! nominal-src-mod (mpi* nominal-src-mod)) (for-each display `(";; `",sym"' is a bound identifier,\n" ";; defined" ,(case src-phase [(0) ""] [(1) "-for-syntax"] [else (cmderror "internal error")]) " in \"",src-mod"\"" ,(if (not (eq? sym src-id)) (format " as `~s'" src-id) "") "\n" ";; required" ,(case import-phase [(0) ""] [(1) "-for-syntax"] [else (cmderror "internal error")]) " " ,(if (equal? src-mod nominal-src-mod) "directly" (format "through \"~a\"~a" nominal-src-mod (if (not (eq? sym nominal-src-id)) (format " where it is defined as `~s'" nominal-src-id) ""))) "\n" ,(case nominal-export-phase [(0) ""] [(1) (format ";; (exported-for-syntax)\n")] [else (cmderror "internal error")])))])) (define (describe-module sexpr m also?) (for-each display `(";; ",(if also? "Also, " "")"`",sexpr"' is a module,\n" ";; located at ",(path->name (resolved-module-path-name m))"\n"))) (defcommand doc "browse the racket documentation" (> " ..." "Uses Racket's `help' to browse the documentation. (Note that this can be" "used even in languages that don't have the `help' binding.)") (let ([spec (getarg 'syntax 'list)]) (namespace-require 'racket/help) (make-new-inputs #`(#,(namespace-symbol->identifier 'help) #,@spec)))) ;; ---------------------------------------------------------------------------- ;; require/load commands (defcommand (require req r) "require a module" (> " ..." "The arguments are usually passed to `require', unless an argument" "specifies an existing filename -- in that case, it's like using a" "\"string\" or a (file \"...\") in `require'. (Note: this does not" "work in subforms.)") (make-new-inputs #`(require #,@(getarg 'modspec 'list)))) (define rr-modules (make-hash)) ; hash to remember reloadable modules (defcommand (require-reloadable reqr rr) "require a module, make it reloadable" (> " ..." "This is the same as ,require but the module is required in a way that" "makes it possible to reload later, or if it was already loaded then it" "is reloaded. This is done by setting `compile-enforce-module-constants'" "to #f, which usually makes code run slower (the compiler is not allowed" "to inline things as usual).") (let ([prev-enforce (eval #`(compile-enforce-module-constants))]) (apply make-new-inputs `(,(lambda () (compile-enforce-module-constants #f)) ,@(for/list ([spec (in-list (getarg 'modspec 'list))]) (define datum (syntax->datum spec)) (define resolved ((current-module-name-resolver) datum #f #f #f)) (define path (resolved-module-path-name resolved)) (if (hash-ref rr-modules resolved #f) ;; reload (lambda () (printf ";; reloading ~a\n" path) (parameterize ([current-module-declare-name resolved]) (load/use-compiled path))) ;; require (begin (hash-set! rr-modules resolved #t) (lambda () (printf ";; requiring ~a\n" path) (make-new-inputs #`(require #,spec)))))) ,(lambda () (compile-enforce-module-constants prev-enforce)))))) (define (harmless-enter! stxs) (namespace-require 'racket/enter) (make-new-inputs #`(#,(namespace-symbol->identifier 'enter!) #,@stxs))) (defcommand (enter en) "require a module and go into its namespace" (> "[] [noisy?]" "Uses `enter!' to go into the module's namespace; the module name is" "optional, without it you go back to the toplevel. A module name can" "specify an existing file as with the ,require command. (Note that this" "can be used even in languages that don't have the `enter!' binding.)") (harmless-enter! (getarg 'modspec 'list))) (defcommand (toplevel top) "go back to the toplevel" (> "" "Go back to the toplevel, same as ,enter with no arguments.") (harmless-enter! '(#f))) (defcommand (load ld) "load a file" (> " ..." "Uses `load' to load the specified file(s)") (apply make-new-inputs (map (lambda (name) #`(load #,name)) (getarg 'path 'list)))) ;; ---------------------------------------------------------------------------- ;; debugging commands ;; not useful: catches only escape continuations ;; (define last-break-exn #f) ;; (defcommand (continue cont) "continue from a break" ;; (> "" ;; "Continue running from the last break.") ;; (if last-break-exn ;; ((exn:break-continuation last-break-exn)) ;; (cmderror 'continue "no break exception to continue from"))) (defcommand time "time an expression" (> "[] " "Times execution of an expression, similar to `time' but prints a" "little easier to read information. You can provide an initial number" "that specifies how many times to run the expression -- in this case," "the expression will be executed that many times, extreme results are" "be removed (top and bottom 2/7ths), and the remaining results will" "be averaged. Two garbage collections are triggered before each run;" "the resulting value(s) are from the last run.") (let* ([x (getarg 'syntax)] [n (and (integer? (syntax-e x)) x)] [expr (if n (getarg 'syntax) x)]) (make-new-inputs #`(time* #,(or n #'1) #,expr)))) (defcommand (trace tr) "trace a function" (> " ..." "Traces a function (or functions), using the racket/trace library.") (make-new-inputs #`(require racket/trace) `(trace ,@(getarg 'syntax 'list)))) (defcommand (untrace untr) "untrace a function" (> " ..." "Untraces functions that were traced with ,trace.") (make-new-inputs #`(require racket/trace) `(untrace ,@(getarg 'syntax 'list)))) (defautoload profiling-enabled errortrace) (defautoload instrumenting-enabled errortrace) (defautoload clear-profile-results errortrace) (defautoload output-profile-results errortrace) (defautoload execute-counts-enabled errortrace) (defautoload annotate-executed-file errortrace) (defcommand (errortrace errt inst) "errortrace instrumentation control" (> "[]" "An argument is used to perform a specific operation:" " + : turn errortrace instrumentation on (effective only for code that" " is evaluated from now on)" " - : turn it off (also only for future evaluations)" " ? : show status without changing it" "With no arguments, toggles instrumentation.") (case (getarg 'sexpr 'opt) [(#f) (if (autoloaded? 'errortrace) (instrumenting-enabled (not (instrumenting-enabled))) (instrumenting-enabled #t))] [(-) (when (autoloaded? 'errortrace) (instrumenting-enabled #f))] [(+) (instrumenting-enabled #t)] [(?) (void)] [else (cmderror "unknown subcommand")]) (if (autoloaded? 'errortrace) (printf ";; errortrace instrumentation is ~a\n" (if (instrumenting-enabled) "on" "off")) (printf ";; errortrace not loaded\n"))) (defcommand (profile prof) "profiler control" (> "[ ...]" "An argument is used to perform a specific operation:" " + : turn the profiler on (effective only for code that is evaluated" " from now on)" " - : turn the profiler off (also only for future evaluations)" " * : show profiling results by time" " # : show profiling results by counts" " ! : clear profiling results" "Multiple commands can be combined, for example \",prof *!-\" will show" "profiler results, clear them, and turn it off." "With no arguments, turns the profiler on (if it's off), shows results" "unless it was off, and clears them." "Note: using *any* of these turns errortrace instrumentation on, even" "a \",prof -\". Use the ,errortrace command to turn it off.") (instrumenting-enabled #t) (for ([cmd (cond [(getarg 'string 'opt) => (lambda (str) (regexp-replace* #rx"[ \t]+" str ""))] [else '(#f)])]) (case cmd [(#\+) (profiling-enabled #t) (printf ";; profiling is on\n")] [(#\-) (profiling-enabled #f) (printf ";; profiling is off\n")] [(#\*) (output-profile-results #f #t)] [(#\#) (output-profile-results #f #f)] [(#\!) (clear-profile-results) (printf ";; profiling data cleared\n")] [(#f) (if (profiling-enabled) (begin (output-profile-results #f #t) (clear-profile-results) (printf ";; profiling data cleared\n")) (begin (profiling-enabled #t) (printf ";; profiling is on\n")))] [(#\space) (void)] [else (cmderror "unknown subcommand")]))) (defcommand execution-counts "execution counts" (> " ..." "Enable errortrace instrumentation for coverage, require the file(s)," "display the results, disables coverage, and disables instrumentation if" "it wasn't previously turned on.") (let ([files (getarg 'path 'list)] [inst? (and (autoloaded? 'errortrace) (instrumenting-enabled))]) (make-new-inputs (lambda () (instrumenting-enabled #t) (execute-counts-enabled #t)) #`(require #,@(map (lambda (file) `(file ,(path->string file))) files)) (lambda () (for ([file (in-list files)]) (annotate-executed-file file " 123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"))) (lambda () (execute-counts-enabled #f) (unless inst? (instrumenting-enabled #f)))))) (defautoload make-module-evaluator racket/sandbox) (defautoload sandbox-coverage-enabled racket/sandbox) (defautoload call-with-trusted-sandbox-configuration racket/sandbox) (defautoload get-uncovered-expressions racket/sandbox) (defautoload kill-evaluator racket/sandbox) (defcommand (coverage cover) "coverage information via a sandbox" (> "" "Runs the given file in a (trusted) sandbox, and annotates it with" "uncovered expression information.") (let ([file (getarg 'path)]) (sandbox-coverage-enabled) ; autoload it (parameterize ([sandbox-coverage-enabled #t]) (define e (call-with-trusted-sandbox-configuration (lambda () (make-module-evaluator file)))) (define uncovered (map (lambda (x) (let ([p (sub1 (syntax-position x))]) (cons p (+ p (syntax-span x))))) (get-uncovered-expressions e #t))) (kill-evaluator e) (call-with-input-file file (lambda (inp) ;; this is a naive and inefficient solution, could be made efficient ;; using `mzlib/integer-set' (let loop () (let* ([start (file-position inp)] [line (read-line inp)] [len (and (string? line) (string-length line))] [end (and len (+ len start))] [indent (and len (regexp-match-positions #px"\\S" line))] [indent (and indent (caar indent))]) (when len (displayln line) (when indent (string-fill! line #\space) (for ([u (in-list uncovered)]) (when (and ((car u) . < . end) ((cdr u) . > . indent)) (for ([i (in-range (max (- (car u) start) indent) (min (- (cdr u) start) len))]) (string-set! line i #\^)))) (displayln (regexp-replace #rx" +$" line ""))) (loop))))))))) ;; ---------------------------------------------------------------------------- ;; namespace switching (define default-namespace-name '*) (define current-namespace-name default-namespace-name) (define namespaces (let* ([r (namespace-symbol->identifier '#%top-interaction)] [r (identifier-binding r)] [r (and r (caddr r))] [r (and r (resolved-module-path-name (module-path-index-resolve r)))] [t (make-hasheq)]) (hash-set! t current-namespace-name (cons (current-namespace) r)) t)) (defcommand (switch-namespace switch) "switch to a different repl namespace" (> "[] [! []]" "Switch to the namespace, creating it if needed. The of a" "namespace is a symbol or an integer where a `*' indicates the initial one;" "it is only used to identify namespaces for this command (so don't confuse" "it with racket bindings). A new namespace is initialized using the name" "of the namespace (if it's require-able), or using the same initial module" "that was used for the current namespace. If `! ' is used, it" "indicates that a new namespace will be created even if it exists, using" "`' as the initial module, and if just `!' is used, then this happens" "with the existing namespace's init or with the current one's." "A few examples:" " ,switch ! reset the current namespace" " ,switch ! racket reset it using the `racket' language" " ,switch r5rs switch to a new `r5rs' namespace" " ,switch foo switch to `foo', creating it if it doesn't exist" " ,switch foo ! racket switch to newly made `foo', even if it exists" " ,switch foo ! same, but using the same as it was created" " with, or same as the current if it's new" "(Note that you can use `^' etc to communicate values between namespaces.)") (define-values (name force-reset? init) (match (getarg 'sexpr 'list) [(list '!) (values #f #t #f )] [(list '! init) (values #f #t init)] [(list name) (values name #f #f )] [(list name '!) (values name #t #f )] [(list name '! init) (values name #t init)] [(list) (cmderror "what do you want to do?")] [_ (cmderror "syntax error, see ,help switch-namespace")])) (unless (or (not name) (symbol? name) (fixnum? name)) (cmderror "bad namespace name, must be symbol or fixnum")) (define old-namespace (current-namespace)) (define (is-require-able? name) (with-handlers ([void (lambda (_) #f)]) ;; name is never a string => no need to set the current directory (file-exists? (resolved-module-path-name ((current-module-name-resolver) name #f #f #f))))) ;; if there's an , then it must be forced (let* ([name (or name current-namespace-name)] [init (cond [init] [(or force-reset? (not (hash-ref namespaces name #f))) (cdr (or (hash-ref namespaces name #f) (and (is-require-able? name) (cons #f name)) (hash-ref namespaces current-namespace-name #f) ;; just in case (hash-ref namespaces default-namespace-name #f)))] [else #f])]) (when init (printf "*** ~a `~s' namespace with ~s ***\n" (if (hash-ref namespaces name #f) "Resetting the" "Initializing a new") name (if (path? init) (path->name init) init)) (current-namespace (make-base-empty-namespace)) (namespace-require init) (hash-set! namespaces name (cons (current-namespace) init)))) (when (and name (not (eq? name current-namespace-name))) (printf "*** switching to the `~s' namespace ***\n" name) (let ([x (hash-ref namespaces current-namespace-name)]) (unless (eq? (car x) old-namespace) (printf "*** (note: saving current namespace for `~s')\n" current-namespace-name) (hash-set! namespaces current-namespace-name (cons old-namespace (cdr x))))) (set! current-namespace-name name) (current-namespace (car (hash-ref namespaces name))))) ;; ---------------------------------------------------------------------------- ;; syntax commands (define current-syntax #f) (define last-syntax #f) ; set by the repl at the bottom (defautoload pretty-write racket/pretty) (defautoload expand/step-text macro-debugger/stepper-text) (define expand-pred (delay (let ([base-stxs ;; all ids that are bound to a syntax in racket/base (let ([ns (make-base-namespace)] [tag "tag"]) (parameterize ([current-namespace ns]) (filter-map (lambda (s) (and (eq? tag (namespace-variable-value s #t (lambda () tag))) (namespace-symbol->identifier s))) (namespace-mapped-symbols))))]) (lambda (id) (not (ormap (lambda (s) (free-identifier=? id s)) base-stxs)))))) (defcommand (syntax stx st) "set syntax object to inspect, and control it" (> "[] [ ...]" "With no arguments, will show the previously set (or expande) syntax" "additional arguments serve as an operation to perform:" "- `^' sets the syntax from the last expression evaluated" "- `+' will `expand-once' the syntax and show the result" "- `!' will `expand' the syntax and show the result" "- `*' will use the syntax stepper to show expansion steps, leaving" " macros from racket/base intact (does not change the currently" " set syntax)" "- `**' similar to `*', but expanding everything") (for ([stx (getarg 'syntax 'list)]) (define (show/set label stx) (printf "~a\n" label) (set! current-syntax stx) (pretty-write (syntax->datum stx))) (define (cur) (or current-syntax (cmderror "no syntax set yet"))) (case (and stx (if (identifier? stx) (syntax-e stx) '--none--)) [(#f) (show/set "current syntax:" (cur))] [(^) (if last-syntax (show/set "using last expression:" last-syntax) (cmderror "no expression entered yet"))] [(+) (show/set "expand-once ->" (expand-once (cur)))] [(!) (show/set "expand ->" (expand (cur)))] [(*) (printf "stepper:\n") (expand/step-text (cur) (force expand-pred))] [(**) (printf "stepper:\n") (expand/step-text (cur))] [else (if (syntax? stx) (begin (printf "syntax set\n") (set! current-syntax stx)) (cmderror "internal error ~e ~e" stx (syntax? stx)))]))) ;; ---------------------------------------------------------------------------- ;; meta evaluation hook (define-namespace-anchor anchor) (defcommand meta "meta-evaluation" (> "" "Evaluate the given expression where bindings are taken from the" "interactive module. This is convenient when you're in a namespace that" "does not have a specific binding -- for example, you might be using a" "language that doesn't have `current-namespace', so to get it, you can use" "`,eval (current-namespace)'. The evaluation happens in the repl namespace" "as usual, only the bindings are taken from the interactive module -- so" "you can use `^' to refer to the result of such an evaluation." "Note that you still need basic bindings like `#%top-interaction' in your" "language, and there are some things that will still not work.") (make-new-inputs (datum->syntax #'interactive (getarg 'sexpr)))) ;; ---------------------------------------------------------------------------- ;; dynamic log output control (define current-log-receiver-thread #f) (define global-logger (current-logger)) (defcommand log "control log output" (> "" "Starts (or stops) logging events at the given level. The level should be" "one of the valid racket logging levels, or #f for no logging. For" "convenience, the level can also be #t (maximum logging) or an integer" "(with 0 for no logging, and larger numbers for more logging output).") (define levels '(#f fatal error warning info debug)) (define level (let ([l (getarg 'sexpr)]) (cond [(memq l levels) l] [(memq l '(#f none -)) #f] [(memq l '(#t all +)) (last levels)] [(not (integer? l)) (cmderror "bad level, expecting one of: ~s" levels)] [(<= l 0) #f] [(< l (length levels)) (list-ref levels l)] [else (last levels)]))) (when current-log-receiver-thread (kill-thread current-log-receiver-thread)) (when level (let ([r (make-log-receiver global-logger level)]) (set! current-log-receiver-thread (thread (lambda () (let loop () (match (sync r) [(vector l m v) (printf ";; [~a] ~a~a\n" l m (if v (format " ~.s" v) "")) (flush-output)]) (loop)))))))) ;; ---------------------------------------------------------------------------- ;; eval hook that keep track of recent evaluation results ;; saved interaction values (define saved-values '()) (define (save-values! xs) (let ([xs (filter (negate void?) xs)]) ; do not save void values (unless (null? xs) ;; `^' is always last value, `^^' is 2nd-to-last or the second value of ;; the last interaction (set! saved-values (append xs saved-values)) (let ([n (saved-values-number)]) (when (< n (length saved-values)) (set! saved-values (take saved-values n))))))) ;; make saved values available through bindings, but do this in a way that ;; doesn't interfere with users using these binders in some way -- set only ids ;; that were void, and restore them to void afterwards (define last-saved-values-state #f) (define last-saved-names #f) (define (saved-names) (unless (equal? last-saved-values-state (cons (saved-values-number) (saved-values-char))) (set! last-saved-names (for/list ([i (in-range (saved-values-number))]) (string->symbol (make-string (add1 i) (saved-values-char))))) (set! last-saved-values-state (cons (saved-values-number) (saved-values-char)))) last-saved-names) (define (with-saved-values thunk) (let* ([saved-names (saved-names)] [vs (map (lambda (id) (box (namespace-variable-value id #f void))) saved-names)] [res #f]) (dynamic-wind (lambda () (for ([id saved-names] [saved saved-values] [v vs]) ;; set only ids that are void, and remember these values (if (void? (unbox v)) (begin (namespace-set-variable-value! id saved) (set-box! v saved)) (set-box! v (void))))) (lambda () (call-with-values thunk (lambda vs (set! res vs) (apply values vs)))) (lambda () (for ([id saved-names] [v vs]) ;; restore the names to void so we can set them next time (when (and (not (void? (unbox v))) ; restore if we set this id above (eq? (unbox v) ; and if it didn't change (namespace-variable-value id #f void))) (namespace-set-variable-value! id (void)))) (when res (save-values! res)))))) (define orig-eval (current-eval)) (define (new-eval expr) ;; not useful: catches only escape continuations ;; (with-handlers ;; ([exn:break? (lambda (e) (set! last-break-exn e) (raise e))]) ;; ) (with-saved-values (lambda () (orig-eval expr)))) (current-eval new-eval) ;; ---------------------------------------------------------------------------- ;; capture ",..." and run the commands, use readline/rep when possible ;; used to signal a result from a command that is a list of expressions to ;; evaluate or a thunks to call (define (make-new-inputs . stxs/thunks) (cons make-new-inputs stxs/thunks)) (define (new-inputs x) (and (pair? x) (eq? make-new-inputs (car x)) (cdr x))) (define namespace->prompt (let () (define (choose-path x) (if (not (complete-path? x)) ; shouldn't happen x (let ([r (path->string (find-relative-path (current-directory) x))]) (if (< (string-length r) (string-length x)) r x)))) (define (get-prompt* path) (define x (path->string path)) (define y (path->name path)) (string->bytes/utf-8 (if (equal? x y) (format "~s" (choose-path x)) (regexp-replace #rx"(?:/main)?[.]ss$" y "")))) (define (get-prompt) (let* ([x '(#%variable-reference)] [x (datum->syntax #'here x)] [x (namespace-syntax-introduce x)] [x (let ([vs saved-values]) ; don't save this value (begin0 (eval x) (set! saved-values vs)))] [x (variable-reference->resolved-module-path x)] [x (and x (resolved-module-path-name x))] [x (and x (if (symbol? x) (format "'~s" x) (get-prompt* x)))] [x (or x (toplevel-prompt))]) (if (eq? current-namespace-name default-namespace-name) x (string->bytes/utf-8 (format "~a::~a" current-namespace-name x))))) (define last-directory #f) (define last-namespace #f) (define prompt #f) (lambda () (define curdir (current-directory)) (unless (and (equal? (current-namespace) last-namespace) (equal? curdir last-directory)) (unless (equal? (car last-2dirs) curdir) (set! last-2dirs (cons curdir (car last-2dirs))) (run-command 'pwd)) (set! prompt (get-prompt)) (set! last-namespace (current-namespace)) (set! last-directory curdir)) prompt))) (provide make-repl-reader) (define (make-repl-reader builtin-reader) (let* ([reader ; plain reader with no readline (lambda (prefix) (when prefix (display prefix)) (builtin-reader))] [term? (case (object-name (current-input-port)) [(stdin) (and (terminal-port? (current-input-port)) (regexp-match? #rx"term|rxvt|vt1[0-9][0-9]" (or (getenv "TERM") "")))] [(readline) (eprintf "Note: you already loaded readline,\n~a\n" " (interactive will do it for you when needed)") 'readline] [else #f])] [reader (if (not term?) reader ;; readline reader (parameterize ([current-prompt-read ; protect against changes below (current-prompt-read)]) (with-handlers ([exn? (lambda (e) (eprintf "Warning: no readline support (~a)\n" (exn-message e)) reader)]) (when (terminal-port? (current-output-port)) (port-count-lines! (current-output-port))) (unless (eq? 'readline term?) (dynamic-require 'readline/rep-start #f)) (let ([p (dynamic-require 'readline/pread 'current-prompt)] [r (if (eq? 'readline term?) builtin-reader (current-prompt-read))]) ;; requiring readline should have changed the current-reader, ;; if it didn't, then there was some problem (if (and (eq? r builtin-reader) (not (eq? 'readline term?))) (begin (eprintf "Warning: problems initializing readline\n") reader) ;; finally -- this is the actual readline reader (lambda (prefix) (if prefix (parameterize ([p (bytes-append prefix (p))]) (r)) (r))))))))]) (define pending-inputs '()) (define (add-pending/loop r) (let ([r (new-inputs r)]) ; returns new inputs if there are any (when r (set! pending-inputs (append r pending-inputs))) (loop))) (define (execute [inp (reader (namespace->prompt))]) (if (procedure? inp) (add-pending/loop (inp)) (syntax-case inp () [(uq cmd) (eq? 'unquote (syntax-e #'uq)) (add-pending/loop (run-command (syntax->datum #'cmd)))] [_ (begin (set! last-syntax inp) inp)]))) (define (loop) (if (pair? pending-inputs) (let ([inp (car pending-inputs)]) (set! pending-inputs (cdr pending-inputs)) (execute inp)) (execute))) loop)) ) ;; ============================================================================ ;; make this available for toplevel (require 'debug) ;; ============================================================================ ;; use the interactive module only when there is an interaction (module -init- racket/base (current-prompt-read (let ([old (current-prompt-read)]) (lambda () (current-prompt-read ;; load and create the new reader ((dynamic-require ''interactive 'make-repl-reader) old)))))) (require '-init-)