Much progress

rmacs/buffer.rkt

@@ -14,15 +14,25 @@
          buffer-pos
          buffer-title
          buffer-group
+         buffer-modeset
+         buffer-column
+         buffer-add-mode!
+         buffer-remove-mode!
+         buffer-toggle-mode!
          buffer-size
          buffer-move-to!
          buffer-move-by!
+         buffer-start-of-line
+         buffer-end-of-line
+         buffer-move-to-start-of-line!
+         buffer-move-to-end-of-line!
          buffer-mark!
          buffer-clear-mark!
          buffer-mark-pos
          buffer-region-split
          buffer-region
          buffer-region-update!
+         buffer-insert!
          call-with-excursion
          buffer-search
          buffer-findf)
@@ -30,6 +40,7 @@
 (require "rope.rkt")
 (require "search.rkt")
 (require "circular-list.rkt")
+(require "mode.rkt")
 
 (require (only-in racket/string string-join))
 (require (only-in racket/path normalize-path))
@@ -44,6 +55,7 @@
                 [pos #:mutable]
                 [title #:mutable]
                 [group #:mutable] ;; (Option BufferGroup)
+                [modeset #:mutable] ;; ModeSet
                 ) #:prefab)
 
 (define (make-buffergroup)
@@ -55,7 +67,8 @@
   (register-buffer! group (buffer (string->rope initial-contents)
                                   0
                                   title
-                                  #f)))
+                                  #f
+                                  kernel-modeset)))
 
 (define (register-buffer! group buf)
   (define old-group (buffer-group buf))
@@ -114,7 +127,8 @@
     (buffer-region-update! b
                            (lambda (_dontcare) (string->rope (file->string filename)))
                            #:point 0
-                           #:mark (buffer-size b))))
+                           #:mark (buffer-size b))
+    (buffer-move-to! b 0)))
 
 (define (buffer-rename! b new-title)
   (if (title-exists-in-group? (buffer-group b) new-title)
@@ -136,8 +150,22 @@
 
 (define (buffer-size buf) (rope-size (buffer-rope buf)))
 
-(define (buffer-move-to! buf pos)
-  (set-buffer-pos! buf (max 0 (min (buffer-size buf) pos)))
+(define (buffer-column buf)
+  (- (buffer-pos buf) (buffer-start-of-line buf)))
+
+(define (buffer-add-mode! buf mode)
+  (set-buffer-modeset! buf (modeset-add-mode (buffer-modeset buf) mode)))
+(define (buffer-remove-mode! buf mode)
+  (set-buffer-modeset! buf (modeset-remove-mode (buffer-modeset buf) mode)))
+(define (buffer-toggle-mode! buf mode)
+  (set-buffer-modeset! buf (modeset-toggle-mode (buffer-modeset buf) mode)))
+
+(define (clamp pos buf)
+  (max 0 (min (buffer-size buf) pos)))
+
+(define (buffer-move-to! buf pos0)
+  (define pos (clamp pos0 buf))
+  (set-buffer-pos! buf pos)
   (buffer-seek! buf pos))
 
 (define (buffer-seek! buf pos)
@@ -146,10 +174,22 @@
 (define (buffer-move-by! buf delta)
   (buffer-move-to! buf (+ (buffer-pos buf) delta)))
 
-(define (buffer-mark! buf [mtype main-mark-type] #:position [pos (buffer-pos buf)] #:value [value #t])
+(define (buffer-start-of-line buf)
+  (buffer-findf buf (lambda (ch) (equal? ch #\newline)) #:forward? #f))
+
+(define (buffer-end-of-line buf)
+  (buffer-findf buf (lambda (ch) (equal? ch #\newline)) #:forward? #t))
+
+(define (buffer-move-to-start-of-line! buf)
+  (buffer-move-to! buf (buffer-start-of-line buf)))
+
+(define (buffer-move-to-end-of-line! buf)
+  (buffer-move-to! buf (buffer-end-of-line buf)))
+
+(define (buffer-mark! buf [pos (buffer-pos buf)] #:mark-type [mtype main-mark-type] #:value [value #t])
   (buffer-lift replace-mark buf mtype pos value))
 
-(define (buffer-clear-mark! buf [mtype main-mark-type])
+(define (buffer-clear-mark! buf #:mark-type [mtype main-mark-type])
   (define pos (find-mark-pos (buffer-rope buf) mtype))
   (if pos
       (buffer-lift clear-mark buf mtype pos)
@@ -159,11 +199,11 @@
   (find-mark-pos (buffer-rope buf) mtype))
 
 (define (buffer-region-split* buf pos mark)
-  (define lo (min pos mark))
-  (define hi (max pos mark))
+  (define lo (clamp (min pos mark) buf))
+  (define hi (clamp (max pos mark) buf))
   (define-values (l mr) (rope-split (buffer-rope buf) lo))
   (define-values (m r) (rope-split mr (- hi lo)))
-  (values l m r))
+  (values l lo m hi r))
 
 (define (buffer-region-split buf
                              #:point [pos (buffer-pos buf)]
@@ -173,29 +213,44 @@
 (define (buffer-region buf
                        #:point [pos (buffer-pos buf)]
                        #:mark [mark (buffer-mark-pos buf)])
-  (define-values (_l m _r) (buffer-region-split* buf pos mark))
+  (define-values (_l _lo m _hi _r) (buffer-region-split* buf pos mark))
   m)
 
 (define (buffer-region-update! buf updater
                                #:point [pos (buffer-pos buf)]
                                #:mark [mark (buffer-mark-pos buf)])
-  (define-values (l m r) (buffer-region-split* buf pos mark))
-  (set-buffer-rope! buf (rope-concat (list l (updater m) r)))
+  (define-values (l lo old-m hi r) (buffer-region-split* buf pos mark))
+  (define new-m (updater old-m))
+  (define delta (- (rope-size new-m) (rope-size old-m)))
+  (set-buffer-rope! buf (rope-append (rope-append l new-m) r))
+  (cond
+   [(<= lo (buffer-pos buf) hi) (buffer-move-to! buf (+ hi delta))]
+   [(> (buffer-pos buf) hi) (buffer-move-by! buf delta)]
+   [else buf]))
+
+(define (buffer-insert! buf content-rope
+                        #:point [pos0 (buffer-pos buf)]
+                        #:move? [move? #t])
+  (define pos (clamp pos0 buf))
+  (define-values (l r) (rope-split (buffer-rope buf) pos))
+  (set-buffer-rope! buf (rope-append (rope-append l content-rope) r))
+  (when (>= (buffer-pos buf) pos)
+    (set-buffer-pos! buf (+ (buffer-pos buf) (rope-size content-rope))))
   buf)
 
 (define (call-with-excursion buf f)
   (define excursion (gensym 'excursion))
   (define saved-mark-type (mark-type (format "Saved mark ~a" excursion) 'right))
   (define saved-point-type (mark-type (format "Saved point ~a" excursion) 'right))
-  (buffer-mark! buf saved-mark-type #:position (buffer-mark-pos buf))
-  (buffer-mark! buf saved-point-type #:position (buffer-pos buf))
+  (buffer-mark! buf (buffer-mark-pos buf) #:mark-type saved-mark-type)
+  (buffer-mark! buf (buffer-pos buf) #:mark-type saved-point-type)
   (define (restore!)
     (define restore-mark-pos (buffer-mark-pos buf saved-mark-type))
     (define restore-point-pos (buffer-mark-pos buf saved-point-type))
-    (when restore-mark-pos (buffer-mark! buf #:position restore-mark-pos))
+    (when restore-mark-pos (buffer-mark! buf restore-mark-pos))
     (when restore-point-pos (buffer-move-to! buf restore-point-pos))
-    (buffer-clear-mark! buf saved-mark-type)
-    (buffer-clear-mark! buf saved-point-type))
+    (buffer-clear-mark! buf #:mark-type saved-mark-type)
+    (buffer-clear-mark! buf #:mark-type saved-point-type))
   (with-handlers [(exn? (lambda (e)
                           (restore!)
                           (raise e)))]
@@ -203,15 +258,19 @@
     (restore!)
     result))
 
-(define (buffer-search* buf start-pos forward? move? find-delta)
+(define (buffer-search* buf start-pos0 forward? move? find-delta)
+  (define start-pos (clamp start-pos0 buf))
   (define-values (l r) (rope-split (buffer-rope buf) start-pos))
   (define delta (find-delta (if forward? r l)))
-  (define new-pos (+ start-pos (cond [(not delta) 0] [forward? delta] [else (- delta)])))
-  (when delta
-    (if move?
-        (buffer-move-to! buf new-pos)
-        (buffer-seek! buf new-pos)))
-  new-pos)
+  (and delta
+       (let ((new-pos (clamp (+ start-pos (cond [(not delta) 0]
+                                                [forward? delta]
+                                                [else (- delta (rope-size l))]))
+                             buf)))
+         (if move?
+             (buffer-move-to! buf new-pos)
+             (buffer-seek! buf new-pos))
+         new-pos)))
 
 (define (buffer-search buf needle
                        #:position [start-pos (buffer-pos buf)]

rmacs/display.rkt

@@ -12,6 +12,8 @@
          tty-goto
          tty-style
          tty-style-reset
+         tty-next-key
+         tty-next-key-evt
 
          ;; From ansi
          color-black
@@ -136,3 +138,10 @@
   (set-tty-rows! tty (position-report-row report))
   (set-tty-columns! tty (position-report-column report))
   tty)
+
+(define (tty-next-key tty)
+  (lex-lcd-input (tty-input tty)))
+
+(define (tty-next-key-evt tty)
+  (handle-evt (tty-input tty)
+              (lambda (_) (tty-next-key tty))))

rmacs/editor.rkt

@@ -4,23 +4,38 @@
          make-editor
          visit-file!
          render-editor!
+         current-editor-buffer
+         current-editor-modeset
+         editor-invoke-command
+         editor-mainloop
+         editor-request-shutdown!
          )
 
+(require racket/match)
+
 (require "buffer.rkt")
 (require "display.rkt")
 (require "window.rkt")
 (require "render.rkt")
+(require "mode.rkt")
+(require "keys.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
                 ) #:prefab)
 
-(define (make-editor)
+(define (make-editor [tty (stdin-tty)])
   (define g (make-buffergroup))
   (define scratch (make-buffer g "*scratch*" #:initial-contents ";; This is the scratch buffer."))
   (define w (make-window scratch))
-  (editor g (list (list w (relative-size 1))) w))
+  (editor g
+          tty
+          (list (list w (relative-size 1)))
+          w
+          #f))
 
 (define (visit-file! editor filename)
   (set-window-buffer! (editor-active-window editor)
@@ -28,5 +43,71 @@
                                     filename)))
 
 (define (render-editor! editor)
-  (render-windows! (editor-windows editor)
+  (render-windows! (editor-tty editor)
+                   (editor-windows editor)
                    (editor-active-window editor)))
+
+(define (current-editor-buffer editor)
+  (define w (editor-active-window editor))
+  (and w (window-buffer w)))
+
+(define (current-editor-modeset editor)
+  (define b (current-editor-buffer editor))
+  (and b (buffer-modeset b)))
+
+(define (root-keyseq-handler editor)
+  (modeset-keyseq-handler (current-editor-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))
+  (when (not cmd)
+    (error 'main "Unhandled command ~a (key sequence: ~a)"
+           selector
+           (keyseq->keyspec keyseq)))
+  (cmd editor prefix-arg keyseq))
+
+(define (editor-mainloop editor)
+  (when (editor-running? editor) (error 'editor-mainloop "Nested mainloop"))
+  (set-editor-running?! editor #t)
+  (with-handlers ([exn? (lambda (e)
+                          ;; TODO: proper error reporting
+                          (local-require ansi)
+                          (tty-restore!)
+                          (raise e))])
+    (let loop ((keys '())
+               (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))))))
+      (if (null? keys)
+          (wait-for-input handler)
+          (match (handler editor keys)
+            [(unbound-key-sequence)
+             (editor-invoke-command 'unbound-key-sequence editor #:keyseq keys)
+             (loop '() (root-keyseq-handler editor))]
+            [(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))
+                 (if (equal? input remaining-input)
+                     '()
+                     (cons (car input) (loop (cdr input))))))
+             (editor-invoke-command selector editor #:keyseq accepted-input #:prefix-arg prefix-arg)
+             (loop remaining-input (root-keyseq-handler editor))])))))
+
+(define (editor-request-shutdown! editor)
+  (set-editor-running?! editor #f))
+
+;;---------------------------------------------------------------------------
+
+(define-command kernel-mode (save-buffers-kill-terminal e)
+  #:bind-key "C-x C-c"
+  (editor-request-shutdown! e))

rmacs/keys.rkt

@@ -0,0 +1,228 @@
+#lang racket/base
+;; Keyspecs, keyseqs and keymaps
+
+(provide parse-key-sequence
+         keyspec->keyseq
+         key->keyspec
+         keyseq->keyspec
+         (struct-out keymap)
+         empty-keymap
+         keymap-update
+         keymap-bind
+         keymap-unbind
+         keymap-lookup)
+
+(require racket/set)
+(require racket/match)
+(require (only-in racket/list append-map))
+(require (only-in racket/string
+                  string-join
+                  string-split
+                  string-trim))
+
+(require ansi/lcd-terminal)
+
+;;---------------------------------------------------------------------------
+;; Key sequence parsing
+
+(define (read-string-to-end s)
+  (define p (open-input-string s))
+  (define result (read p))
+  (and (eof-object? (peek-char p))
+       result))
+
+(define (bad-key lexeme fmt . args)
+  (error 'parse-key-sequence "~a in key ~v" (apply format fmt args) (string-trim lexeme)))
+
+(define (parse-modifiers modifiers lexeme)
+  (for/set ((mod (string-split (string-upcase modifiers) "-")))
+    (match mod
+      ["C" 'control]
+      ["S" 'shift]
+      ["M" 'meta]
+      [_ (bad-key lexeme "Unknown modifier ~a" mod)])))
+
+(define (parse-key-sequence s)
+  (match s
+    [(pregexp "^ *#:default(( +.*)|$)" (list lexeme rest _))
+     (cons '#:default (parse-key-sequence rest))]
+    [(pregexp "^ *(([cCsSmM]-)*)\"([^\"]*)\"(.*)" (list lexeme modifiers _ stringspec rest))
+     (define mods (parse-modifiers modifiers lexeme))
+     (define seq (unknown-escape-sequence (or (read-string-to-end (format "\"~a\"" stringspec))
+                                              (bad-key lexeme "Bad raw input sequence"))))
+     (cons (key seq mods) (parse-key-sequence rest))]
+    [(pregexp "^ *(([cCsSmM]-)*)<([^>]+)>(( +.*)|$)" (list lexeme modifiers _ symname rest _))
+     (define mods (parse-modifiers modifiers lexeme))
+     (cons (key (string->symbol symname) mods)
+           (parse-key-sequence rest))]
+    [(pregexp "^ *(([cCsSmM]-)*)(?i:esc)(( +.*)|$)" (list lexeme modifiers _ rest _))
+     (define mods (parse-modifiers modifiers lexeme))
+     (cons (key #\[ (set-add mods 'control)) (parse-key-sequence rest))]
+    [(pregexp "^ *(([cCsSmM]-)*)([^ ]+)(( +.*)|$)" (list lexeme modifiers _ keystr rest _))
+     (define mods (parse-modifiers modifiers lexeme))
+     (define keychar (or (read-string-to-end (format "#\\~a" keystr))
+                         (bad-key lexeme "Bad single-character key")))
+     (cons (key (if (set-member? mods 'control)
+                    (char-upcase keychar)
+                    keychar)
+                mods)
+           (parse-key-sequence rest))]
+    [(pregexp "^ *$")
+     '()]
+    [_ (bad-key s "Unexpected junk")]))
+
+(define (keyspec->keyseq what original-keyspec)
+  (let convert ((keyspec original-keyspec))
+    (cond
+     [(key? keyspec) (list keyspec)]
+     [(keyword? keyspec) (list keyspec)]
+     [(string? keyspec) (parse-key-sequence keyspec)]
+     [(list? keyspec) (append-map convert keyspec)]
+     [else (error what "Invalid key specification: ~v" original-keyspec)])))
+
+(define (format-modifiers mods suffix)
+  (if (set-empty? mods)
+      suffix
+      (string-append (string-join (map (lambda (m)
+                                         (match m
+                                           ['control "C"]
+                                           ['shift "S"]
+                                           ['meta "M"]))
+                                       (set->list mods))
+                                  "-")
+                     "-"
+                     suffix)))
+
+(define (key->keyspec k)
+  (match k
+    [(? keyword?) (format "~a" k)]
+    [(key value modifiers)
+     (define-values (str updated-modifiers)
+       (match value
+         [(unknown-escape-sequence s)
+          (values (format "~v" s) modifiers)]
+         [(? symbol? s)
+          (values (format "<~a>" s) modifiers)]
+         [#\[ #:when (set-member? modifiers 'control)
+          (values "ESC" (set-remove modifiers 'control))]
+         [(? char? c)
+          (define s (format "~v" c))
+          (values (substring s 2 (string-length s)) modifiers)]))
+     (format-modifiers updated-modifiers str)]))
+
+(define (keyseq->keyspec keyseq)
+  (string-join (map key->keyspec keyseq) " "))
+
+;;---------------------------------------------------------------------------
+;; Keymaps
+
+(struct keymap (table
+                ) #:prefab)
+
+(define (empty-keymap)
+  (keymap (hash)))
+
+(define (keymap-update km keyspec updater)
+  (define original-keyseq (keyspec->keyseq 'keymap-bind keyspec))
+  (let loop ((prefix-rev '())
+             (keyseq original-keyseq)
+             (km km))
+    (match keyseq
+      ['() (updater (reverse prefix-rev) km original-keyseq)]
+      [(cons k rest)
+       (cond
+        [(keymap? km)
+         (let* ((new (loop (cons k prefix-rev) rest (hash-ref (keymap-table km) k #f)))
+                (newtab (if new
+                            (hash-set (keymap-table km) k new)
+                            (hash-remove (keymap-table km) k))))
+           (if (hash-empty? newtab)
+               #f
+               (struct-copy keymap km [table newtab])))]
+        [(not km)
+         (loop prefix-rev keyseq (empty-keymap))]
+        [else
+         (error 'keymap-update
+                "Cannot update keyspec ~v, as a shorter prefix ~v exists"
+                (keyseq->keyspec original-keyseq)
+                (keyseq->keyspec (reverse prefix-rev)))])])))
+
+(define (keymap-bind km keyspec command)
+  (keymap-update km keyspec (lambda (prefix oldval newseq)
+                              (if oldval
+                                  (error 'keymap-bind "Cannot bind ~v, as prefix ~v exists"
+                                         (keyseq->keyspec newseq)
+                                         (keyseq->keyspec prefix))
+                                  command))))
+
+(define (keymap-bind* km specs-and-commands)
+  (match specs-and-commands
+    ['() km]
+    [(cons (list keyspec command) rest) (keymap-bind* (keymap-bind km keyspec command) rest)]))
+
+(define (keymap-unbind km keyspec)
+  (or (keymap-update km keyspec (lambda (prefix oldval newseq) #f))
+      (empty-keymap)))
+
+(define (keymap-lookup km keyspec)
+  (define original-keyseq (keyspec->keyseq 'keymap-lookup keyspec))
+  (let loop ((keyseq original-keyseq)
+             (km km))
+    (match keyseq
+      ['() (values km keyseq)]
+      [(cons k rest)
+       (match km
+         [(keymap table) (loop rest (or (hash-ref table k #f)
+                                        (hash-ref table '#:default #f)))]
+         [_ (values km keyseq)])])))
+
+;;---------------------------------------------------------------------------
+
+(module+ test
+  (require rackunit racket/pretty)
+
+  (check-equal? (parse-key-sequence "<") (list (key #\< (set))))
+  (check-equal? (parse-key-sequence ">") (list (key #\> (set))))
+  (check-equal? (parse-key-sequence "#:default #:default")
+                (list '#:default '#:default))
+  (check-equal? (parse-key-sequence "esc ESC")
+                (list (key #\[ (set 'control))
+                      (key #\[ (set 'control))))
+
+  (define km (keymap-bind* (empty-keymap) (list (list "C-x o" 'other-window)
+                                                (list "C-x 2" 'split-window)
+                                                (list "C-x 1" 'delete-other-windows)
+                                                (list "C-x 0" 'delete-window))))
+  (check-equal? km
+                (keymap (hash (key #\X (set 'control))
+                              (keymap (hash (key #\o (set)) 'other-window
+                                            (key #\2 (set)) 'split-window
+                                            (key #\1 (set)) 'delete-other-windows
+                                            (key #\0 (set)) 'delete-window)))))
+  (set! km (keymap-unbind km "C-x 1"))
+  (check-equal? km
+                (keymap (hash (key #\X (set 'control))
+                              (keymap (hash (key #\o (set)) 'other-window
+                                            (key #\2 (set)) 'split-window
+                                            (key #\0 (set)) 'delete-window)))))
+  (check-equal? (keymap-unbind (keymap-unbind km "C-x 2") "C-x 0")
+                (keymap (hash (key #\X (set 'control))
+                              (keymap (hash (key #\o (set)) 'other-window)))))
+  (check-equal? (keymap-unbind (keymap-unbind (keymap-unbind km "C-x 2") "C-x 0") "C-x o")
+                (empty-keymap))
+  (check-equal? (keymap-unbind km "C-x")
+                (empty-keymap))
+
+  (define (lookup s)
+    (define-values (result remaining-input) (keymap-lookup km s))
+    (list result remaining-input))
+
+  (check-equal? (lookup "C-x") (list (keymap (hash (key #\o (set)) 'other-window
+                                                   (key #\2 (set)) 'split-window
+                                                   (key #\0 (set)) 'delete-window))
+                                     '()))
+  (check-equal? (lookup "C-x 1") (list #f '()))
+  (check-equal? (lookup "C-x 2") (list 'split-window '()))
+  (check-equal? (lookup "C-c") (list #f '()))
+  (check-equal? (lookup "C-c C-c") (list #f (list (key #\C (set 'control)))))
+  )

rmacs/main.rkt

@@ -1,19 +1,17 @@
 #lang racket/base
 
-(require "editor.rkt")
-(require "render.rkt")
 (require racket/match)
 
+(require "editor.rkt")
+(require "buffer.rkt")
+(require "mode/fundamental.rkt")
+
 (define (main)
-  (with-handlers ([exn? (lambda (e)
-                          (local-require ansi)
-                          (tty-restore!)
-                          (raise e))])
-    (define e (make-editor))
-    (visit-file! e (build-path (collection-file-path "main.rkt" "rmacs")
-                               'up 'up "doc" "xterm_controls.txt"))
-    (render-editor! e))
-  (sleep 2))
+  (define e (make-editor))
+  (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
   (void (main)))

rmacs/mode.rkt

@@ -0,0 +1,258 @@
+#lang racket/base
+;; Modes and modesets.
+
+(provide (struct-out mode)
+         (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
+         make-mode
+         mode-add-constraints
+         mode-keymap-bind!
+         mode-keymap-unbind!
+         mode-keymap-rebind!
+         mode-define-command!
+         mode-undefine-command!
+         mode-redefine-command!
+
+         make-modeset
+         modeset-add-mode
+         modeset-remove-mode
+         modeset-toggle-mode
+         modeset-keyseq-handler
+         modeset-lookup-command
+
+         kernel-mode
+         kernel-modeset
+
+         define-key
+         define-command)
+
+(require racket/set)
+(require racket/match)
+(require (only-in racket/list filter-map))
+(require (for-syntax syntax/parse))
+(require (for-syntax racket/base))
+
+(require "keys.rkt")
+(require "topsort.rkt")
+
+(struct mode (id
+              name
+              [keymap #:mutable]
+              [commands #:mutable]
+              dispatch-keys-before
+              dispatch-keys-after
+              interpret-commands-before
+              interpret-commands-after
+              ) #:prefab)
+
+(struct modeset (modes
+                 key-dispatch-order
+                 command-interpretation-order
+                 ) #:prefab)
+
+(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)
+  (mode (gensym name)
+        name
+        (empty-keymap)
+        (hasheq)
+        (seteq)
+        (seteq)
+        (seteq)
+        (seteq)))
+
+(define (mode-add-constraints m
+                              #:dispatch-keys-before [kb '()]
+                              #:dispatch-keys-after [ka '()]
+                              #:interpret-commands-before [cb '()]
+                              #:interpret-commands-after [ca '()])
+  (define (convert modes) (list->seteq (for/list ((m modes))
+                                         (if (keyword? m)
+                                             m
+                                             (mode-id m)))))
+  (struct-copy mode m
+               [dispatch-keys-before
+                (set-union (mode-dispatch-keys-before m) (convert kb))]
+               [dispatch-keys-after
+                (set-union (mode-dispatch-keys-after m) (convert ka))]
+               [interpret-commands-before
+                (set-union (mode-interpret-commands-before m) (convert cb))]
+               [interpret-commands-after
+                (set-union (mode-interpret-commands-after m) (convert ca))]))
+
+(define (make-mode name)
+  (mode-add-constraints (make-raw-mode name)
+                        #:dispatch-keys-before '(#:kernel)
+                        #:interpret-commands-before '(#:kernel)))
+
+(define (mode-keymap-bind! m keyspec command)
+  (set-mode-keymap! m (keymap-bind (mode-keymap m) keyspec command))
+  m)
+
+(define (mode-keymap-unbind! m keyspec)
+  (set-mode-keymap! m (keymap-unbind (mode-keymap m) keyspec))
+  m)
+
+(define (mode-keymap-rebind! m keyspec command)
+  (mode-keymap-bind! (mode-keymap-unbind! m keyspec) keyspec command))
+
+(define (mode-define-command! m selector handler)
+  (when (hash-has-key? (mode-commands m) selector)
+    (error 'mode-define-command!
+           "Duplicate command handler for ~a in mode ~a"
+           selector
+           (mode-id m)))
+  (set-mode-commands! m (hash-set (mode-commands m) selector handler))
+  m)
+
+(define (mode-undefine-command! m selector)
+  (set-mode-commands! m (hash-remove (mode-commands m) selector))
+  m)
+
+(define (mode-redefine-command! m selector handler)
+  (mode-define-command! (mode-undefine-command! m selector) selector handler))
+
+(define (make-modeset)
+  (modeset (hasheq)
+           '()
+           '()))
+
+(define (modeset-add-mode ms m)
+  (compute-modeset-orders
+   (struct-copy modeset ms [modes (hash-set (modeset-modes ms)
+                                            (mode-id m)
+                                            m)])))
+
+(define (modeset-remove-mode ms m)
+  (compute-modeset-orders
+   (struct-copy modeset ms [modes (hash-remove (modeset-modes ms) (mode-id m))])))
+
+(define (modeset-toggle-mode ms m)
+  ((if (hash-has-key? (modeset-modes ms) (mode-id m)) modeset-remove-mode modeset-add-mode)
+   ms
+   m))
+
+(define (edges ms before-getter after-getter)
+  (for/fold [(es '())]
+            [(m (in-hash-values (modeset-modes ms)))]
+    (define mid (mode-id m))
+    (append (for/list [(nid (before-getter m))] (list mid nid))
+            (for/list [(nid (after-getter m))] (list nid mid))
+            es)))
+
+(define (compute-modeset-order ms what before-getter after-getter)
+  (or (topsort (edges ms before-getter after-getter) #:comparison eq?)
+      (error 'compute-modeset-orders "Inconsistent ~a order: ~v"
+             (hash-keys (modeset-modes ms)))))
+
+(define (compute-modeset-orders ms)
+  (struct-copy modeset ms
+   [key-dispatch-order (compute-modeset-order ms
+                                              "key dispatch"
+                                              mode-dispatch-keys-before
+                                              mode-dispatch-keys-after)]
+   [command-interpretation-order (compute-modeset-order ms
+                                                        "command interpretation"
+                                                        mode-interpret-commands-before
+                                                        mode-interpret-commands-after)]))
+
+(define (order->modes ms order-getter)
+  (define modes (modeset-modes ms))
+  (filter-map (lambda (id) (hash-ref modes id #f)) (order-getter ms)))
+
+(define (modeset-keyseq-handler ms)
+  (let handler-for-maps ((maps (map mode-keymap (order->modes ms modeset-key-dispatch-order))))
+    (lambda (e ks)
+      (define results (map (lambda (km)
+                             (define-values (result remaining-input) (keymap-lookup km ks))
+                             (list result remaining-input)) maps))
+      (let process-results ((results results))
+        (match results
+          ['() (unbound-key-sequence)]
+          [(cons (list result remaining-input) rest)
+           (cond
+            [(not result) (process-results rest)]
+            [(keymap? result) (incomplete-key-sequence
+                               (handler-for-maps (filter keymap? (map car results))))]
+            [(procedure? result)
+             (if (null? remaining-input)
+                 (incomplete-key-sequence result)
+                 (result e remaining-input))]
+            [else (command-invocation result '#:default remaining-input)])])))))
+
+(define (modeset-lookup-command ms selector)
+  (let search ((tables (map mode-commands
+                            (order->modes ms modeset-command-interpretation-order))))
+    (match tables
+      ['() #f]
+      [(cons table rest)
+       (define handler (hash-ref table selector #f))
+       (if handler
+           (lambda (e prefix-arg ks)
+             (handler e
+                      (lambda ([prefix-arg prefix-arg] [ks ks])
+                        (define next-method (search rest))
+                        (when next-method (next-method e prefix-arg ks)))
+                      selector
+                      prefix-arg
+                      ks))
+           (search rest))])))
+
+(define kernel-mode
+  (mode-add-constraints (make-raw-mode "kernel")
+                        #:dispatch-keys-after '(#:kernel)
+                        #:interpret-commands-after '(#:kernel)))
+
+(define kernel-modeset
+  (modeset-add-mode (make-modeset) kernel-mode))
+
+;;---------------------------------------------------------------------------
+
+(define-syntax-rule (define-key mode-exp keyspec-exp command-symbol)
+  (mode-keymap-bind! mode-exp keyspec-exp 'command-symbol))
+
+(define-syntax define-command
+  (lambda (stx)
+    (syntax-parse stx
+      [(_ mode-exp
+          (selector editor
+                    (~or (~optional (~seq #:next-method next-method)
+                                    #:defaults ([next-method #'nm])
+                                    #:name "#:next-method")
+                         (~optional (~seq #:prefix-arg
+                                          (~or (~seq [prefix-arg prefix-default prefix-prefix])
+                                               (~seq [prefix-arg prefix-default])
+                                               prefix-arg))
+                                    #:defaults ([prefix-arg #'pa]
+                                                [prefix-default #''#:default]
+                                                [prefix-prefix #''#:prefix])
+                                    #:name "#:prefix-arg")
+                         (~optional (~seq #:selector self-selector)
+                                    #:defaults ([self-selector #'self])
+                                    #:name "#:self-selector")
+                         (~optional (~seq #:keyseq keyseq)
+                                    #:defaults ([keyseq #'keyseq])
+                                    #:name "#:keyseq"))
+                    ...)
+          (~seq #:bind-key bind-keyspec-exps) ...
+          body ...)
+       #`(let ((mode mode-exp))
+           (mode-define-command! mode 'selector
+                                 (lambda (editor next-method self-selector prefix-arg keyseq)
+                                   (let ((prefix-arg (match prefix-arg
+                                                       ['#:default prefix-default]
+                                                       ['#:prefix prefix-prefix]
+                                                       [_ prefix-arg])))
+                                     body ...)))
+           #,@(for/list ((bind-keyspec-exp (syntax->list #'(bind-keyspec-exps ...))))
+                #`(mode-keymap-bind! mode #,bind-keyspec-exp 'selector))
+           (void))])))

rmacs/mode/fundamental.rkt

@@ -0,0 +1,136 @@
+#lang racket/base
+
+(provide fundamental-mode)
+
+(require ansi/lcd-terminal)
+(require "../mode.rkt")
+(require "../editor.rkt")
+(require "../buffer.rkt")
+(require "../keys.rkt")
+(require "../rope.rkt")
+
+(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))))
+  (when (char? ch)
+    (buffer-insert! (current-editor-buffer e) (string->rope (string ch)))))
+
+(define-command fundamental-mode (unbound-key-sequence e #:keyseq keyseq)
+  (editor-invoke-command 'self-insert-command e #:keyseq keyseq))
+
+(define-key fundamental-mode (list "C-q" '#:default) self-insert-command)
+
+(define-command fundamental-mode (newline e)
+  #:bind-key "C-m"
+  #:bind-key "C-j"
+  (buffer-insert! (current-editor-buffer e) (string->rope "\n")))
+
+(define (move-forward-n-lines buf count)
+  (for ((i count))
+    (buffer-move-to-end-of-line! buf)
+    (buffer-move-by! buf 1)))
+
+(define (move-backward-n-lines buf count)
+  (for ((i count))
+    (buffer-move-to-start-of-line! buf)
+    (buffer-move-by! buf -1)))
+
+(define (move-to-column buf col)
+  (define eol-pos (buffer-end-of-line buf))
+  (buffer-move-to-start-of-line! buf)
+  (buffer-move-by! buf (min col (- eol-pos (buffer-pos buf)))))
+
+(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))
+
+(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)))
+
+(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 col (buffer-column buf))
+  (move-forward-n-lines buf count)
+  (move-to-column buf col))
+
+(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 col (buffer-column buf))
+  (move-backward-n-lines buf count)
+  (move-to-column buf col))
+
+(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))
+  (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))
+  (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))
+  (buffer-region-update! buf
+                         (lambda (_deleted) (empty-rope))
+                         #:mark (- (buffer-pos buf) count)))
+
+(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))
+  (buffer-region-update! buf
+                         (lambda (_deleted) (empty-rope))
+                         #:mark (+ (buffer-pos buf) count)))
+
+(define-command fundamental-mode (beginning-of-buffer e #:prefix-arg [tenths 0])
+  #:bind-key "M-<"
+  #:bind-key "C-<home>"
+  #:bind-key "<begin>"
+  (define buf (current-editor-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))
+  (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 m (buffer-mark-pos buf))
+  (when m
+    (define p (buffer-pos buf))
+    (buffer-mark! buf p)
+    (buffer-move-to! buf m)))
+
+(define-command fundamental-mode (set-mark-command e #:prefix-arg arg)
+  #:bind-key "C-@"
+  #:bind-key "C-space"
+  (define buf (current-editor-buffer e))
+  (if (eq? arg '#:prefix)
+      (let ((m (buffer-mark-pos buf)))
+        (and m (buffer-move-to! buf m)))
+      (buffer-mark! buf)))

rmacs/render.rkt

@@ -27,20 +27,21 @@
 ;; Ensures the given mark is sanely positioned as a top-of-window mark
 ;; with respect to the given cursor position. Returns the
 ;; top-of-window position.
-(define (frame-buffer! buf window-height
+(define (frame-buffer! buf available-line-count
                        #:preferred-position-fraction [preferred-position-fraction 1/2])
   (define old-top-of-window-pos (or (buffer-mark-pos buf top-of-window-mtype) 0))
-  (define preferred-distance-from-bottom (ceiling (* window-height (- 1 preferred-position-fraction))))
+  (define preferred-distance-from-bottom
+    (ceiling (* available-line-count (- 1 preferred-position-fraction))))
   (let loop ((pos (buffer-findf buf newline? #:forward? #f))
              (line-count 0)
              (top-of-window-pos old-top-of-window-pos))
     (define new-top-of-window-pos
       (if (= line-count preferred-distance-from-bottom) pos top-of-window-pos))
     (cond
-     [(<= pos old-top-of-window-pos)
+     [(= pos old-top-of-window-pos)
       old-top-of-window-pos]
-     [(= line-count window-height)
-      (buffer-mark! buf top-of-window-mtype #:position new-top-of-window-pos)
+     [(>= line-count (- available-line-count 1))
+      (buffer-mark! buf new-top-of-window-pos #:mark-type top-of-window-mtype)
       new-top-of-window-pos]
      [else
       (loop (buffer-findf buf newline? #:forward? #f #:position (- pos 1))
@@ -59,7 +60,8 @@
              #:background-color color-white))
 
 (define (render-buffer! t b window-top window-height is-active?)
-  (define top-of-window-pos (frame-buffer! b window-height))
+  (define available-line-count (- window-height 1))
+  (define top-of-window-pos (frame-buffer! b available-line-count))
   (define cursor-pos (buffer-pos b))
   (tty-goto t window-top 0)
   (tty-body-style t is-active?)
@@ -68,7 +70,7 @@
                (sol-pos top-of-window-pos)
                (cursor-coordinates #f))
       (cond
-       [(>= line-count (- window-height 1))
+       [(>= line-count available-line-count)
         cursor-coordinates]
        [else
         (define eol-pos (buffer-findf b newline? #:position sol-pos))
@@ -115,11 +117,10 @@
                (list (list w offset remaining))
                '()))])))
 
-(define (render-windows! ws active-window)
-  (define t (stdin-tty))
+(define (render-windows! t ws active-window)
   (define layout (layout-windows ws (tty-rows t)))
   (tty-body-style t #f)
-  (tty-clear t)
+  (tty-goto t 0 0)
   (define active-cursor-position
     (for/fold [(cursor-position #f)] [(e layout)]
       (match-define (list w window-top window-height) e)

rmacs/rope.rkt

@@ -315,8 +315,7 @@
 
 (define (replace-mark r0 mtype new-pos new-value)
   (define pos (find-mark-pos r0 mtype))
-  (when (not pos) (error 'replace-mark "Mark ~a not found" mtype))
-  (set-mark (clear-mark r0 mtype pos) mtype new-pos new-value))
+  (set-mark (if pos (clear-mark r0 mtype pos) r0) mtype new-pos new-value))
 
 (define (clear-all-marks r)
   (and r

rmacs/topsort.rkt

@@ -0,0 +1,54 @@
+#lang racket/base
+
+(provide topsort)
+
+(require racket/match)
+
+(define (topsort edges
+                 #:comparison [comparison equal?])
+  (define hash-ctor (cond [(eq? comparison equal?) hash]
+                          [(eq? comparison eq?) hasheq]
+                          [else (error 'topsort "Invalid comparison ~v" comparison)]))
+  (define-values (fwd rev)
+    (for/fold [(fwd (hash-ctor)) (rev (hash-ctor))]
+              [(edge edges)]
+      (match-define (list source target) edge)
+      (values (hash-set fwd source (hash-set (hash-ref fwd source hash-ctor) target #t))
+              (hash-set rev target (hash-set (hash-ref rev target hash-ctor) source #t)))))
+  (define roots (for/fold [(roots (hash-ctor))]
+                          [(source (in-hash-keys fwd))]
+                  (if (hash-has-key? rev source)
+                      roots
+                      (hash-set roots source #t))))
+
+  (if (hash-empty? roots)
+      (if (and (hash-empty? fwd) (hash-empty? rev))
+          '() ;; no nodes at all
+          #f) ;; no nodes without incoming edges -> cycle
+      (let/ec return
+        (define seen (hash-ctor))
+        (define busy (hash-ctor))
+        (define acc '())
+
+        (define (visit-nodes nodes)
+          (for ((n nodes))
+            (when (hash-has-key? busy n) (return #f)) ;; cycle
+            (when (not (hash-has-key? seen n))
+              (set! busy (hash-set busy n #t))
+              (visit-nodes (hash-keys (hash-ref fwd n hash-ctor)))
+              (set! seen (hash-set seen n #t))
+              (set! busy (hash-remove busy n))
+              (set! acc (cons n acc)))))
+
+        (visit-nodes (hash-keys roots))
+        acc)))
+
+(module+ test
+  (require rackunit)
+  (check-equal? (topsort '()) '())
+  (check-equal? (topsort '((1 1))) #f)
+  (check-equal? (topsort '((1 0) (0 1))) #f)
+  (check-equal? (topsort '((1 2) (1 3) (3 2) (3 4) (4 0) (0 1))) #f)
+  (check-equal? (topsort '((1 2) (1 3) (3 2) (3 4) (4 1) (0 1))) #f)
+  (check-equal? (topsort '((1 2) (1 3) (3 2) (3 4) (0 1))) '(0 1 3 4 2)) ;; others also valid
+  )