scheme/racket/geiser/user.rkt

   1 ;;; user.rkt -- global bindings visible to geiser users
   2
   3 ;; Copyright (C) 2010 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          mzlib/thread
  18          racket/tcp
  19          geiser/main
  20          geiser/enter
  21          geiser/eval
  22          geiser/modules)
  23
  24 (define top-namespace (current-namespace))
  25
  26 (define (enter! mod stx)
  27   (cond [(not mod) (current-namespace top-namespace)]
  28         [(module-path? mod)
  29          (enter-module mod)
  30          (current-namespace (module->namespace mod))]
  31         [else (raise-syntax-error
  32                #f
  33                "not a valid module path, and not #f"
  34                stx
  35                mod)]))
  36
  37 (define orig-loader (current-load/use-compiled))
  38 (define geiser-loader (module-loader orig-loader))
  39
  40 (define (geiser-eval)
  41   (define geiser-main (module->namespace 'geiser/main))
  42   (let* ([mod (read)]
  43          [lang (read)]
  44          [form (read)])
  45     (datum->syntax #f
  46                    (list 'quote
  47                          (cond [(equal? form '(unquote apply))
  48                                 (let* ([proc (eval (read) geiser-main)]
  49                                        [args (read)])
  50                                   (eval-in `(,proc ,@args) mod lang))]
  51                                [else ((geiser:eval lang) form mod)])))))
  52
  53 (define ((geiser-read prompt))
  54   (prompt)
  55   (flush-output)
  56   (let* ([in (current-input-port)]
  57          [form ((current-read-interaction) (object-name in) in)])
  58     (syntax-case form ()
  59       [(uq cmd) (eq? 'unquote (syntax-e #'uq))
  60        (case (syntax-e #'cmd)
  61          [(start-geiser) (datum->syntax #f `(list 'port ,(start-geiser)))]
  62          [(enter) (enter! (read) #'cmd)]
  63          [(geiser-eval) (geiser-eval)]
  64          [(geiser-no-values) (datum->syntax #f (void))]
  65          [else form])]
  66       [_ form])))
  67
  68 (define geiser-prompt
  69   (lambda ()
  70     (printf "racket@~a> " (namespace->module-name (current-namespace)))))
  71
  72 (define (geiser-prompt-read prompt)
  73   (make-repl-reader (geiser-read prompt)))
  74
  75 (define (init-geiser-repl)
  76   (compile-enforce-module-constants #f)
  77   (current-load/use-compiled geiser-loader)
  78   (current-prompt-read (geiser-prompt-read geiser-prompt)))
  79
  80 (define (run-geiser-repl in out enforce-module-constants)
  81   (parameterize [(compile-enforce-module-constants enforce-module-constants)
  82                  (current-input-port in)
  83                  (current-output-port out)
  84                  (current-error-port out)
  85                  (current-load/use-compiled geiser-loader)
  86                  (current-prompt-read (geiser-prompt-read geiser-prompt))]
  87     (read-eval-print-loop)))
  88
  89 (define server-channel (make-channel))
  90
  91 (define (run-geiser-server port enforce-module-constants)
  92   (run-server port
  93               (lambda (in out)
  94                 (run-geiser-repl in out enforce-module-constants))
  95               #f
  96               void
  97               (lambda (p _ __)
  98                 (let ([lsner (tcp-listen p)])
  99                   (let-values ([(_ p __ ___) (tcp-addresses lsner #t)])
 100                     (channel-put server-channel p)
 101                     lsner)))))
 102
 103 (define (start-geiser (port 0) (enforce-module-constants #f))
 104   (thread (lambda () (run-geiser-server port enforce-module-constants)))
 105   (channel-get server-channel))