racket/collects/mred/private/repl.ss

(module repl mzscheme
  (require (lib "class.ss")
	   (lib "class100.ss")
	   (prefix wx: "kernel.ss")
	   "editor.ss"
	   "app.ss"
	   "mrtop.ss"
	   "mrcanvas.ss"
	   "mrmenu.ss"
	   "filedialog.ss")

  (provide graphical-read-eval-print-loop)

  (define (-graphical-read-eval-print-loop user-esp override-ports?)
    ;; The REPL buffer class
    (define esq:text%
      (class100 text% ()
	(inherit insert last-position get-text erase change-style clear-undos)
	(rename [super-on-char on-char])
	(private-field [prompt-pos 0] [locked? #f])
	(augment
	 [can-insert? (lambda (start end) (and (>= start prompt-pos) (not locked?)))]
	 [can-delete? (lambda (start end) (and (>= start prompt-pos) (not locked?)))])
	(override
	  [on-char (lambda (c)
		     (super-on-char c)
		     (when (and (memq (send c get-key-code) '(#\return #\newline #\003))
				(not locked?))
		       (set! locked? #t)
		       (evaluate (get-text prompt-pos (last-position)))))])
	(public
	  [new-prompt (lambda ()
			(output "> ")
			(set! prompt-pos (last-position))
			(set! locked? #f)
			(clear-undos))]
	  [output (lambda (str)
		    (let ([l? locked?])
		      (set! locked? #f)
		      (insert str)
		      (set! locked? l?)))]
	  [reset (lambda ()
		   (set! locked? #f)
		   (set! prompt-pos 0)
		   (erase)
		   (new-prompt))])
	(sequence 
	  (super-init)
	  (let ([s (last-position)]
		[m (regexp-match #rx"^(.*), (Copyright.*)$" (banner))])
	    (insert (format "Welcome to ~a." (cadr m)))
	    (let ([e (last-position)])
	      (insert #\newline)
	      (change-style (send (make-object wx:style-delta% 'change-bold) set-delta-foreground "BLUE") s e))
	    (output (caddr m)))
	  (insert "This is a simple window for evaluating MrEd Scheme expressions.") (insert #\newline)
	  (let ([s (last-position)])
	    (insert "Quit now and run DrScheme to get a better window.")
	    (let ([e (last-position)])
	      (insert #\newline)
	      (change-style
	       (send (make-object wx:style-delta% 'change-italic) set-delta-foreground "RED")
	       s e)))
	  (insert "The current input port always returns eof.") (insert #\newline)
	  (new-prompt))))

    ;; GUI creation
    (define frame (make-object (class100 frame% args
				 (inherit accept-drop-files)
				 (augment
				  [on-close (lambda () 
					      (custodian-shutdown-all user-custodian)
					      (semaphore-post waiting))])
				 (override
				   [on-drop-file (lambda (f) (evaluate (format "(load ~s)" (path->string f))))])
				 (sequence 
				   (apply super-init args) (accept-drop-files #t)))
			       "MrEd REPL" #f 500 400))
    (define repl-buffer (make-object esq:text%))
    (define repl-display-canvas (new editor-canvas% [parent frame] [style '(no-border auto-hscroll resize-corner)]))

    (define esq-eventspace (wx:current-eventspace))
    (define (queue-output proc)
      (parameterize ((wx:current-eventspace esq-eventspace))
	(wx:queue-callback proc #f)))
    
    ;; User space initialization
    (define user-custodian (make-custodian))
    
    (define user-output-port
      (let ([leftover #""]
	    [cvt (bytes-open-converter "UTF-8-permissive" "UTF-8")])
	(make-output-port
	 'console
	 always-evt
	 (lambda (s start end flush? breakable?) 
	   (queue-output (lambda () 
			   ;; s might end in the middle of a UTF-8 encoding.
			   ;;  Get a complete prefix, and save the rest.
			   (let ([s (bytes-append leftover (subbytes s start end))])
			     (let-values ([(res used status) (bytes-convert cvt s)])
			       (send repl-buffer output (bytes->string/utf-8 res))
			       (set! leftover (subbytes s used))))))
	   (- end start))
	 void))) ; no close action
    
    (define user-eventspace
      (or user-esp
	  (parameterize ((current-custodian user-custodian))
	    (wx:make-eventspace))))

    ;; Evaluation
    
    (define (evaluate expr-str)
      (parameterize ((wx:current-eventspace user-eventspace))
	(wx:queue-callback
	 (lambda ()
	   (dynamic-wind
	       void
	       (lambda () 
		 (call-with-values
		     (lambda () (eval (read (open-input-string expr-str))))
		   (lambda results
		     (for-each 
		      (lambda (v) 
			(parameterize ([current-output-port user-output-port])
			  (print v) 
			  (newline)))
		      results))))
	       (lambda ()
		 (queue-output (lambda () (send repl-buffer new-prompt)))))))))

    (define waiting (make-semaphore 0))

    (let ([mb (make-object menu-bar% frame)])
      (let ([m (make-object menu% "&File" mb)])
	(make-object menu-item% "Load File..." m (lambda (i e) (let ([f (get-file #f frame)]) 
								 (and f 
								      (evaluate (format "(load ~s)" (path->string f)))))))
	(unless (current-eventspace-has-standard-menus?)
	  (make-object menu-item% 
		       (if (eq? (system-type) 'windows)
			   "E&xit"
			   "&Quit")
		       m (lambda (i e) (send frame on-close) (send frame show #f)) #\q)))
      (let ([m (make-object menu% "&Edit" mb)])
	(append-editor-operation-menu-items m #f)))

    ;; Just a few extra key bindings:
    ((current-text-keymap-initializer) (send repl-buffer get-keymap))
    (send repl-buffer auto-wrap #t)

    ;; Go
    (when override-ports?
      (parameterize ((wx:current-eventspace user-eventspace))
	(wx:queue-callback
	 (lambda ()
	   (current-output-port user-output-port)
	   (current-error-port user-output-port)
	   (current-input-port (open-input-bytes #"")))
	 #t)))

    (send repl-display-canvas set-editor repl-buffer)

    (send frame show #t)
    
    (send repl-display-canvas focus)

    (wx:yield waiting))

  (define graphical-read-eval-print-loop
    (case-lambda
     [() (-graphical-read-eval-print-loop #f #t)]
     [(esp)
      (graphical-read-eval-print-loop esp (not esp))]
     [(esp override-ports?)
      (unless (or (not esp) (wx:eventspace? esp))
	(raise-type-error 'graphical-read-eval-print-loop "eventspace or #f" esp))
      (-graphical-read-eval-print-loop esp override-ports?)])))