scheme/racket/geiser/user.rkt

   1 ;;; user.rkt -- global bindings visible to geiser users
   2
   3 ;; Copyright (C) 2010, 2011, 2012 Jose Antonio Ortega Ruiz
   4
   5 ;; This program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the Modified BSD License. You should
   7 ;; have received a copy of the license along with this program. If
   8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
   9
  10 ;; Start date: Wed Mar 31, 2010 22:24
  11
  12 #lang racket/base
  13
  14 (provide init-geiser-repl run-geiser-server start-geiser)
  15
  16 (require (for-syntax racket/base)
  17          file/convertible
  18          mzlib/thread
  19          racket/file
  20          racket/pretty
  21          racket/tcp
  22          geiser
  23          geiser/enter
  24          geiser/eval
  25          geiser/modules)
  26
  27 (define top-namespace (current-namespace))
  28 (define last-entered (make-parameter ""))
  29
  30 (define (do-enter mod name)
  31   (enter-module mod)
  32   (current-namespace (module->namespace mod))
  33   (last-entered name))
  34
  35 (define (enter! mod stx)
  36   (cond [(not mod)
  37          (current-namespace top-namespace)
  38          (last-entered "")]
  39         [(symbol? mod) (do-enter mod (symbol->string mod))]
  40         [(and (list? mod)
  41               (= 2 (length mod))
  42               (eq? 'file (car mod))
  43               (path-string? (cadr mod))) (do-enter mod (cadr mod))]
  44         [(path-string? mod) (do-enter `(file ,mod) mod)]
  45         [else (raise-syntax-error
  46                #f
  47                "not a valid module path, and not #f"
  48                stx
  49                mod)]))
  50
  51 (define orig-loader (current-load/use-compiled))
  52 (define geiser-loader (module-loader orig-loader))
  53
  54 (define (geiser-eval)
  55   (define geiser-main (module->namespace 'geiser))
  56   (define (eval-here form) (eval form geiser-main))
  57   (let* ([mod (read)]
  58          [lang (read)]
  59          [form (read)])
  60     (datum->syntax #f
  61                    (list 'quote
  62                          (cond [(equal? form '(unquote apply))
  63                                 (let* ([proc (eval-here (read))]
  64                                        [args (map eval-here (read))]
  65                                        [ev (lambda () (apply proc args))])
  66                                   (eval-in `(,ev) mod lang))]
  67                                [else ((geiser:eval lang) form mod)])))))
  68
  69 (define ((geiser-read prompt))
  70   (prompt)
  71   (flush-output)
  72   (let* ([in ((current-get-interaction-input-port))]
  73          [form ((current-read-interaction) (object-name in) in)])
  74     (syntax-case form ()
  75       [(uq cmd) (eq? 'unquote (syntax-e #'uq))
  76        (case (syntax-e #'cmd)
  77          [(start-geiser) (datum->syntax #f `(list 'port ,(start-geiser)))]
  78          [(enter) (enter! (read) #'cmd)]
  79          [(geiser-eval) (geiser-eval)]
  80          [(geiser-no-values) (datum->syntax #f (void))]
  81          [(add-to-load-path) (add-to-load-path (read))]
  82          [(set-image-cache) (image-cache (read))]
  83          [(image-cache) (image-cache)]
  84          [(gcd) (current-directory)]
  85          [(cd) (current-directory (read))]
  86          [else form])]
  87       [_ form])))
  88
  89 (define geiser-prompt
  90   (lambda ()
  91     (printf "racket@~a> "
  92             (namespace->module-name (current-namespace) (last-entered)))))
  93
  94 (define image-cache
  95   (let ([ensure-dir (lambda (dir)
  96                       (and (path-string? dir)
  97                            (begin (make-directory* dir) dir)))])
  98     (make-parameter #f ensure-dir)))
  99
 100 (define (geiser-prompt-read prompt)
 101   (make-repl-reader (geiser-read prompt)))
 102
 103 (define (geiser-save-tmpimage imgbytes)
 104   ;; Save imgbytes to a new temporary file and return the filename
 105   (define filename (make-temporary-file "geiser-img-~a.png" #f (image-cache)))
 106   (with-output-to-file filename #:exists 'truncate
 107     (lambda () (display imgbytes)))
 108   filename)
 109
 110 (define (geiser-maybe-print-image value)
 111   (cond
 112    [(and (convertible? value)
 113          (convert value 'png-bytes))
 114     => (lambda (pngbytes)
 115          ;; (The above could be problematic if a future version of racket
 116          ;; suddenly decides it can "convert" strings to picts)
 117          (printf "#<Image: ~a>\n" (geiser-save-tmpimage pngbytes)))]
 118    [else
 119     (unless (void? value)
 120       (pretty-print value))]))
 121
 122 (define (init-geiser-repl)
 123   (compile-enforce-module-constants #f)
 124   (current-load/use-compiled geiser-loader)
 125   (current-prompt-read (geiser-prompt-read geiser-prompt))
 126   (current-print geiser-maybe-print-image))
 127
 128 (define (run-geiser-repl in out enforce-module-constants)
 129   (parameterize [(compile-enforce-module-constants enforce-module-constants)
 130                  (current-input-port in)
 131                  (current-output-port out)
 132                  (current-error-port out)
 133                  (current-load/use-compiled geiser-loader)
 134                  (current-prompt-read (geiser-prompt-read geiser-prompt))
 135                  (current-print geiser-maybe-print-image)]
 136     (read-eval-print-loop)))
 137
 138 (define server-channel (make-channel))
 139
 140 (define (run-geiser-server port enforce-module-constants)
 141   (run-server port
 142               (lambda (in out)
 143                 (run-geiser-repl in out enforce-module-constants))
 144               #f
 145               void
 146               (lambda (p _ __)
 147                 (let ([lsner (tcp-listen p)])
 148                   (let-values ([(_ p __ ___) (tcp-addresses lsner #t)])
 149                     (channel-put server-channel p)
 150                     lsner)))))
 151
 152 (define (start-geiser (port 0) (enforce-module-constants #f))
 153   (thread (lambda () (run-geiser-server port enforce-module-constants)))
 154   (channel-get server-channel))