#lang racket/base

;; ----------------------------------------------------------------------------
;; customization

(define toplevel-prefix       (make-parameter "-")) ; when not in a module
(define saved-values-number   (make-parameter 5))
(define saved-values-patterns (make-parameter '("^" "$~a")))
;; TODO: when there's a few more of these, make them come from the prefs

;; ----------------------------------------------------------------------------

(require racket/list racket/match scribble/text/wrap)

;; ----------------------------------------------------------------------------
;; utilities

(define home-dir (find-system-path 'home-dir))

(define-namespace-anchor anchor)
(define (here-namespace) (namespace-anchor->namespace anchor))

;; autoloads: avoid loading a ton of stuff to minimize startup penalty
(define autoloaded-specs (make-hasheq))
(define (autoloaded? sym) (hash-ref autoloaded-specs sym #f))
(define-syntax-rule (defautoload libspec id ...)
  (begin (define (id . args)
           (set! id (parameterize ([current-namespace (here-namespace)])
                      (dynamic-require 'libspec 'id)))
           (hash-set! autoloaded-specs 'libspec #t)
           (hash-set! autoloaded-specs 'id #t)
           (apply id args))
         ...))

(defautoload racket/system          system system*)
(defautoload racket/file            file->string)
(defautoload setup/path-to-relative path->relative-string/setup)
(defautoload syntax/modcode         get-module-code)
(defautoload racket/path            find-relative-path)

;; similar, but just for identifiers
(define hidden-namespace (make-base-namespace))
(define initial-namespace (current-namespace))
;; when `racket/enter' initializes, it grabs the `current-namespace' to get
;; back to -- which means it should be instantiated in a top level namespace
;; rather than in (here-namespace); but if we use `initial-namespace' we
;; essentially rely on the user to not kill `enter!' (eg, (define enter! 4)).
;; the solution is to make a `hidden-namespace' where we store these bindings,
;; then instantiate needed modules in the initial namespace and immediately
;; attach the modules to the hidden one then use it, so changes to the binding
;; in `initial-namespace' doesn't affect us.
(define (make-lazy-identifier sym from)
  (define id #f)
  (λ () (or id (begin (parameterize ([current-namespace initial-namespace])
                        (namespace-require from))
                      (parameterize ([current-namespace hidden-namespace])
                        (namespace-attach-module initial-namespace from)
                        (namespace-require from)
                        (set! id (namespace-symbol->identifier sym))
                        id)))))

;; makes it easy to use meta-tools without user-namespace contamination
(define (eval-sexpr-for-user form)
  (eval (namespace-syntax-introduce (datum->syntax #f form))))

;; If `mod' is a known module, return it; if it's a symbol and 'mod is
;; known, return 'mod; otherwise return #f.  If `mode' is 'path, return
;; a path for modules that come from files and #f otherwise, and if it's
;; 'path/sym return a path for the same and a symbolic name for known
;; modules with that name.
(define (known-module mod [mode #f])
  (define (known-top mod)
    (and (not (eq? mode 'path))
         (with-handlers ([exn:fail? (λ (_) #f)])
           (module->imports mod)
           (if (eq? mode 'path/sym) (cadr mod) mod))))
  (match mod
    [(list 'quote (? symbol?)) (known-top mod)]
    [_ (or (with-handlers ([exn:fail? (λ (_) #f)])
             (define r
               (resolved-module-path-name
                ((current-module-name-resolver) mod #f #f)))
             (if (not mode)
               (and r mod)
               ;; sanity check that path results exists
               (and (or (and (path? r) (file-exists? r))
                        (and (eq? mode 'path/sym) (symbol? r)))
                    r)))
           ;; for symbols, try also 'mod
           (and (symbol? mod) (known-top `',mod)))]))
(define (module->path module)
  (resolved-module-path-name ((current-module-name-resolver) module #f #f)))

(define (mpi->name mpi)
  (resolved-module-path-name (module-path-index-resolve mpi)))
(define (->relname x)
  (cond [(path-string? x) (path->relative-string/setup x)]
        [x]))

(define (module-displayable-name mod)
  (define (choose-path x)
    ;; choose the shortest from an absolute path, a relative path, and a
    ;; "~/..." path.
    (if (not (complete-path? x)) ; shouldn't happen
      x
      (let* ([r (path->string (find-relative-path (current-directory) x))]
             [h (path->string (build-path (string->path-element "~")
                                          (find-relative-path home-dir x)))]
             [best (if (< (string-length r) (string-length h)) r h)]
             [best (if (< (string-length best) (string-length x)) best x)])
        best)))
  (define (get-prefix* path)
    (define x (path->string path))
    (define y (->relname path))
    (if (equal? x y)
      (format "~s" (choose-path x))
      (regexp-replace #rx"[.]rkt$" y "")))
  (match mod
    [(? symbol?) (symbol->string mod)]
    [(list 'quote (? symbol? s)) (format "'~a" s)]
    [_ (get-prefix* mod)]))

(define (here-source) ; returns a path, a symbol, or #f (= not in a module)
  (variable-reference->module-source
   (eval (namespace-syntax-introduce
          (datum->syntax #f `(,#'#%variable-reference))))))

(define (phase->name phase [fmt #f])
  (define s
    (case phase
      [(0) #f] [(#f) "for-label"] [(1) "for-syntax"] [(-1) "for-template"]
      [else (format "for-meta:~a" phase)]))
  (cond [(not fmt) s] [s (format fmt s)] [else ""]))

;; true if (quote sym) is a known module name
(define (known-module-name? sym)
  (and (symbol? sym)
       (with-handlers ([exn? (λ (_) #f)]) (module->imports `',sym) #t)))

(define last-output-port #f)
(define last-error-port  #f)
(define (maybe-new-output-ports)
  (define-syntax-rule (maybe last cur)
    (unless (eq? last cur)
      (when last (flush-output last)) ; just in case
      (set! last cur)
      (flush-output last)
      (port-count-lines! last)))
  (maybe last-output-port (current-output-port))
  (maybe last-error-port (current-error-port)))
(define (fresh-line [stderr? #f])
  (maybe-new-output-ports)
  (define port (if stderr? last-error-port last-output-port))
  (flush-output port)
  (define-values [line col pos] (port-next-location port))
  (unless (eq? col 0) (newline)))
(define (zero-column!)
  ;; there's a problem whenever there's some printout followed by a read: the
  ;; cursor will at column zero, but the port counting will think that it's
  ;; still right after the printout; call this function in such cases to adjust
  ;; the column to 0.
  (maybe-new-output-ports)
  (define-values [line col pos] (port-next-location last-output-port))
  (set-port-next-location! last-output-port line 0 pos))

;; wrapped output
(define-syntax-rule (with-wrapped-output body ...)
  (do-xrepl-wrapped-output (λ () body ...)))
(define (do-xrepl-wrapped-output thunk)
  (do-wrapped-output thunk #:indent-first -2 #:line-prefix #rx"^;+ *"))
;; maybe move this into scribble/text/wrap
(define (do-wrapped-output thunk
                           #:wrap-width   [width (wrap-width)]
                           #:line-prefix  [prefix-rx #f] ; not including spaces
                           #:indent-first [fst-indent 0] ; can be negative
                           #:split-word   [split-word #f])
  (define-values [ip op] (make-pipe))
  (define widths
    (cond [(fst-indent . > . 0) (cons (- width fst-indent) width)]
          [(fst-indent . < . 0) (cons width (+ width fst-indent))]
          [else (cons width width)]))
  (define indents
    (let ([spaces (make-bytes (abs fst-indent) (char->integer #\space))])
      (cond [(fst-indent . > . 0) (cons spaces #"")]
            [(fst-indent . < . 0) (cons #"" spaces)]
            [else (cons #"" #"")])))
  (define out (current-output-port))
  (define (wrapper)
    (define m (cond [(regexp-match #rx#"^(?:\n|[^\n]+)" ip) => car] [else #f]))
    (when m ; #f => we're at the end
      (if (equal? #"\n" m)
        (newline out)
        (let* ([i (cdar (regexp-match-positions #rx#"^ *" m))]
               [p (regexp-match-positions prefix-rx m i)]
               [i (if (and p (= (caar p) i)) (cdar p) i)]
               [j (caar (regexp-match-positions #rx" *$" m))]
               [widths (cons (- (car widths) i) (- (cdr widths) i))]
               [lines  (wrap-line (bytes->string/utf-8 (subbytes m i j))
                                  widths split-word)])
          (write-bytes m out 0 i)
          (write-bytes (car indents) out)
          (write-string (car lines) out)
          (for ([l (in-list (cdr lines))])
            (newline out)
            (write-bytes m out 0 i)
            (write-bytes (cdr indents) out)
            (write-string l out))))
      (wrapper)))
  (define th (thread wrapper))
  (parameterize ([current-output-port op]) (thunk))
  (close-output-port op)
  (thread-wait th))

;; ----------------------------------------------------------------------------
;; toplevel "," commands management

(struct command (names argline 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 argline desc handler)
  (let* ([names (if (list? names) names (list names))]
         [cmd (command names blurb argline desc handler)])
    (for ([n (in-list 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 argline blurb [desc ...]
                      body0 body ...)
  (register-command! `cmd+aliases `argline `blurb `(desc ...)
                     (λ () 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))))

;; returns first peeked non-space/tab char (#\return is considered space too)
(define string->list*
  (let ([t (make-weak-hasheq)]) ; good for string literals
    (λ (s) (hash-ref! t s (λ () (string->list s))))))
(define (skip-spaces/peek [skip " \t\r"])
  (let ([skip (string->list* skip)])
    (let loop ()
      (let ([ch (peek-char)])
        (if (memq ch skip) (begin (read-char) (loop)) ch)))))

(define (here-path [no-path eof])
  (let ([x (here-source)]) (if (path? x) x no-path)))
(define (here-mod-or-eof)
  (let ([x (here-source)])
    (if (not x)
      eof
      (datum->syntax #f
        (cond [(symbol? x) `',x]
              [(path? x)   (let ([s (path->string x)])
                             (if (absolute-path? x) `(file ,s) s))]
              [else (error 'here-mod-or-eof "internal error: ~s" x)])))))

(define (getarg kind [flag 'req] #:default [dflt #f])
  (unless (memq flag '(req opt list list+))
    (error 'getarg "unknown flag: ~e" flag))
  (define (argerror fmt . args)
    (apply cmderror #:default-who 'getarg fmt args))
  (define (missing) (argerror "missing ~a argument" kind))
  (define (get read)
    (define (get-one)
      (cond [(eq? read read-line-arg) (read)]
            [(eq? #\newline (skip-spaces/peek)) eof]
            [else (read)]))
    (define (get-list)
      (let ([x (get-one)]) (if (eof-object? x) '() (cons x (get-list)))))
    (define 0th  (get-one))
    (define 0th? (not (eof-object? 0th)))
    (define 1st  (if (and (not 0th?) dflt) (dflt) 0th))
    (define 1st? (not (eof-object? 1st)))
    (cond [1st? (if (memq flag '(list list+))
                  (cons 1st (if 0th? (get-list) '()))
                  1st)]
          [(eq? flag 'opt) #f]
          [(eq? flag 'list) '()]
          [else (missing)]))
  (define (read-string-arg)
    (define ch (skip-spaces/peek " \t\r\n"))
    (let* ([i (current-input-port)]
           [m (if (eq? ch #\")
                (let ([m (regexp-match #px#"((?:\\\\.|[^\"\\\\]+)+)\"" i)])
                  (and m (regexp-replace* #rx#"\\\\(.)" (cadr m) #"\\1")))
                (cond [(regexp-match #px#"\\S+" i) => car] [else #f]))])
      (if m (bytes->string/locale m) eof)))
  (define (read-line-arg)
    (regexp-replace* #px"^\\s+|\\s+$" (read-line) ""))
  (define (symbolic-shorthand x)
    ;; convenience: symbolic requires that name a file turn to a `file'
    ;; require, and those that name a known module turn to a (quote sym)
    (define dtm (if (syntax? x) (syntax->datum x) x))
    (if (not (symbol? dtm))
      x
      (let* (;; try a file
             [f (expand-user-path (symbol->string dtm))]
             [f (and (file-exists? f) (path->string f))]
             [f (and f (if (absolute-path? f) `(file ,f) f))]
             ;; try a quoted one if the above failed
             [m (or f (and (known-module-name? dtm) `',dtm))]
             [m (and m (if (syntax? x) (datum->syntax x m x) m))])
        (or m x))))
  (define (process-require req)
    ;; no verification of requires -- let the usual error happen if needed
    (symbolic-shorthand req))
  (define (process-module mod)
    (or (known-module (symbolic-shorthand mod))
        (cmderror "unknown module: ~s" mod)))
  (define (translate arg convert)
    (and arg (if (memq flag '(list list+)) (map convert arg) (convert arg))))
  (let loop ([kind kind])
    (case kind
      [(line)    (get read-line-arg)]
      [(string)  (get read-string-arg)]
      [(path)    (translate (loop 'string) expand-user-path)]
      [(sexpr)   (get read)]
      [(syntax)  (translate (get read-syntax) namespace-syntax-introduce)]
      [(require) (translate (loop 'syntax) process-require)]
      [(module)  (translate (loop 'sexpr) process-module)]
      [else (error 'getarg "unknown arg kind: ~e" kind)])))

(define (run-command cmd)
  (parameterize ([current-command cmd])
    (with-handlers ([void (λ (e)
                            (if (exn? e)
                              (eprintf "~a\n" (exn-message e))
                              (eprintf "~s\n" e)))])
      ((command-handler (or (hash-ref commands cmd #f)
                            (error "Unknown command:" cmd)))))))

(defcommand (help h ?) "[<command-name>]"
  "display available commands"
  ["Lists known commands and their help; use with a command name to get"
   "additional information for that command."]
  (define arg (match (getarg 'sexpr 'opt) [(list 'unquote x) x] [x x]))
  (define cmd
    (and arg (hash-ref commands arg
                       (λ () (printf "*** Unknown command: `~s'\n" arg) #f))))
  (define (show-cmd cmd indent)
    (define names (command-names cmd))
    (printf "~a~s" indent (car names))
    (when (pair? (cdr names)) (printf " ~s" (cdr names)))
    (printf ": ~a\n" (command-blurb cmd)))
  (with-wrapped-output
    (if cmd
      (begin (show-cmd cmd "; ")
             (printf ";   usage: ,~a" arg)
             (let ([a (command-argline cmd)]) (when a (printf " ~a" a)))
             (printf "\n")
             (for ([d (in-list (command-desc cmd))])
               (printf "; ~a\n" d)))
      (begin (printf "; Available commands:\n")
             (for-each (λ (c) (show-cmd c ";   ")) (reverse commands-list))))))

;; ----------------------------------------------------------------------------
;; generic commands

(defcommand (exit quit ex) "[<exit-code>]"
  "exit racket"
  ["Optional argument specifies exit code."]
  (cond [(getarg 'sexpr 'opt) => exit] [else (exit)]))

(define last-2dirs
  (make-parameter (let ([d (current-directory)]) (cons d d))))
(define (report-directory-change [mode #f])
  (define curdir (current-directory))
  (define (report) ; remove last "/" and say where we are
    (define-values [base name dir?] (split-path curdir))
    (printf "; now in ~a\n" (if base (build-path base name) curdir)))
  (cond [(not (equal? (car (last-2dirs)) curdir))
         (last-2dirs (cons curdir (car (last-2dirs))))
         (report)]
        [else (case mode
                [(pwd) (report)]
                [(cd)  (printf "; still in the same directory\n")])]))

(defcommand cd "[<path>]"
  "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) home-dir)]
         [arg (if (equal? arg (string->path "-")) (cdr (last-2dirs)) arg)])
    (if (directory-exists? arg)
      (begin (current-directory arg) (report-directory-change 'cd))
      (eprintf "; cd: no such directory: ~a\n" arg))))

(defcommand pwd #f
  "display the current directory"
  ["Displays the value of `current-directory'."]
  (report-directory-change 'pwd))

(defcommand (shell sh ls cp mv rm md rd git svn) "<shell-command>"
  "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.)"
   "If the REPL is inside some module's namespace, the command can use $F"
   "which is set to the full path to this module's source file."]
  (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])]
          [here (here-path #f)])
      (putenv "F" (if here (path->string here) ""))
      (unless (system (cond [(and (not cmd) (not arg)) (getenv "SHELL")]
                            [(not cmd) arg]
                            [(not arg) cmd]
                            [else (string-append cmd " " arg)]))
        (eprintf "; (exit with an error status)\n"))
      (when here (putenv "F" ""))
      (void))))

(defcommand (edit e) "<file> ..."
  "edit files in your $EDITOR"
  ["Runs your $EDITOR with the specified file/s.  If no files are given, and"
   "the REPL is currently inside a module, the file for that module is used."
   "If $EDITOR is not set, the ,drracket will be used instead."]
  (define env (let ([e (getenv "EDITOR")]) (and (not (equal? "" e)) e)))
  (define exe (and env (find-executable-path env)))
  (cond [(not env)
         (printf "~a, using the ,drracket command.\n"
                 (if env
                   (string-append "$EDITOR ("env") not found in your path")
                   "no $EDITOR variable"))
         (run-command 'drracket)]
        [(not (apply system* exe (getarg 'path 'list #:default here-path)))
         (eprintf "; (exit with an error status)\n")]
        [else (void)]))

(define ->running-dr #f)
(define (->dr . xs) (unless ->running-dr (start-dr)) (->running-dr xs))
(define (start-dr)
  (printf "; starting DrRacket...\n")
  (define c (make-custodian))
  (define ns ((dynamic-require 'racket/gui 'make-gui-namespace)))
  (parameterize ([current-custodian c]
                 [current-namespace ns]
                 [exit-handler (λ (x)
                                 (eprintf "; DrRacket shutdown.\n")
                                 (set! ->running-dr #f)
                                 (custodian-shutdown-all c))])
    ;; construct a kind of a fake sandbox to run drracket in
    (define es
      (eval '(begin (require racket/class racket/gui framework racket/file)
                    (define es (make-eventspace))
                    es)))
    (define (E expr)
      (parameterize ([current-custodian c]
                     [current-namespace ns]
                     [(eval 'current-eventspace ns) es])
        (eval expr ns)))
    (E '(begin
          (define c (current-custodian))
          (define-syntax-rule (Q expr ...)
            (parameterize ([current-eventspace es])
              (queue-callback
               (λ () (parameterize ([current-custodian c]) expr ...)))))
          ;; problem: right after we read commands, readline will save a new
          ;; history in the prefs file which frequently collides with drr; so
          ;; make it use a writeback thing, with silent failures.  (actually,
          ;; this is more likely a result of previously starting drr wrongly,
          ;; but keep this anyway.)
          (let ([t (make-hasheq)] [dirty '()])
            (preferences:low-level-get-preference
             (λ (sym [dflt (λ () #f)])
               (hash-ref t sym
                 (λ () (let ([r (get-preference sym dflt)])
                         (hash-set! t sym r)
                         r)))))
            (preferences:low-level-put-preferences
             (λ (prefs vals)
               (Q (set! dirty (append prefs dirty))
                  (for ([pref (in-list prefs)] [val (in-list vals)])
                    (hash-set! t pref val)))))
            (define (flush-prefs)
              (set! dirty (remove-duplicates dirty))
              (with-handlers ([void void])
                (put-preferences dirty (map (λ (p) (hash-ref t p)) dirty))
                (set! dirty '())))
            (exit:insert-on-callback flush-prefs)
            (define (write-loop)
              (sleep (random 4))
              (when (pair? dirty) (Q (flush-prefs)))
              (write-loop))
            (define th (thread write-loop))
            (exit:insert-on-callback (λ () (Q (kill-thread th)))))
          ;; start it
          (Q (dynamic-require 'drracket #f))
          ;; hide the first untitled window, so drr runs in "server mode"
          (Q (dynamic-require 'drracket/tool-lib #f))
          (define top-window
            (let ([ch (make-channel)])
              (Q (let ([r (get-top-level-windows)])
                   (channel-put ch (and (pair? r) (car r)))))
              (channel-get ch)))
          (Q (when top-window (send top-window show #f))
             ;; and avoid trying to open new windows in there
             (send (group:get-the-frame-group) clear))
          ;; avoid being able to quit so the server stays running,
          ;; also hack: divert quitting into closing all group frames
          (define should-exit? #f)
          (exit:insert-can?-callback
           (λ () (or should-exit?
                     (let ([g (group:get-the-frame-group)])
                       (when (send g can-close-all?) (send g on-close-all))
                       #f))))
          (require drracket/tool-lib))) ; used as usual below
    (define (new)
      (E '(Q (drracket:unit:open-drscheme-window #f))))
    (define open
      (case-lambda
        [() (E '(Q (handler:open-file)))]
        [paths
         (let ([paths (map path->string paths)])
           (E `(Q (let ([f (drracket:unit:open-drscheme-window ,(car paths))])
                    (send f show #t)
                    ,@(for/list ([p (in-list (cdr paths))])
                        `(begin (send f open-in-new-tab ,p)
                                (send f show #t)))))))]))
    (define (quit)
      (E `(Q (set! should-exit? #t) (exit:exit))))
    (define (loop)
      (define m (thread-receive))
      (if (pair? m)
        (let ([proc (case (car m) [(new) new] [(open) open] [(quit) quit]
                          [else (cmderror "unknown flag: -~a" (car m))])])
          (if (procedure-arity-includes? proc (length (cdr m)))
            (apply proc (cdr m))
            (cmderror "bad number of arguments for the -~a flag" (car m))))
        (error '->dr "internal error"))
      (loop))
    (define th (thread loop))
    (set! ->running-dr (λ (xs) (thread-send th xs)))))
(defcommand (drracket dr drr) "[-flag] <file> ..."
  "edit files in DrRacket"
  ["Runs DrRacket with the specified file/s.  If no files are given, and"
   "the REPL is currently inside a module, the file for that module is used."
   "DrRacket is launched directly, without starting a new subprocess, and it"
   "is kept running in a hidden window so further invocations are immediate."
   "In addition to file arguments, the arguments can have a flag that"
   "specifies one of a few operations for the running DrRacket:"
   "* -new: opens a new editing window.  This is the default when no files are"
   "  given and the REPL is not inside a module,"
   "* -open: opens the specified file/s (or the current module's file).  This"
   "  is the default when files are given or when inside a module."
   "* -quit: exits the running instance.  Quitting the application as usual"
   "  will only close the visible window, but it will still run in a hidden"
   "  window.  This command should not be needed under normal circumstances."]
  (define args (getarg 'path 'list #:default here-path))
  (if (null? args)
    (->dr 'new)
    (let* ([cmd (let ([s (path->string (car args))])
                  (and (regexp-match? #rx"^-" s)
                       (string->symbol (substring s 1))))]
           [args (if cmd (cdr args) args)])
      (apply ->dr (or cmd 'open) args))))

;; ----------------------------------------------------------------------------
;; binding related commands

(defcommand (apropos ap) "<search-for> ..."
  "look for a binding"
  ["Additional arguments restrict the shown matches.  The search specs can"
   "have symbols (which specify what to look for in bound names), and regexps"
   "(for more complicated matches)."]
  (let* ([look (map (λ (s) (cond [(symbol? s)
                                  (regexp (regexp-quote (symbol->string s)))]
                                 [(regexp? s) s]
                                 [else (cmderror "bad search spec: ~e" s)]))
                    (getarg 'sexpr 'list))]
         [look (and (pair? look)
                    (λ (str) (andmap (λ (rx) (regexp-match? rx str)) look)))]
         [syms (map (λ (sym) (cons sym (symbol->string sym)))
                    (namespace-mapped-symbols))]
         [syms (if look (filter (λ (s) (look (cdr s))) syms) syms)]
         [syms (sort syms string<? #:key cdr)]
         [syms (map car syms)])
    (with-wrapped-output
      (if (null? syms)
        (printf "; No matches found")
        (begin (printf "; Matches: ~s" (car syms))
               (for ([s (in-list (cdr syms))]) (printf ", ~s" s))))
      (printf ".\n"))))

(defcommand (describe desc id) "[<phase-number>] <identifier-or-module> ..."
  "describe a (bound) identifier"
  ["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.  An optional numeric argument specifies phase for"
   "identifier lookup."]
  (define-values [try-mods? level ids/mods]
    (let ([xs (getarg 'syntax 'list)])
      (if (and (pair? xs) (number? (syntax-e (car xs))))
        (values #f (syntax-e (car xs)) (cdr xs))
        (values #t 0 xs))))
  (with-wrapped-output
    (for ([id/mod (in-list ids/mods)])
      (define dtm (syntax->datum id/mod))
      (define mod (and try-mods? (known-module dtm 'path/sym)))
      (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 level))
      (when mod
        (parameterize (;; without this the reported paths are wrong
                       [current-load-relative-directory
                        (and (path? mod)
                             (let-values ([(base name dir?) (split-path mod)])
                               (and (path? base) base)))])
          (describe-module dtm mod bind?))))))
(define (describe-binding sym b level)
  (define at-phase (phase->name level " (~a)"))
  (cond
    [(not b)
     (printf "; `~s' is a toplevel (or unbound) identifier~a\n" sym at-phase)]
    [(eq? b 'lexical)
     (printf "; `~s' is a lexical identifier~a\n" sym at-phase)]
    [(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))
     (set! src-mod         (->relname (mpi->name src-mod)))
     (set! nominal-src-mod (->relname (mpi->name nominal-src-mod)))
     (printf "; `~s' is a bound identifier~a,\n" sym at-phase)
     (printf ";   defined~a in ~a~a\n" (phase->name src-phase "-~a") src-mod
             (if (not (eq? sym src-id)) (format " as `~s'" src-id) ""))
     (printf ";   required~a ~a\n" (phase->name import-phase "-~a")
             (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)
                         ""))))
     (printf "~a" (phase->name nominal-export-phase ";   (exported-~a)\n"))]))
(define (describe-module sexpr mod-path/sym also?)
  (define get
    (if (symbol? mod-path/sym)
      (let ([spec `',mod-path/sym])
        (λ (imp?) ((if imp? module->imports module->exports) spec)))
      (let ([code (get-module-code mod-path/sym)])
        (λ (imp?)
          ((if imp? module-compiled-imports module-compiled-exports) code)))))
  (define (phase<? p1 p2)
    (cond [(eq? p1 p2) #f]
          [(or (eq? p1 0) (not p2)) #t]
          [(or (eq? p2 0) (not p1)) #f]
          [(and (> p1 0) (> p2 0)) (< p1 p2)]
          [(and (< p1 0) (< p2 0)) (> p1 p2)]
          [else (> p1 0)]))
  (define (modname<? x y)
    (cond [(and (string? x) (string? y)) (string<? x y)]
          [(and (symbol? x) (symbol? y))
           (string<? (symbol->string x) (symbol->string y))]
          [(and (symbol? x) (string? y)) #t]
          [(and (string? x) (symbol? y)) #f]
          [else (error 'describe-module "internal error: ~s, ~s" x y)]))
  (define imports
    (filter-map
     (λ (x)
       (and (pair? (cdr x))
            (cons (car x) (sort (map (λ (m) (->relname (mpi->name m))) (cdr x))
                                modname<?))))
     (sort (get #t) phase<? #:key car)))
  (define-values [val-exports stx-exports]
    (let-values ([(vals stxs) (get #f)])
      (define (get-directs l)
        (filter-map
         (λ (x)
           (let ([directs (filter-map (λ (b) (and (null? (cadr b)) (car b)))
                                      (cdr x))])
             (and (pair? directs) (cons (car x) directs))))
         (sort l phase<? #:key car)))
      (values (get-directs vals) (get-directs stxs))))
  (printf "; `~a' is~a a module,\n" sexpr (if also? " also" ""))
  (let ([relname (->relname mod-path/sym)])
    (printf ";   ~a~a\n"
            (if (symbol? relname) "defined directly as '" "located at ")
            relname))
  (if (null? imports)
    (printf ";   no imports.\n")
    (for ([imps (in-list imports)])
      (let ([phase (car imps)] [imps (cdr imps)])
        (printf ";   imports~a: ~a" (phase->name phase "-~a") (car imps))
        (for ([imp (in-list (cdr imps))]) (printf ", ~a" imp))
        (printf ".\n"))))
  (define (show-exports exports kind)
    (for ([exps (in-list exports)])
      (let ([phase (car exps)]
            [exps (sort (cdr exps) string<? #:key symbol->string)])
        (printf ";   direct ~a exports~a: ~a"
                kind (phase->name phase "-~a") (car exps))
        (for ([exp (in-list (cdr exps))]) (printf ", ~a" exp))
        (printf ".\n"))))
  (if (and (null? val-exports) (null? stx-exports))
    (printf ";   no direct exports.\n")
    (begin (show-exports val-exports "value")
           (show-exports stx-exports "syntax"))))

(define help-id (make-lazy-identifier 'help 'racket/help))
(defcommand doc "<any> ..."
  "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.)"]
  (eval-sexpr-for-user `(,(help-id) ,@(getarg 'syntax 'list))))

;; ----------------------------------------------------------------------------
;; require/load commands

(defcommand (require req r) "<require-spec> ...+"
  "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.)"]
  (more-inputs #`(require #,@(getarg 'require 'list+)))) ; use *our* `require'

(define rr-modules (make-hash)) ; hash to remember reloadable modules

(define last-rr-modules '())

(defcommand (require-reloadable reqr rr) "<module> ..."
  "require a module, make it reloadable"
  ["Same as ,require but the module is required in a way that makes it"
   "possible to reload later.  If it was already loaded then it is reloaded."
   "Note that this is done by setting `compile-enforce-module-constants' to"
   "#f, which prohibits some optimizations."]
  (let ([ms (getarg 'module 'list)])
    (when (pair? ms) (set! last-rr-modules ms)))
  (when (null? last-rr-modules) (cmderror "missing module argument(s)"))
  (parameterize ([compile-enforce-module-constants
                  (compile-enforce-module-constants)])
    (compile-enforce-module-constants #f)
    (for ([mod (in-list last-rr-modules)])
      (define resolved ((current-module-name-resolver) mod #f #f #f))
      (define path     (resolved-module-path-name resolved))
      (if (hash-ref rr-modules resolved #f)
        ;; reload
        (begin (printf "; reloading ~a\n" path)
               (parameterize ([current-module-declare-name resolved])
                 (load/use-compiled path)))
        ;; require
        (begin (hash-set! rr-modules resolved #t)
               (printf "; requiring ~a\n" path)
               ;; (namespace-require mod)
               (eval #`(require #,mod)))))))

(define enter!-id (make-lazy-identifier 'enter! 'racket/enter))

(defcommand (enter en) "[<module>] [noisy?]"
  "require a module and go into its namespace"
  ["Uses `enter!' to go into the module's namespace.  A module name can"
   "specify an existing file as with the ,require command.  If no module is"
   "given, and the REPL is already in some module's namespace, then `enter!'"
   "is used with that module, causing it to reload if needed.  (Note that this"
   "can be used even in languages that don't have the `enter!' binding.)"]
  (eval-sexpr-for-user `(,(enter!-id)
                         ,(getarg 'module #:default here-mod-or-eof)
                         ,@(getarg 'syntax 'list)
                         #:dont-re-require-enter)))

(defcommand (toplevel top) #f
  "go back to the toplevel"
  ["Go back to the toplevel, same as ,enter with no arguments."]
  (eval-sexpr-for-user `(,(enter!-id) #f)))

(defcommand (load ld) "<filename> ..."
  "load a file"
  ["Uses `load' to load the specified file(s)."]
  (more-inputs* (map (λ (name) #`(load #,name)) (getarg 'path 'list))))

;; ----------------------------------------------------------------------------
;; debugging commands

;; not useful: catches only escape continuations
;; (define last-break-exn (make-parameter #f))
;; (defcommand (continue cont) #f
;;   "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")))

(define last-backtrace #f)
(defcommand (backtrace bt) #f
  "see a backtrace of the last exception"
  ["Display the last exception with its backtrace."]
  (printf "; ~a\n"
          (regexp-replace* #rx"\n+" (or last-backtrace "(no backtrace)")
                           "\n; ")))

(define time-id
  (make-lazy-identifier 'time* 'unstable/time))
(defcommand time "[<count>] <expr> ..."
  "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"
   "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."]
  (more-inputs #`(#,(time-id) #,@(getarg 'syntax 'list))))

(define trace-id (make-lazy-identifier 'trace 'racket/trace))
(defcommand (trace tr) "<function> ..."
  "trace a function"
  ["Traces a function (or functions), using the `racket/trace' library."]
  (eval-sexpr-for-user `(,(trace-id) ,@(getarg 'syntax 'list))))

(define untrace-id (make-lazy-identifier 'untrace 'racket/trace))
(defcommand (untrace untr) "<function> ..."
  "untrace a function"
  ["Untraces functions that were traced with ,trace."]
  (eval-sexpr-for-user `(,(untrace-id) ,@(getarg 'syntax 'list))))

(defautoload errortrace
  profiling-enabled instrumenting-enabled clear-profile-results
  output-profile-results execute-counts-enabled annotate-executed-file)

(defcommand (errortrace errt inst) "[<flag>]"
  "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")))

(define profile-id
  (make-lazy-identifier 'profile 'profile))
(define (statistical-profiler)
  (more-inputs #`(#,(profile-id) #,(getarg 'syntax))))
(define (errortrace-profiler)
  (instrumenting-enabled #t)
  (define flags (regexp-replace* #rx"[ \t]+" (getarg 'line) ""))
  (for ([cmd (in-string (if (equal? "" flags)
                          (if (profiling-enabled) "*!" "+")
                          flags))])
    (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")]
      [else (cmderror "unknown subcommand")])))
(defcommand (profile prof) "[<expr> | <flag> ...]"
  "profiler control"
  ["Runs either the exact errortrace-based profiler, or the statistical one."
   "* If a parenthesized expression is given, run the statistical profiler"
   "  while running it.  This profiler requires no special setup and adds"
   "  almost no overhead, it samples stack traces as execution goes on."
   "* Otherwise the errortrace profiler is used.  This profiler produces"
   "  precise results, but like other errortrace uses, it must be enabled"
   "  before loading the code and it adds noticeable overhead.  In this case,"
   "  an argument is used to determine 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 flags can be combined, for example \",prof *!-\" will show"
   "  profiler results, clear them, and turn it off."
   "* With no arguments, turns the errortrace profiler on if it's off, and if"
   "  it's on it shows the collected results and clears them."
   "Note: using no arguments or *any* of the flags turns errortrace"
   "  instrumentation on, even a \",prof -\".  Use the ,errortrace command if"
   "  you want to turn instrumentation off."]
  (if (memq (skip-spaces/peek) '(#\( #\[ #\{))
    (statistical-profiler)
    (errortrace-profiler)))

(defcommand execution-counts "<file> ..."
  "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))])
    (more-inputs
     (λ ()
       (instrumenting-enabled #t)
       (execute-counts-enabled #t))
     #`(require #,@(map (λ (file) `(file ,(path->string file))) files))
     (λ ()
       (for ([file (in-list files)])
         (annotate-executed-file file " 123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ")))
     (λ ()
       (execute-counts-enabled #f)
       (unless inst? (instrumenting-enabled #f))))))

(defautoload racket/sandbox
  make-module-evaluator kill-evaluator call-with-trusted-sandbox-configuration
  sandbox-coverage-enabled get-uncovered-expressions)

(defcommand (coverage cover) "<file>"
  "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
         (λ () (make-module-evaluator file))))
      (define uncovered
        (map (λ (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
        (λ (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 (make-parameter default-namespace-name))
(define namespaces
  (let* ([r (namespace-symbol->identifier '#%top-interaction)]
         [r (identifier-binding r)]
         [r (and r (mpi->name (caddr r)))]
         [t (make-hasheq)])
    (hash-set! t (current-namespace-name) (cons (current-namespace) r))
    t))
(defcommand (switch-namespace switch) "[<name>] [? | - | ! [<init>]]"
  "switch to a different repl namespace"
  ["Switch to the <name> namespace, creating it if needed.  The <name> of a"
   "namespace is a symbol or an integer; `*' indicates the initial namespace."
   "These names are used only by this command, they're not bindings.  A new"
   "namespace is initialized using the name of the namespace if it names a"
   "module, or using the same initial module that was used for the current"
   "namespace."
   "If `! <init>' is used, the new namespace will be created even if it"
   "exists, using `<init>' as the initial module.  If `!' is used without an"
   "<init> to reset an existing namespace its initial module is used again,"
   "and if it is used to create a new namespace, the initial module in current"
   "namespace used."
   "You can also use `-' and a name to drop the corresponding namespace"
   "(allowing it to be garbage-collected), and `?' to list all known"
   "namespaces."
   "A few examples:"
   "  ,switch !             reset the current namespace"
   "  ,switch ! racket      reset it using the `racket' language"
   "  ,switch r5rs          switch to a new `r5rs' namespace, initializing it"
   "                        with `r5rs'"
   "  ,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 <init> as it was created"
   "                        with, or as the current namespace if `foo' is new"
   "  ,switch ?             list known namespaces and their initial modules"
   "  ,switch - r5rs        drop the `r5rs' namespace"
   "(Note that you can use `^' etc to communicate values between namespaces.)"]
  (define (list-namespaces)
    (printf "; namespaces and their languages:\n")
    (define nss (sort (map (λ (x) (cons (format "~s" (car x)) (cddr x)))
                           (hash-map namespaces cons))
                      string<? #:key car))
    (define maxlen (apply max (map (λ (x) (string-length (car x))) nss)))
    (for ([x (in-list nss)])
      (printf "; ~a:~a ~s\n"
              (car x)
              (make-string (- maxlen (string-length (car x))) #\space)
              (cdr x))))
  (define (delete name)
    (when (eq? name default-namespace-name)
      (cmderror "cannot drop the default namespace"))
    (when (eq? name (current-namespace-name))
      (cmderror "cannot drop the current namespace"))
    (unless (hash-ref namespaces name #f)
      (cmderror "unknown namespace name: ~s" name))
    (hash-remove! namespaces name)
    (printf "; namespace dropped: ~s\n" name))
  (define (switch name force-reset? init)
    (unless (or (not name) (symbol? name) (fixnum? name))
      (cmderror "bad namespace name, must be symbol or fixnum"))
    (define old-namespace (current-namespace))
    ;; if there's an <init>, then it must be forced
    (let* ([name (or name (current-namespace-name))]
           [init
            (cond [init]
                  [(or force-reset? (not (hash-ref namespaces name #f)))
                   (when (eq? name default-namespace-name)
                     ;; no deep reason for this, but might be usful to keep it
                     ;; possible to ,en xrepl/xrepl to change options etc
                     (cmderror "cannot reset the default namespace"))
                   (cdr (or (hash-ref namespaces name #f)
                            (let ([k (known-module name)]) (and k (cons #f k)))
                            (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 ~a ***\n"
                (if (hash-ref namespaces name #f)
                  "Resetting the" "Initializing a new")
                name
                (module-displayable-name init))
        (current-namespace (make-base-empty-namespace))
        (unless (known-module init)
          (parameterize ([current-namespace old-namespace])
            (dynamic-require init #f)) ; instantiate it if needed
          (namespace-attach-module old-namespace init))
        (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)))))
      (current-namespace-name name)
      (current-namespace (car (hash-ref namespaces name)))))
  (define (syntax-error)
    (cmderror "syntax error, see ,help switch-namespace"))
  (match (getarg 'sexpr 'list)
    [(list) (cmderror "what do you want to do?")]
    [(list '?)           (list-namespaces)]
    [(list '? _ ...)     (syntax-error)]
    [(list '- name)      (delete name)]
    [(list '- _ ...)     (syntax-error)]
    [(list '!)           (switch #f   #t #f  )]
    [(list '! init)      (switch #f   #t init)]
    [(list name)         (switch name #f #f  )]
    [(list name '!)      (switch name #t #f  )]
    [(list name '! init) (switch name #t init)]
    [_      (syntax-error)]))

;; ----------------------------------------------------------------------------
;; syntax commands

(define current-syntax (make-parameter #f))
(defautoload racket/pretty pretty-write)
(defautoload macro-debugger/stepper-text expand/step-text)
(define not-in-base
  (λ () (let ([base-stxs #f])
          (unless base-stxs
            (set! base-stxs ; all ids that are bound to a syntax in racket/base
                  (parameterize ([current-namespace hidden-namespace])
                    (let-values ([(vals stxs) (module->exports 'racket/base)])
                      (map (λ (s) (namespace-symbol->identifier (car s)))
                           (cdr (assq 0 stxs)))))))
          (λ (id) (not (ormap (λ (s) (free-identifier=? id s)) base-stxs))))))
(define (macro-stepper . args)
  (define-values [i o] (make-pipe))
  (parameterize ([current-output-port o])
    (thread (λ () (apply expand/step-text args) (close-output-port o))))
  (let loop ()
    (define l (read-line i))
    (unless (eof-object? l)
      ;; hack: beautify the stepper's output -- remove empty line, indent code
      (unless (equal? "" l)
        (printf (if (regexp-match? #px"^[A-Z][a-z]+\\b" l)
                  "; ---- ~a ----\n" "; ~a\n")
                l))
      (loop))))
(defcommand (syntax stx st) "[<expr>] [<flag> ...]"
  "set syntax object to inspect, and control it"
  ["With no arguments, will show the previously set (or expanded) syntax"
   "additional arguments serve as an operation to perform:"
   "- `^' sets the syntax from the last entered expression"
   "- other sexprs set the current syntax explicitly"
   "- `+' will `expand-once' the syntax and show the result (can be used again"
   "      for additional `expand-once' steps)"
   "- `!' 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"
   "Note that you can specify several syntaxes and operations in a single"
   "invocation."]
  (define args (getarg 'syntax 'list))
  (for ([stx (in-list (if (null? args) '(#f) args))])
    (define (show/set label stx)
      (printf "; ~a\n" label)
      (current-syntax stx)
      (display "; ") (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-input-syntax)
              (show/set "Using last expression:" (last-input-syntax))
              (cmderror "no expression entered yet"))]
      [(+)  (show/set "expand-once ->" (expand-once (cur)))]
      [(!)  (show/set "expand ->" (expand (cur)))]
      [(*)  (printf "; Stepper:\n") (macro-stepper (cur) (not-in-base))]
      [(**) (printf "; Stepper:\n") (macro-stepper (cur))]
      [else
       (if (syntax? stx)
         (begin (printf "; Syntax set\n") (current-syntax stx))
         (cmderror "internal error: ~s ~s" stx (syntax? stx)))])))

(defautoload macro-debugger/analysis/check-requires show-requires)
(defcommand (check-requires ckreq) "[<module>]"
  "check the `require's of a module"
  ["Uses `macro-debugger/analysis/check-requires', see the docs for more"
   "information."]
  (define mod (getarg 'module #:default here-mod-or-eof))
  (define rs (show-requires mod))
  (with-wrapped-output
    (for ([decision (in-list '(keep bypass drop))])
      (define all (filter (λ (x) (eq? decision (car x))) rs))
      (unless (null? all)
        (define names (map cadr all))
        ;; doesn't print the phase number (third element of all members)
        (printf "; ~a: ~a"
                (string-titlecase (symbol->string decision)) (car names))
        (for ([n (in-list (cdr names))]) (printf ", ~a" n))
        (printf ".\n")))))

;; ----------------------------------------------------------------------------
;; dynamic log output control

(define current-log-receiver-thread (make-parameter #f))
(define global-logger (current-logger))

(defcommand log "<level>"
  "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)])))
  (cond [(current-log-receiver-thread) => kill-thread])
  (when level
    (let ([r (make-log-receiver global-logger level)])
      (current-log-receiver-thread
       (thread
        (λ ()
          (let loop ()
            (match (sync r)
              [(vector l m v name)
               (display (format "; [~a] ~a~a\n"
                                l m (if v (format " ~.s" v) "")))
               (flush-output)])
            (loop))))))))

;; ----------------------------------------------------------------------------
;; meta evaluation hook

;; questionable value, (and need to display the resulting values etc)
#;
(defcommand meta "<expr>"
  "meta evaluation"
  ["Evaluate the given expression where bindings are taken from the xrepl"
   "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 xrepl module -- so you can"
   "use `^' to refer to the result of such an evaluation."]
  (eval (datum->syntax #'here `(#%top-interaction . ,(getarg 'sexpr))))
  (void))

;; ----------------------------------------------------------------------------
;; setup xrepl in the user's racketrc file

(define init-file (find-system-path 'init-file))
(defcommand install! #f
  "install xrepl in your Racket init file"
  ["Installs xrepl in your Racket REPL initialization file.  This is done"
   "carefully: I will tell you about the change, and ask for permission."
   "You can then edit the file if you want to; in your system, you can find it"
   ,(format "at \"~a\"." init-file)]
  (define comment "The following line loads `xrepl' support")
  (define expr  "(require xrepl)")
  (define dexpr "(dynamic-require 'xrepl #f)")
  (define contents (if (file-exists? init-file) (file->string init-file) ""))
  ;; discard the newline for further input
  (let loop () (when (byte-ready?) (read-byte)))
  (define (look-for comment-rx expr)
    (let ([m (regexp-match-positions
              (format "(?<=\r?\n|^) *;+ *~a *\r?\n *~a *(?=\r?\n|$)"
                      comment-rx (regexp-quote expr))
              contents)])
      (and m (car m))))
  (define existing? (look-for (regexp-quote comment) expr))
  (define existing-readline?
    (look-for "load readline support[^\r\n]*" "(require readline/rep)"))
  (define (yes? question)
    (define qtext (string->bytes/utf-8 (format "; ~a? " question)))
    (define inp
      (case (object-name (current-input-port))
        [(readline-input)
         (parameterize ([(dynamic-require
                          (collection-file-path "pread.rkt" "readline")
                          'readline-prompt)
                         qtext])
           (read-line))]
        [else (write-bytes qtext) (flush-output) (read-line)]))
    (and (string? inp) (regexp-match? #px"^[[:space:]]*[yY]" inp)))
  (cond
    [existing?
     (printf "; already installed, nothing to do\n")
     (when existing-readline?
       (printf "; (better to remove the readline loading, xrepl does that)"))]
    [(let ([m (regexp-match
               (string-append (regexp-quote expr) "|" (regexp-quote dexpr))
               contents)])
       (and m (begin (printf "; found \"~a\", ~a\n"
                             (car m) "looks like xrepl is already installed")
                     (not (yes? "should I continue anyway")))))]
    [else
     (when existing-readline?
       (printf "; found a `readline' loading line\n")
       (if (yes? "xrepl will already do that, ok to remove")
         (set! contents (string-append
                         (substring contents 0 (car existing-readline?))
                         (substring contents (cdr existing-readline?))))
         (printf "; it will be kept ~a\n"
                 "(you can edit the file and removing it later)")))
     (printf "; writing new contents, with an added \"~a\"\n" expr)
     (printf "; (if you want to load it conditionally, edit the file and\n")
     (printf ";  use \"~a\" instead, which is a plain expression)\n" dexpr)
     (if (yes? "OK to continue")
       (begin
         (call-with-output-file* init-file #:exists 'truncate
           (λ (o) (define new (regexp-replace #rx"(?:\r?\n)+$" contents ""))
                  (write-string new o)
                  (unless (equal? "" new) (write-string "\n\n" o))
                  (fprintf o ";; ~a\n~a\n" comment expr)))
         (printf "; new contents written to ~a\n" init-file))
       (printf "; ~a was not updated\n" init-file))])
  (void))

;; ----------------------------------------------------------------------------
;; eval hook that keep track of recent evaluation results

;; saved interaction values (can be #f to disable saving)
(define saved-values (make-parameter '()))
(define (save-values! xs)
  (let* ([xs (filter (λ (x) (not (void? x))) xs)] ; don't save void values
         [xs (map (λ (x) (and x (make-weak-box x))) xs)]) ; save weakly
    (unless (null? xs)
      ;; the order is last, 2nd-to-last, ..., same from prev interactions
      ;; the idea is that `^', `^^', etc refer to the values as displayed
      (saved-values (append (reverse xs) (saved-values)))
      (let ([n (saved-values-number)] [l (saved-values)])
        (when (< n (length l)) (saved-values (take l n)))))))

(define last-saved-names+state (make-parameter '(#f #f #f)))
(define (get-saved-names)
  (define last       (last-saved-names+state))
  (define last-num   (cadr last))
  (define last-ptrns (caddr last))
  (define cur-num    (saved-values-number))
  (define cur-ptrns  (saved-values-patterns))
  (if (and (equal? last-num cur-num) (equal? last-ptrns cur-ptrns))
    (car last)
    (let ([new
           (for*/list ([i (in-range 1 (add1 (saved-values-number)))]
                       [p (in-list cur-ptrns)])
             (string->symbol
              (cond
                [(= 1 (string-length p)) (make-string i (string-ref p 0))]
                [(regexp-match? #rx"^[^~]*~a[^~]*$" p) (format p i)]
                [else (error 'saved-names "bad name pattern: ~e" p)])))])
      (last-saved-names+state (list new cur-num cur-ptrns))
      new)))

;; see comment at the top of this module for the below hair
(require xrepl/saved-values)

;; make saved values available through bindings, but avoid names that
;; already exist in the namespace (possibly from a previous initialization)
(define (initialize-namespace)
  ;; We might run into circularity problems, give up silently in that case
  (when (with-handlers ([exn? (λ (_) #f)])
          (namespace-attach-module (here-namespace) 'xrepl/saved-values)
          (dynamic-require 'xrepl/saved-values (void))
          #t)
    ;; Hack: wire in our parameter for expansions (see comment in saved-values)
    (eval-sexpr-for-user `(,#'set-saved-values-param! ,saved-values))
    (for ([sym (in-list (get-saved-names))])
      (define id (namespace-symbol->identifier sym))
      (unless (identifier-binding id)
        (eval-sexpr-for-user
         `(,#'require (,#'only-in ,#'xrepl/saved-values
                                  [,#'saved-value-ref ,id])))))))

(require (for-syntax racket/base))
(define ((make-xrepl-evaluator orig) expr)
  ;; not useful: catches only escape continuations
  ;;   (with-handlers ([exn:break? (λ (e) (last-break-exn e) (raise e))]) ...)
  (if (saved-values)
    (let ([results (call-with-values (λ () (orig expr)) list)])
      (save-values! results)
      (apply values results))
    (orig expr)))

;; ----------------------------------------------------------------------------
;; capture ",..." and run the commands, use readline/rep when possible

(define get-prefix ; to show before the "> " prompt
  (let ()
    (define (get-prefix)
      (let* ([x (here-source)]
             [x (and x (module-displayable-name (if (symbol? x) `',x x)))]
             [x (or x (toplevel-prefix))]
             [x (let ([ph (namespace-base-phase)])
                  (if (eq? 0 ph) x (format "~a[~a]" x ph)))])
        (if (eq? (current-namespace-name) default-namespace-name)
          x (format "~a::~a" (current-namespace-name) x))))
    (define last-directory #f)
    (define last-namespace #f)
    (define prefix #f)
    (λ ()
      (define curdir (current-directory))
      (unless (and (equal? (current-namespace) last-namespace)
                   (equal? curdir last-directory))
        (report-directory-change)
        (initialize-namespace)
        (set! prefix
              (with-handlers
                  ([exn? (λ (e)
                           (eprintf "; error during prompt calculation: ~a\n"
                                    (exn-message e))
                           "[internal-error]")])
                (get-prefix)))
        (set! last-namespace (current-namespace))
        (set! last-directory curdir))
      prefix)))

;; the last non-command expression read
(define last-input-syntax (make-parameter #f))

(struct more-inputs (list)
        #:constructor-name more-inputs* #:omit-define-syntaxes)
(define (more-inputs . inputs) (more-inputs* inputs))

(define (make-xrepl-reader orig)
  (define (plain-reader prefix) ; a plain reader, without readline
    (display prefix) (display "> ") (flush-output) (zero-column!)
    (let ([in ((current-get-interaction-input-port))])
      ((current-read-interaction) (object-name in) in)))
  (define RL ; no direct dependency on readline
    (with-handlers ([exn? (λ (_) #f)])
      (collection-file-path "pread.rkt" "readline")))
  (define (make-readline-reader)
    (let ([p (dynamic-require RL 'current-prompt)]
          [r (dynamic-require RL 'read-cmdline-syntax)])
      (λ (prefix) ; uses the readline prompt
        (parameterize ([p (bytes-append (string->bytes/locale prefix) (p))])
          (r)))))
  (define reader
    (case (object-name (current-input-port))
      [(stdin)
       (if (or (not (terminal-port? (current-input-port)))
               (eq? 'windows (system-type))
               (regexp-match? #rx"^dumb" (or (getenv "TERM") ""))
               (not RL))
         plain-reader
         (with-handlers ([exn?
                          (λ (e)
                            (eprintf "; Warning: no readline support (~a)\n"
                                     (exn-message e))
                            plain-reader)])
           (dynamic-require 'readline/rep-start #f)
           ;; requiring readline should have changed the reader
           (if (eq? (current-prompt-read)
                    (dynamic-require RL 'read-cmdline-syntax))
             (make-readline-reader)
             (begin (eprintf "; Warning: could not initialize readline\n")
                    plain-reader))))]
      [(readline-input)
       (eprintf "; Note: readline already loaded\n~a\n"
                ";   (better to let xrepl load it for you)")
       (make-readline-reader)]
      [else plain-reader]))
  ;; IO management
  (port-count-lines! (current-input-port))
  ;; wrap the reader to get the command functionality
  (define more-inputs '())
  (define (reader-loop)
    (parameterize ([saved-values #f])
      (define from-queue? (pair? more-inputs))
      (define input
        (if from-queue?
          (begin0 (car more-inputs) (set! more-inputs (cdr more-inputs)))
          (begin (fresh-line) (reader (get-prefix)))))
      (syntax-case input ()
        [(uq cmd) (eq? 'unquote (syntax-e #'uq))
         (let ([r (run-command (syntax->datum #'cmd))])
           (cond [(void? r) (reader-loop)]
                 [(more-inputs? r)
                  (set! more-inputs (append (more-inputs-list r) more-inputs))
                  (reader-loop)]
                 [else (eprintf "; Warning: internal weirdness: ~s\n" r) r]))]
        [_ (begin (unless from-queue? (last-input-syntax input)) input)])))
  reader-loop)

;; ----------------------------------------------------------------------------
;; a display handler that omits stacktraces (making them available later)

(define ((make-xrepl-display-handler orig) str exn)
  (fresh-line #t)
  (define backtrace?
    (parameterize ([current-error-port (open-output-string)])
      (orig str exn)
      (let* ([s (get-output-string (current-error-port))]
             [s (regexp-replace* #rx"^\n+|\n+$" s "")]
             [s (regexp-replace* #rx"\n\n+" s "\n")])
        ;; temporary hack: this is always on since it shows all fields,
        ;; so ",bt" is now really a generic "more info"
        (and ; (not (equal? str s))
             (begin (set! last-backtrace s) #t)))))
  (define msg "[,bt for context]")
  (parameterize ([current-output-port (current-error-port)])
    (let* ([s (regexp-replace* #rx"^\n+|\n+$" str "")]
           [s (regexp-replace* #rx"\n\n+" s "\n")]
           [s (regexp-replace* #rx"\n  [^\n]+\\.\\.\\.:(?:[^\n]+|\n   )+" s "")]
           [s (regexp-replace* #rx"\n" s "\n; ")]
           [s (if backtrace?
                (string-append s (if (regexp-match? #rx"\n" s) "\n; " " ") msg)
                s)])
      (with-wrapped-output (printf "; ~a\n" s)))))

;; ----------------------------------------------------------------------------
;; set up the xrepl environment

(provide setup-xrepl-environment)
(define (setup-xrepl-environment)
  (define (tweak param maker) (param (maker (param))))
  (tweak error-display-handler make-xrepl-display-handler)
  (tweak current-eval make-xrepl-evaluator)
  (tweak current-prompt-read make-xrepl-reader))