diff --git a/scripts/sloth.in b/scripts/sloth.in index 1e6fd5b..b44e2e7 100644 --- a/scripts/sloth.in +++ b/scripts/sloth.in @@ -45,7 +45,7 @@ "(Listof String) -> Int program entrypoint; handle commandline args and call appropriate procedures" (define options (getopt-config-auto args %configuration)) - (start-loop #:file (option-ref options '(file) #f))) + (start-loop (option-ref options '(file) #f))) ;;; Local Variables: ;;; mode: scheme diff --git a/sloth/editor.scm b/sloth/editor.scm index 54dc33b..49e0c50 100644 --- a/sloth/editor.scm +++ b/sloth/editor.scm @@ -3,66 +3,99 @@ #:use-module (ncurses curses) #:use-module (ts) #:use-module (ice-9 textual-ports) + #:use-module (srfi srfi-9 gnu) #:export (start-loop)) -(define modes '(normal-mode insert-mode)) +(define-immutable-record-type + (make-sloth-state win mode) + sloth-state? + (win sloth-state-win) + (mode sloth-state-mode set-sloth-state-mode)) -(define* (start-loop #:key (win (init-win)) - (file #f)) - (if file (find-file win file)) - (core-loop win)) +(define* (start-loop #:optional (file #f)) + (define state (make-sloth-state (init-win) 'normal-mode)) + (if file + (core-loop (find-file state file)) + (core-loop state))) -(define* (core-loop win #:optional (mode 'normal-mode)) - (define process-result +(define (core-loop state) + (define win (sloth-state-win state)) + (define mode (sloth-state-mode state)) + (define new-state (case mode - ((normal-mode) (normal-mode-process-input win (getch win))) - ((insert-mode) (insert-mode-process-input win (getch win))))) - (if (memq process-result modes) - (core-loop win process-result) - (core-loop win mode))) + ((normal-mode) (normal-mode-process-input state (getch win))) + ((insert-mode) (insert-mode-process-input state (getch win))))) + (core-loop new-state)) -(define (insert-mode-process-input win key) - (define y (getcury win)) - (define x (getcurx win)) +(define (insert-mode-process-input state key) + (define y (getcury (sloth-state-win state))) + (define x (getcurx (sloth-state-win state))) (cond ((eqv? key KEY_BACKSPACE) - (delch win #:y y #:x (- x 1))) + (backward-delete-char state)) ((eqv? key KEY_DC) - (delch win)) + (delete-char state)) ((eqv? key KEY_LEFT) - (move win y (- x 1))) + (move-cursor state y (- x 1))) ((eqv? key KEY_RIGHT) - (move win y (+ x 1))) + (move-cursor state y (+ x 1))) ((eqv? key KEY_UP) - (move win (- y 1) x)) + (move-cursor state (- y 1) x)) ((eqv? key KEY_DOWN) - (move win (+ y 1) x)) - ((eqv? key #\esc) 'normal-mode) - (else (insch win (normal key) #:y y #:x (+ x 1))))) + (move-cursor state (+ y 1) x)) + ((eqv? key #\esc) + (set-sloth-state-mode state 'normal-mode)) + (else (insert-char state key)))) -(define (normal-mode-process-input win key) +(define (normal-mode-process-input state key) + (define win (sloth-state-win state)) (define y (getcury win)) (define x (getcurx win)) (cond ((or (eqv? key KEY_LEFT) (eqv? key #\h)) - (move win y (- x 1))) + (move-cursor state y (- x 1))) ((or (eqv? key KEY_RIGHT) (eqv? key #\l)) - (move win y (+ x 1))) + (move-cursor state y (+ x 1))) ((or (eqv? key KEY_UP) (eqv? key #\k)) - (move win (- y 1) x)) + (move-cursor state (- y 1) x)) ((or (eqv? key KEY_DOWN) (eqv? key #\j)) - (move win (+ y 1) x)) - ((eqv? key #\i) 'insert-mode) + (move-cursor state (+ y 1) x)) + ((eqv? key #\i) (set-sloth-state-mode state 'insert-mode)) ((eqv? key #\q) (endwin) - (quit)))) + (quit)) + (else state))) -(define (find-file win file) +(define (find-file state file) + (define win (sloth-state-win state)) (when (file-exists? file) - (addstr win (call-with-input-file file get-string-all)) + (addstr win (call-with-inputn-file file get-string-all)) (refresh win) - (move win 0 0))) + (move win 0 0)) + state) + +;; These are stubs for now, but they'll get more complex +;; as we add features and more processing is needed on updates + +(define (backward-delete-char state) + (delch (sloth-state-win state) #:y y #:x (- x 1)) + state) + +(define (delete-char state) + (delch (sloth-state-win state)) + state) + +(define (move-cursor state y x) + (move (sloth-state-win state) y x) + state) + +(define (insert-char state char) + (define x (getcurx (sloth-state-win state))) + (define y (getcury (sloth-state-win state))) + (insch (sloth-state-win state) (normal char)) + (move (sloth-state-win state) y (+ x 1)) + state)