racket-ansi/rmacs/editor.rkt

284 lines
12 KiB
Racket

#lang racket/base
(provide (except-out (struct-out editor) editor)
make-editor
window-layout
window-width
window-height
open-window
close-other-windows
close-window
resize-window
select-window
visit-file!
render-editor!
editor-next-window
editor-prev-window
editor-command
editor-active-buffer
editor-active-modeset
editor-mainloop
editor-request-shutdown!
editor-force-redisplay!)
(require racket/match)
(require "buffer.rkt")
(require "display.rkt")
(require "window.rkt")
(require "render.rkt")
(require "mode.rkt")
(require "keys.rkt")
(require "rope.rkt")
(require "circular-list.rkt")
(struct editor (buffers ;; BufferGroup
[tty #:mutable] ;; Tty
[windows #:mutable] ;; (CircularList (List Window SizeSpec)), abstract window layout
[active-window #:mutable] ;; (Option Window)
[running? #:mutable] ;; Boolean
[default-modeset #:mutable] ;; ModeSet
[layout #:mutable] ;; (Option (List Layout))
) #:prefab)
(define (make-editor #:tty [tty (stdin-tty)]
#:default-modeset [default-modeset (make-modeset)])
(define g (make-buffergroup))
(define scratch (make-buffer g "*scratch*"
#:initial-contents ";; This is the scratch buffer.\n\n"))
(define w (make-window scratch))
(define ws (list->circular-list (list (list w (relative-size 1)))))
(define e (editor g tty ws w #f default-modeset #f))
(initialize-buffergroup! g e)
(configure-fresh-buffer! e scratch)
(window-move-to! w (buffer-size scratch))
e)
(define (configure-fresh-buffer! editor buffer)
(buffer-apply-modeset! buffer (editor-default-modeset editor))
buffer)
(define (find-buffer editor [title0 #f] #:initial-contents [initial-contents ""])
(define g (editor-buffers editor))
(define title (or title0 (unused-buffer-title g '())))
(or (lookup-buffer g title)
(configure-fresh-buffer! editor (make-buffer g title #:initial-contents initial-contents))))
(define (split-size s)
(match s
[(absolute-size _) s] ;; can't scale fixed-size windows
[(relative-size w) (relative-size (/ w 2))]))
(define (merge-sizes surviving disappearing)
(match* (surviving disappearing)
[((relative-size a) (relative-size b)) (relative-size (+ a b))]
[(_ _) surviving]))
(define (window-for-buffer editor buffer)
(cond [(circular-list-memf (lambda (e) (eq? (window-buffer (car e)) buffer))
(editor-windows editor)) => (compose car circular-car)]
[else #f]))
(define (entry-for? window) (lambda (e) (eq? (car e) window)))
(define (invalidate-layout! editor)
(set-editor-layout! editor #f))
(define (layout! editor)
(when (not (editor-layout editor))
(set-editor-layout! editor (layout-windows (circular-list->list (editor-windows editor))
(tty-columns (editor-tty editor))
(tty-rows (editor-tty editor)))))
(editor-layout editor))
(define (window-layout editor win)
(cond [(memf (lambda (l) (eq? (layout-window l) win)) (layout! editor)) => car]
[else #f]))
(define ((-layout-accessor- getter) editor window)
(cond [(window-layout editor window) => getter]
[else #f]))
(define window-size-spec (-layout-accessor- layout-size-spec))
(define window-width (-layout-accessor- layout-width))
(define window-height (-layout-accessor- layout-height))
(define (update-window-entry editor win updater)
(set-editor-windows! editor (circular-list-replacef (editor-windows editor)
(entry-for? win)
updater))
(invalidate-layout! editor))
(define (open-window editor buffer
#:after-window [after-window (editor-active-window editor)]
#:proportional? [proportional? #f]
#:activate? [activate? #t])
(define existing-w (window-for-buffer editor buffer))
(define existing-size (window-size-spec editor after-window))
(define new-size (if proportional? existing-size (split-size existing-size)))
(define new-point (or (and existing-w (buffer-mark-pos* buffer (window-point existing-w))) 0))
(define new-window (make-window buffer #:point new-point))
(update-window-entry editor after-window
(lambda (e) (list (list after-window new-size)
(list new-window new-size))))
(when activate? (set-editor-active-window! editor new-window))
new-window)
(define (close-other-windows editor win)
(for ((entry (circular-list->list (editor-windows editor))) #:when (not (eq? (car entry) win)))
(set-window-buffer! (car entry) #f))
(set-editor-windows! editor (list->circular-list (list (list win (relative-size 1)))))
(set-editor-active-window! editor win)
(invalidate-layout! editor))
(define (close-window editor win)
(define prev (editor-prev-window editor win))
(define prev-size (window-size-spec editor prev))
(define win-size (window-size-spec editor win))
(when (and prev (> (circular-length (editor-windows editor)) 1))
(when (eq? (editor-active-window editor) win) (set-editor-active-window! editor prev))
(update-window-entry editor win (lambda (e) '()))
(resize-window editor prev (merge-sizes prev-size win-size))))
(define (resize-window editor win size)
(update-window-entry editor win (lambda (e) (list (list win size)))))
(define (select-window editor win)
(set-editor-active-window! editor win))
(define (visit-file! editor filename)
(set-window-buffer! (editor-active-window editor)
(configure-fresh-buffer! editor
(file->buffer (editor-buffers editor) filename))))
(define (render-editor! editor)
(render-windows! (editor-tty editor)
(layout! editor)
(editor-active-window editor)))
(define (editor-active-buffer editor)
(define w (editor-active-window editor))
(and w (window-buffer w)))
(define (editor-active-modeset editor)
(define b (editor-active-buffer editor))
(and b (buffer-modeset b)))
(define (editor-next-window editor win)
(cond [(circular-list-memf (entry-for? win)
(editor-windows editor)) => (compose car
circular-car
circular-list-rotate-forward)]
[else #f]))
(define (editor-prev-window editor win)
(cond [(circular-list-memf (entry-for? win)
(editor-windows editor)) => (compose car
circular-car
circular-list-rotate-backward)]
[else #f]))
(define (editor-command selector editor
#:keyseq [keyseq #f]
#:prefix-arg [prefix-arg '#:default])
(window-command selector (editor-active-window editor) #:keyseq keyseq #:prefix-arg prefix-arg))
(define (root-keyseq-handler editor)
(modeset-keyseq-handler (editor-active-modeset editor)))
(define *error-count* 0)
(define (open-debugger editor exc)
(local-require (only-in web-server/private/util exn->string))
(define error-report (exn->string exc))
(log-error "Exception:\n~a\n" error-report)
(set! *error-count* (+ *error-count* 1))
(when (>= *error-count* 3) (exit))
(define b (find-buffer editor "*Error*"))
(buffer-replace-contents! b (string->rope error-report))
(open-window editor b))
(define (editor-mainloop editor)
(when (editor-running? editor) (error 'editor-mainloop "Nested mainloop"))
(set-editor-running?! editor #t)
(with-handlers* ([exn? (lambda (exc)
(set-editor-running?! editor #f)
(open-debugger editor exc)
(editor-mainloop editor))])
(let loop ((total-keyseq '())
(input '())
(handler (root-keyseq-handler editor))
(next-repaint-deadline 0))
(define (request-repaint) (or next-repaint-deadline (+ (current-inexact-milliseconds) 20)))
(define (wait-for-input next-handler)
(when (editor-running? editor)
(sync (if next-repaint-deadline
(handle-evt (alarm-evt next-repaint-deadline)
(lambda (_)
(loop total-keyseq '() next-handler next-repaint-deadline)))
never-evt)
(handle-evt (tty-next-key-evt (editor-tty editor))
(lambda (new-key)
(define new-input (list new-key))
(loop (append total-keyseq new-input)
new-input
next-handler
next-repaint-deadline))))))
(cond
[(and next-repaint-deadline (>= (current-inexact-milliseconds) next-repaint-deadline))
(render-editor! editor)
(loop total-keyseq input handler #f)]
[(null? input)
(wait-for-input handler)]
[else
(match (handler editor input)
[(unbound-key-sequence)
(if (invoke (editor-command 'unbound-key-sequence editor #:keyseq total-keyseq))
(loop '() '() (root-keyseq-handler editor) (request-repaint))
(error 'editor-mainloop "Unbound key sequence: ~a"
(keyseq->keyspec total-keyseq)))]
[(incomplete-key-sequence next-handler)
(wait-for-input next-handler)]
[(command-invocation selector prefix-arg remaining-input)
(define accepted-input
(let remove-tail ((keyseq total-keyseq))
(if (equal? keyseq remaining-input)
'()
(cons (car keyseq) (remove-tail (cdr keyseq))))))
(invoke (editor-command selector editor #:keyseq accepted-input #:prefix-arg prefix-arg))
(loop '() remaining-input (root-keyseq-handler editor) (request-repaint))])]))))
(define (editor-request-shutdown! editor)
(set-editor-running?! editor #f))
(define (editor-force-redisplay! editor)
(tty-reset (editor-tty editor))
(invalidate-layout! editor))
;;---------------------------------------------------------------------------
(define-command kernel-mode (save-buffers-kill-terminal buf #:editor ed)
#:bind-key "C-x C-c"
(editor-request-shutdown! ed))
(define-command kernel-mode (force-redisplay buf #:editor ed)
#:bind-key "C-l"
(editor-force-redisplay! ed))
(define-command kernel-mode (dump-buffer-to-stderr buf #:window win)
#:bind-key "C-M-x"
(local-require racket/pretty)
(log-info "")
(log-info "--------------------------------------------------------------------------------")
(log-info "--------------------------------------------------------------------------------")
(log-info "========================================================================= WINDOW")
(log-info "id ~v" (window-id win))
(log-info "top ~v ~v" (window-top win) (buffer-mark-pos* buf (window-top win)))
(log-info "point ~v ~v" (window-point win) (buffer-mark-pos* buf (window-point win)))
(log-info "mark ~v ~v" (window-mark win) (buffer-mark-pos* buf (window-mark win)))
(log-info "title ~v" (buffer-title buf))
(log-info "rope:")
(pretty-write (buffer-rope buf) (current-error-port))
(log-info "modeset:")
(pretty-write (buffer-modeset buf) (current-error-port))
(log-info "--------------------------------------------------------------------------------"))