save-buffer

rmacs/buffer.rkt

@@ -8,14 +8,19 @@
          register-buffer!
          lookup-buffer
          unused-buffer-title
-         file->buffer
+         load-buffer
+         revert-buffer!
+         save-buffer!
          buffer-rename!
          buffer-reorder!
          buffer-next
          buffer-prev
          buffer-title
+         buffer-dirty?
+         buffer-source
          buffer-rope
          buffer-group
+         mark-buffer-clean!
          buffer-editor
          buffer-modeset
          buffer-string-column-count
@@ -71,6 +76,7 @@
 (require "circular-list.rkt")
 (require "mode.rkt")
 (require "keys.rkt")
+(require "file.rkt")
 
 (struct buffer-mark-type (kind ;; Symbol
                           window-id ;; Symbol
@@ -85,6 +91,8 @@
                 [title #:mutable]
                 [group #:mutable] ;; (Option BufferGroup)
                 [modeset #:mutable] ;; ModeSet
+                [dirty? #:mutable] ;; Boolean
+                [source #:mutable] ;; (Option BufferSource)
                 ) #:prefab)
 
 (struct command (selector ;; Symbol
@@ -117,7 +125,9 @@
   (register-buffer! group (buffer (initial-contents-rope initial-contents)
                                   title
                                   #f
-                                  kernel-modeset)))
+                                  kernel-modeset
+                                  #f
+                                  #f)))
 
 (define (register-buffer! group buf)
   (define old-group (buffer-group buf))
@@ -166,18 +176,21 @@
                   candidate)))
         candidate)))
 
-;; (Option Group) Path -> String
+(define (load-buffer group src)
-(define (filename->unique-buffer-title group filename)
+  (define pieces (buffer-source-title-pieces src))
-  (define pieces (reverse (map path->string (explode-path filename))))
+  (define title (if (not group) (car pieces) (unused-buffer-title group pieces)))
-  (if (not group)
+  (define b (make-buffer group title))
-      (car pieces)
+  (set-buffer-source! b src)
-      (unused-buffer-title group pieces)))
+  (revert-buffer! b)
+  b)
 
-(define (file->buffer group filename)
+(define (revert-buffer! buf)
-  (let* ((filename (normalize-path (simplify-path filename)))
+  (buffer-replace-contents! buf (string->rope (buffer-source-read (buffer-source buf))))
-         (title (filename->unique-buffer-title group filename))
+  (mark-buffer-clean! buf))
-         (b (make-buffer group title)))
+
-    (buffer-replace-contents! b (string->rope (file->string filename)))))
+(define (save-buffer! buf)
+  (buffer-source-write (buffer-source buf) (rope->string (buffer-rope buf)))
+  (mark-buffer-clean! buf))
 
 (define (buffer-rename! b new-title)
   (if (title-exists-in-group? (buffer-group b) new-title)
@@ -199,6 +212,9 @@
 
 (define (buffer-size buf) (rope-size (buffer-rope buf)))
 
+(define (mark-buffer-clean! buf)
+  (set-buffer-dirty?! buf #f))
+
 (define (buffer-editor b)
   (define g (buffer-group b))
   (and g (buffergroup-editor g)))
@@ -324,12 +340,14 @@
   (define new-m (transfer-marks old-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))
+  (set-buffer-dirty?! buf #t)
   buf)
 
 (define (buffer-insert! buf pos-or-mtype content-rope)
   (define pos (->pos buf pos-or-mtype 'buffer-insert!))
   (define-values (l r) (rope-split (buffer-rope buf) pos))
   (set-buffer-rope! buf (rope-append (rope-append l content-rope) r))
+  (set-buffer-dirty?! buf #t)
   buf)
 
 (define (buffer-replace-contents! buf content-rope)

rmacs/editor.rkt

@@ -31,6 +31,7 @@
 (require "keys.rkt")
 (require "rope.rkt")
 (require "circular-list.rkt")
+(require "file.rkt")
 
 (struct editor (buffers ;; BufferGroup
                 [tty #:mutable] ;; Tty
@@ -149,7 +150,8 @@
 (define (visit-file! editor filename)
   (set-window-buffer! (editor-active-window editor)
                       (configure-fresh-buffer! editor
-                                               (file->buffer (editor-buffers editor) filename))))
+                                               (load-buffer (editor-buffers editor)
+                                                            (local-file-buffer-source filename)))))
 
 (define (render-editor! editor)
   (render-windows! (editor-tty editor)

rmacs/file.rkt

@@ -0,0 +1,37 @@
+#lang racket/base
+
+(provide gen:buffer-source
+         buffer-source-title-pieces
+         buffer-source-mtime
+         buffer-source-read
+         buffer-source-write
+
+         (struct-out local-file-buffer-source)
+         local-file-buffer-source-path)
+
+(require racket/generic)
+(require (only-in racket/file file->string))
+(require (only-in racket/path normalize-path))
+
+(define-generics buffer-source
+  (buffer-source-title-pieces buffer-source)
+  (buffer-source-mtime buffer-source)
+  (buffer-source-read buffer-source)
+  (buffer-source-write buffer-source content))
+
+(struct local-file-buffer-source (filename)
+        #:transparent
+        #:methods gen:buffer-source
+        [(define (buffer-source-title-pieces src)
+           (reverse (map path->string (explode-path (local-file-buffer-source-path src)))))
+         (define (buffer-source-mtime src)
+           (file-or-directory-modify-seconds (local-file-buffer-source-path src)))
+         (define (buffer-source-read src)
+           (file->string (local-file-buffer-source-path src)))
+         (define (buffer-source-write src content)
+           (call-with-output-file (local-file-buffer-source-path src)
+             (lambda (p) (write-string content p))
+             #:exists 'replace))])
+
+(define (local-file-buffer-source-path src)
+  (normalize-path (simplify-path (local-file-buffer-source-filename src))))

rmacs/mode/fundamental.rkt

@@ -137,3 +137,7 @@
   #:bind-key "C-tab"
   #:bind-key "C-x o"
   (select-window ed (editor-next-window ed win)))
+
+(define-command fundamental-mode (save-buffer buf)
+  #:bind-key "C-x C-s"
+  (save-buffer! buf))

rmacs/render.rkt

@@ -121,10 +121,10 @@
   (define cursor-coordinates (render-top-spans spans 0 #f))
 
   (tty-statusline-style t is-active?)
-  (tty-display t "-- " (buffer-title buf) " ")
+  (let* ((prefix (format "-:~a- ~a " (if (buffer-dirty? buf) "**" "--") (buffer-title buf)))
-  (let ((remaining-length (- (tty-columns t) 4 (string-length (buffer-title buf)))))
+         (remaining-length (- (tty-columns t) (string-length prefix))))
-    (when (positive? remaining-length)
+    (tty-display t prefix)
-      (tty-display t (make-string remaining-length #\-))))
+    (when (positive? remaining-length) (tty-display t (make-string remaining-length #\-))))
 
   cursor-coordinates)