More progress

rmacs/buffer.rkt

@@ -6,6 +6,7 @@
          make-buffer
          register-buffer!
          lookup-buffer
+         unused-buffer-title
          file->buffer
          buffer-rename!
          buffer-reorder!
@@ -16,6 +17,7 @@
          buffer-group
          buffer-modeset
          buffer-column
+         buffer-apply-modeset!
          buffer-add-mode!
          buffer-remove-mode!
          buffer-toggle-mode!
@@ -33,6 +35,7 @@
          buffer-region
          buffer-region-update!
          buffer-insert!
+         buffer-replace-contents!
          call-with-excursion
          buffer-search
          buffer-findf)
@@ -61,10 +64,17 @@
 (define (make-buffergroup)
   (buffergroup circular-empty))
 
+(define (initial-contents-rope initial-contents)
+  (cond
+   [(string? initial-contents) (string->rope initial-contents)]
+   [(rope? initial-contents) initial-contents]
+   [(procedure? initial-contents) (initial-contents-rope (initial-contents))]
+   [else (error 'initial-contents-rope "Invalid initial-contents: ~v" initial-contents)]))
+
 (define (make-buffer group ;; (Option BufferGroup)
                      title ;; String
                      #:initial-contents [initial-contents ""])
-  (register-buffer! group (buffer (string->rope initial-contents)
+  (register-buffer! group (buffer (initial-contents-rope initial-contents)
                                   0
                                   title
                                   #f
@@ -98,13 +108,9 @@
 (define (title-exists-in-group? group title)
   (and (title->buffer* group title) #t))
 
-;; (Option Group) Path -> String
+(define (unused-buffer-title group context-pieces)
-(define (filename->unique-buffer-title group filename)
+  (define primary-piece (if (null? context-pieces) "*anonymous*" (car context-pieces)))
-  (define pieces (reverse (map path->string (explode-path filename))))
+  (define uniquifiers (if (null? context-pieces) '() (cdr context-pieces)))
-  (define primary-piece (car pieces))
-  (define uniquifiers (cdr pieces))
-  (if (not group)
-      primary-piece
   (let search ((used '()) (remaining uniquifiers))
     (define candidate
       (if (null? used)
@@ -118,16 +124,20 @@
               (if (title-exists-in-group? group candidate)
                   (search (+ counter 1))
                   candidate)))
-            candidate))))
+        candidate)))
+
+;; (Option Group) Path -> String
+(define (filename->unique-buffer-title group filename)
+  (define pieces (reverse (map path->string (explode-path filename))))
+  (if (not group)
+      (car pieces)
+      (unused-buffer-title group pieces)))
 
 (define (file->buffer group filename)
   (let* ((filename (normalize-path (simplify-path filename)))
          (title (filename->unique-buffer-title group filename))
          (b (make-buffer group title)))
-    (buffer-region-update! b
+    (buffer-replace-contents! b (string->rope (file->string filename)))
-                           (lambda (_dontcare) (string->rope (file->string filename)))
-                           #:point 0
-                           #:mark (buffer-size b))
     (buffer-move-to! b 0)))
 
 (define (buffer-rename! b new-title)
@@ -153,6 +163,9 @@
 (define (buffer-column buf)
   (- (buffer-pos buf) (buffer-start-of-line buf)))
 
+(define (buffer-apply-modeset! buf modeset)
+  (set-buffer-modeset! buf modeset))
+
 (define (buffer-add-mode! buf mode)
   (set-buffer-modeset! buf (modeset-add-mode (buffer-modeset buf) mode)))
 (define (buffer-remove-mode! buf mode)
@@ -238,6 +251,9 @@
     (set-buffer-pos! buf (+ (buffer-pos buf) (rope-size content-rope))))
   buf)
 
+(define (buffer-replace-contents! buf content-rope)
+  (buffer-region-update! buf (lambda (_dontcare) content-rope) #:point 0 #:mark (buffer-size buf)))
+
 (define (call-with-excursion buf f)
   (define excursion (gensym 'excursion))
   (define saved-mark-type (mark-type (format "Saved mark ~a" excursion) 'right))

rmacs/display.rkt

@@ -25,6 +25,7 @@
          color-cyan
          color-white)
 
+(require racket/set)
 (require racket/match)
 (require ansi)
 
@@ -140,7 +141,13 @@
   tty)
 
 (define (tty-next-key tty)
-  (lex-lcd-input (tty-input tty)))
+  (define k (lex-lcd-input (tty-input tty)))
+  (if (equal? k (key #\[ (set 'control))) ;; ESC
+      (or (sync/timeout 0.5
+                        (handle-evt (tty-next-key-evt tty)
+                                    (lambda (k) (add-modifier 'meta k))))
+          k)
+      k))
 
 (define (tty-next-key-evt tty)
   (handle-evt (tty-input tty)

rmacs/editor.rkt

@@ -4,8 +4,8 @@
          make-editor
          visit-file!
          render-editor!
-         current-editor-buffer
+         editor-active-buffer
-         current-editor-modeset
+         editor-active-modeset
          editor-invoke-command
          editor-mainloop
          editor-request-shutdown!
@@ -19,89 +19,122 @@
 (require "render.rkt")
 (require "mode.rkt")
 (require "keys.rkt")
+(require "rope.rkt")
 
 (struct editor (buffers ;; BufferGroup
                 [tty #:mutable] ;; Tty
                 [windows #:mutable] ;; (List (List Window SizeSpec)), abstract window layout
                 [active-window #:mutable] ;; (Option Window)
                 [running? #:mutable] ;; Boolean
+                [default-modeset #:mutable] ;; ModeSet
                 ) #:prefab)
 
-(define (make-editor [tty (stdin-tty)])
+(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."))
   (define w (make-window scratch))
-  (editor g
+  (define e (editor g
                     tty
                     (list (list w (relative-size 1)))
                     w
-          #f))
+                    #f
+                    default-modeset))
+  (configure-fresh-buffer! e 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 (open-window editor buffer
+                     #:size [size (relative-size 1)]
+                     #:activate? [activate? #t])
+  (define w (make-window buffer))
+  (set-editor-windows! editor (append (editor-windows editor) (list (list w size))))
+  (when activate? (set-editor-active-window! editor w))
+  w)
 
 (define (visit-file! editor filename)
   (set-window-buffer! (editor-active-window editor)
-                      (file->buffer (editor-buffers editor)
+                      (configure-fresh-buffer! editor
-                                    filename)))
+                                               (file->buffer (editor-buffers editor) filename))))
 
 (define (render-editor! editor)
   (render-windows! (editor-tty editor)
                    (editor-windows editor)
                    (editor-active-window editor)))
 
-(define (current-editor-buffer editor)
+(define (editor-active-buffer editor)
   (define w (editor-active-window editor))
   (and w (window-buffer w)))
 
-(define (current-editor-modeset editor)
+(define (editor-active-modeset editor)
-  (define b (current-editor-buffer editor))
+  (define b (editor-active-buffer editor))
   (and b (buffer-modeset b)))
 
 (define (root-keyseq-handler editor)
-  (modeset-keyseq-handler (current-editor-modeset editor)))
+  (modeset-keyseq-handler (editor-active-modeset editor)))
 
 (define (editor-invoke-command selector editor
                                #:keyseq [keyseq #f]
                                #:prefix-arg [prefix-arg '#:default])
-  (define cmd (modeset-lookup-command (current-editor-modeset editor) selector))
+  (define cmd (modeset-lookup-command (editor-active-modeset editor) selector))
   (when (not cmd)
-    (error 'main "Unhandled command ~a (key sequence: ~a)"
+    (error 'editor-invoke-command "Unhandled command ~a (key sequence: ~a)"
            selector
            (keyseq->keyspec keyseq)))
   (cmd editor prefix-arg keyseq))
 
+(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)
+  (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 (e)
+  (with-handlers* ([exn? (lambda (exc)
-                          ;; TODO: proper error reporting
+                           (set-editor-running?! editor #f)
-                          (local-require ansi)
+                           (open-debugger editor exc)
-                          (tty-restore!)
+                           (editor-mainloop editor))])
-                          (raise e))])
+    (let loop ((total-keyseq '())
-    (let loop ((keys '())
+               (input '())
                (handler (root-keyseq-handler editor)))
       (define (wait-for-input next-handler)
         (render-editor! editor)
         (when (editor-running? editor)
           (sync (handle-evt (tty-next-key-evt (editor-tty editor))
                             (lambda (new-key)
-                              (loop (list new-key) next-handler))))))
+                              (define new-input (list new-key))
-      (if (null? keys)
+                              (loop (append total-keyseq new-input) new-input next-handler))))))
+      (if (null? input)
           (wait-for-input handler)
-          (match (handler editor keys)
+          (match (handler editor input)
             [(unbound-key-sequence)
-             (editor-invoke-command 'unbound-key-sequence editor #:keyseq keys)
+             (if (editor-invoke-command 'unbound-key-sequence editor #:keyseq total-keyseq)
-             (loop '() (root-keyseq-handler editor))]
+                 (loop '() '() (root-keyseq-handler editor))
+                 (error 'editor-mainloop "Unbound key sequence: ~a"
+                        (keyseq->keyspec total-keyseq)))]
             [(incomplete-key-sequence next-handler)
              (wait-for-input next-handler)]
-            [(key-macro-expansion new-keys)
-             (loop new-keys (root-keyseq-handler editor))]
             [(command-invocation selector prefix-arg remaining-input)
              (define accepted-input
-               (let loop ((input keys))
+               (let remove-tail ((keyseq total-keyseq))
-                 (if (equal? input remaining-input)
+                 (if (equal? keyseq remaining-input)
                      '()
-                     (cons (car input) (loop (cdr input))))))
+                     (cons (car keyseq) (remove-tail (cdr keyseq))))))
              (editor-invoke-command selector editor #:keyseq accepted-input #:prefix-arg prefix-arg)
-             (loop remaining-input (root-keyseq-handler editor))])))))
+             (loop '() remaining-input (root-keyseq-handler editor))])))))
 
 (define (editor-request-shutdown! editor)
   (set-editor-running?! editor #f))

rmacs/keys.rkt

@@ -107,7 +107,8 @@
           (values "ESC" (set-remove modifiers 'control))]
          [(? char? c)
           (define s (format "~v" c))
-          (values (substring s 2 (string-length s)) modifiers)]))
+          (define maybe-downcase (if (set-member? modifiers 'control) string-downcase values))
+          (values (maybe-downcase (substring s 2 (string-length s))) modifiers)]))
      (format-modifiers updated-modifiers str)]))
 
 (define (keyseq->keyspec keyseq)

rmacs/main.rkt

@@ -4,13 +4,14 @@
 
 (require "editor.rkt")
 (require "buffer.rkt")
+(require "mode.rkt")
 (require "mode/fundamental.rkt")
 
 (define (main)
-  (define e (make-editor))
+  (define e (make-editor #:default-modeset (modeset-add-mode kernel-modeset
+                                                             fundamental-mode)))
   (visit-file! e (build-path (collection-file-path "main.rkt" "rmacs")
                              'up 'up "doc" "xterm_controls.txt"))
-  (buffer-add-mode! (current-editor-buffer e) fundamental-mode)
   (editor-mainloop e))
 
 (module+ main

rmacs/mode.rkt

@@ -5,7 +5,6 @@
          (struct-out modeset)
          (struct-out incomplete-key-sequence)
          (struct-out unbound-key-sequence)
-         (struct-out key-macro-expansion)
          (struct-out command-invocation)
 
          make-raw-mode
@@ -57,7 +56,6 @@
 
 (struct incomplete-key-sequence (handler) #:prefab)
 (struct unbound-key-sequence () #:prefab)
-(struct key-macro-expansion (keys) #:prefab)
 (struct command-invocation (selector prefix-arg remaining-input) #:prefab)
 
 (define (make-raw-mode name)

rmacs/mode/fundamental.rkt

@@ -2,6 +2,8 @@
 
 (provide fundamental-mode)
 
+(require racket/set)
+(require racket/match)
 (require ansi/lcd-terminal)
 (require "../mode.rkt")
 (require "../editor.rkt")
@@ -11,15 +13,12 @@
 
 (define fundamental-mode (make-mode "fundamental"))
 
-(void (mode-keymap-bind! fundamental-mode
-                         "ESC"
-                         (lambda (e ks)
-                           (key-macro-expansion (cons (add-modifier 'meta (car ks)) (cdr ks))))))
-
 (define-command fundamental-mode (self-insert-command e #:keyseq keyseq)
-  (define ch (key-value (car (reverse keyseq))))
+  (log-info "self-insert-command ~a" (keyseq->keyspec keyseq))
-  (when (char? ch)
+  (match keyseq
-    (buffer-insert! (current-editor-buffer e) (string->rope (string ch)))))
+    [(list (key (? char? ch) modifiers)) #:when (set-empty? (set-remove modifiers 'shift))
+     (buffer-insert! (editor-active-buffer e) (string->rope (string ch)))]
+    [_ #f]))
 
 (define-command fundamental-mode (unbound-key-sequence e #:keyseq keyseq)
   (editor-invoke-command 'self-insert-command e #:keyseq keyseq))
@@ -29,7 +28,7 @@
 (define-command fundamental-mode (newline e)
   #:bind-key "C-m"
   #:bind-key "C-j"
-  (buffer-insert! (current-editor-buffer e) (string->rope "\n")))
+  (buffer-insert! (editor-active-buffer e) (string->rope "\n")))
 
 (define (move-forward-n-lines buf count)
   (for ((i count))
@@ -49,17 +48,17 @@
 (define-command fundamental-mode (forward-char e #:prefix-arg [count 1])
   #:bind-key "C-f"
   #:bind-key "<right>"
-  (buffer-move-by! (current-editor-buffer e) count))
+  (buffer-move-by! (editor-active-buffer e) count))
 
 (define-command fundamental-mode (backward-char e #:prefix-arg [count 1])
   #:bind-key "C-b"
   #:bind-key "<left>"
-  (buffer-move-by! (current-editor-buffer e) (- count)))
+  (buffer-move-by! (editor-active-buffer e) (- count)))
 
 (define-command fundamental-mode (next-line e #:prefix-arg [count 1])
   #:bind-key "C-n"
   #:bind-key "<down>"
-  (define buf (current-editor-buffer e))
+  (define buf (editor-active-buffer e))
   (define col (buffer-column buf))
   (move-forward-n-lines buf count)
   (move-to-column buf col))
@@ -67,7 +66,7 @@
 (define-command fundamental-mode (prev-line e #:prefix-arg [count 1])
   #:bind-key "C-p"
   #:bind-key "<up>"
-  (define buf (current-editor-buffer e))
+  (define buf (editor-active-buffer e))
   (define col (buffer-column buf))
   (move-backward-n-lines buf count)
   (move-to-column buf col))
@@ -75,21 +74,21 @@
 (define-command fundamental-mode (move-end-of-line e #:prefix-arg [count 1])
   #:bind-key "C-e"
   #:bind-key "<end>"
-  (define buf (current-editor-buffer e))
+  (define buf (editor-active-buffer e))
   (when (positive? count) (move-forward-n-lines buf (- count 1)))
   (buffer-move-to-end-of-line! buf))
 
 (define-command fundamental-mode (move-beginning-of-line e #:prefix-arg [count 1])
   #:bind-key "C-a"
   #:bind-key "<home>"
-  (define buf (current-editor-buffer e))
+  (define buf (editor-active-buffer e))
   (when (positive? count) (move-forward-n-lines buf (- count 1)))
   (buffer-move-to-start-of-line! buf))
 
 (define-command fundamental-mode (delete-backward-char e #:prefix-arg [count 1])
   #:bind-key "<backspace>"
   #:bind-key "C-h" ;; differs from GNU emacs
-  (define buf (current-editor-buffer e))
+  (define buf (editor-active-buffer e))
   (buffer-region-update! buf
                          (lambda (_deleted) (empty-rope))
                          #:mark (- (buffer-pos buf) count)))
@@ -97,7 +96,7 @@
 (define-command fundamental-mode (delete-forward-char e #:prefix-arg [count 1])
   #:bind-key "<delete>"
   #:bind-key "C-d"
-  (define buf (current-editor-buffer e))
+  (define buf (editor-active-buffer e))
   (buffer-region-update! buf
                          (lambda (_deleted) (empty-rope))
                          #:mark (+ (buffer-pos buf) count)))
@@ -106,20 +105,20 @@
   #:bind-key "M-<"
   #:bind-key "C-<home>"
   #:bind-key "<begin>"
-  (define buf (current-editor-buffer e))
+  (define buf (editor-active-buffer e))
   (if (eq? tenths '#:prefix) (set! tenths 0) (buffer-mark! buf))
   (buffer-move-to! buf (* (buffer-size buf) (max 0 (min 10 tenths)) 1/10)))
 
 (define-command fundamental-mode (end-of-buffer e #:prefix-arg [tenths 0])
   #:bind-key "M->"
   #:bind-key "C-<end>"
-  (define buf (current-editor-buffer e))
+  (define buf (editor-active-buffer e))
   (if (eq? tenths '#:prefix) (set! tenths 0) (buffer-mark! buf))
   (buffer-move-to! buf (* (buffer-size buf) (- 10 (max 0 (min 10 tenths))) 1/10)))
 
 (define-command fundamental-mode (exchange-point-and-mark e)
   #:bind-key "C-x C-x"
-  (define buf (current-editor-buffer e))
+  (define buf (editor-active-buffer e))
   (define m (buffer-mark-pos buf))
   (when m
     (define p (buffer-pos buf))
@@ -129,7 +128,7 @@
 (define-command fundamental-mode (set-mark-command e #:prefix-arg arg)
   #:bind-key "C-@"
   #:bind-key "C-space"
-  (define buf (current-editor-buffer e))
+  (define buf (editor-active-buffer e))
   (if (eq? arg '#:prefix)
       (let ((m (buffer-mark-pos buf)))
         (and m (buffer-move-to! buf m)))

rmacs/render.rkt

@@ -59,6 +59,35 @@
              #:foreground-color color-black
              #:background-color color-white))
 
+(define (format-line line window-width cursor-input-pos)
+  (let loop ((chars (string->list line))
+             (remaining-width window-width)
+             (cursor-input-pos cursor-input-pos)
+             (acc-rev '())
+             (cursor-offset (if (zero? cursor-input-pos) 0 #f)))
+    (define (finish) (values (list->string (reverse acc-rev)) cursor-offset))
+    (match chars
+      ['() (finish)]
+      [(cons c rest)
+       (define (emit str)
+         (define needed (string-length str))
+         (if (>= remaining-width needed)
+             (loop rest
+                   (- remaining-width needed)
+                   (- cursor-input-pos 1)
+                   (append (reverse (string->list str)) acc-rev)
+                   (if (zero? cursor-input-pos)
+                       (length acc-rev)
+                       cursor-offset))
+             (finish)))
+       (match c
+         [#\tab
+          (emit (make-string (- 8 (modulo (length acc-rev) 8)) #\space))]
+         [(? char-iso-control?)
+          (emit (format "[~x]" (char->integer c)))]
+         [_
+          (emit (string c))])])))
+
 (define (render-buffer! t b window-top window-height is-active?)
   (define available-line-count (- window-height 1))
   (define top-of-window-pos (frame-buffer! b available-line-count))
@@ -75,14 +104,15 @@
        [else
         (define eol-pos (buffer-findf b newline? #:position sol-pos))
         (define line (rope->string (buffer-region b #:point eol-pos #:mark sol-pos)))
-        (tty-display t line)
+        (define-values (formatted-line cursor-offset)
+          (format-line line (tty-columns t) (- cursor-pos sol-pos)))
+        (tty-display t formatted-line)
         (tty-clear-to-eol t)
         (tty-newline t)
         (loop (+ line-count 1)
               (+ eol-pos 1)
-              (if (<= sol-pos cursor-pos eol-pos)
+              (if cursor-offset
-                  (list (+ line-count window-top)
+                  (list (+ line-count window-top) cursor-offset)
-                        (- cursor-pos sol-pos))
                   cursor-coordinates))])))
   (tty-statusline-style t is-active?)
   (tty-display t (if is-active? "== " "-- ") (buffer-title b) " ")