Sloth
/
sloth
2
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Continue building toolkit and replacing existing code with generics

This commit is contained in:
Skylar Hill 2023-11-06 17:14:15 -06:00
parent 1b611d0f96
commit c0121850b3
5 changed files with 158 additions and 128 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
scripts/sloth.in
View File

@ -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 (option-ref options '(file) #f)))
(start-loop (init-frontend 'ncurses) (option-ref options '(file) #f)))
;;; Local Variables:
;;; mode: scheme

12
sloth/common.scm
View File

@ -1,6 +1,16 @@
(define-module (sloth common)
#:use-module (oop goops)
#:export (<sloth-frontend>))
#:export (<sloth-frontend>
fetch-input
get-main-win
set-cursor-pos
end
write-buffer))
(define-class <sloth-frontend> ()
(main-win #:getter get-main-win #:init-keyword #:main-win))
(define-generic fetch-input) ; args: <sloth-frontend>
(define-generic set-cursor-pos) ; args: <sloth-frontend> x y
(define-generic end) ; args: <sloth-frontend>
(define-generic write-buffer) ; args: <sloth-frontend> buffer lines-scrolled

245
sloth/editor.scm
View File

@ -1,174 +1,187 @@
(define-module (sloth editor)
#:use-module (sloth interface)
#:use-module (ncurses curses)
#:use-module (ts)
#:use-module (ice-9 textual-ports)
#:use-module (srfi srfi-9 gnu)
#:use-module (oop goops)
#:use-module (sloth interface)
#:use-module (sloth common)
#:use-module (ts)
#:export (start-loop))
(define-immutable-record-type <sloth-state>
(make-sloth-state win mode tree point-node)
sloth-state?
(win sloth-state-win)
(mode sloth-state-mode set-sloth-state-mode)
(tree sloth-state-tree set-sloth-state-tree)
(point-node sloth-state-point-node set-sloth-state-point-node))
(define-class <sloth-state> ()
(frontend #:init-keyword #:frontend #:getter get-frontend)
(mode #:init-value 'normal-mode #:accessor mode)
(buffer #:init-value '("") #:accessor buffer)
(tree #:accessor tree)
(point-node #:accessor point-node)
(curx #:init-value 0 #:accessor curx)
(cury #:init-value 0 #:accessor cury)
(lines-scrolled #:init-value 0 #:accessor lines-scrolled))
(define* (start-loop #:optional (file #f))
(define state (make-sloth-state (init-win) 'normal-mode #f #f))
(if file
(core-loop (find-file state file))
(core-loop state)))
(define* (start-loop frontend #:optional (file #f))
(define state (make <sloth-state>
#:frontend frontend))
(find-file state file)
(core-loop state))
(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 state (getch win)))
((insert-mode) (insert-mode-process-input state (getch win)))))
(core-loop new-state))
(case (mode state)
((normal-mode)
(normal-mode-process-input state
(fetch-input (get-frontend state))))
((insert-mode)
(insert-mode-process-input state
(fetch-input (get-frontend state)))))
(core-loop state))
(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)
(case key
((backspace)
(backward-delete-char state))
((eqv? key KEY_DC)
((delete)
(delete-char state))
((eqv? key KEY_LEFT)
(move-cursor state y (- x 1)))
((eqv? key KEY_RIGHT)
(move-cursor state y (+ x 1)))
((eqv? key KEY_UP)
(move-cursor state (- y 1) x))
((eqv? key KEY_DOWN)
(move-cursor state (+ y 1) x))
((eqv? key #\esc)
(set-sloth-state-mode state 'normal-mode))
((left)
(move-cursor state #:x -1 #:relative? #t))
((right)
(move-cursor state #:x 1 #:relative? #t))
((up)
(move-cursor state #:y -1 #:relative? #t))
((down)
(move-cursor state #:y 1 #:relative? #t))
((escape)
(set! (mode state) 'normal-mode))
(else (insert-char state 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-cursor state y (- x 1)))
((or (eqv? key KEY_RIGHT)
(eqv? key #\l))
(move-cursor state y (+ x 1)))
((or (eqv? key KEY_UP)
(eqv? key #\k))
(move-cursor state (- y 1) x))
((or (eqv? key KEY_DOWN)
(eqv? key #\j))
(move-cursor state (+ y 1) x))
((eqv? key #\n) (next-node state))
((eqv? key #\d) (down-node state))
((eqv? key #\p) (prev-node state))
((eqv? key #\u) (up-node state))
((eqv? key #\i) (set-sloth-state-mode state 'insert-mode))
((eqv? key #\q)
(endwin)
(quit))
(else state)))
(case key
((left h) (move-cursor state #:x -1 #:relative? #t))
((right l) (move-cursor state #:x 1 #:relative? #t))
((up k) (move-cursor state #:y -1 #:relative? #t))
((down j) (move-cursor state #:y 1 #:relative? #t))
((n) (next-node state))
((d) (down-node state))
((p) (prev-node state))
((u) (up-node state))
((i) (set! (mode state) 'insert-mode))
((q)
(end (get-frontend state))
(quit))))
(define* (get-lines p #:optional (acc '()))
(let ((l (get-line p)))
(if (eof-object? l)
(reverse acc)
(get-lines p (cons l acc)))))
(define (find-file state file)
(define win (sloth-state-win state))
(define contents "")
(when (file-exists? file)
(set! contents
(call-with-input-file file get-string-all))
(addstr win contents)
(refresh win)
(move win 0 0))
(set! (buffer state)
(call-with-input-file file get-lines)))
(define scheme-lang (get-ts-language-from-file "libtree-sitter-scheme"
"tree_sitter_scheme"))
(define scheme-parser (ts-parser-new #:language scheme-lang))
(define tree (ts-parser-parse-string scheme-parser
#f
contents))
(set-fields
state
((sloth-state-tree) tree)
((sloth-state-point-node) (or (ts-node-child (ts-tree-root-node tree)
0)
(ts-tree-root-node tree)))))
(define parse-tree (ts-parser-parse-string scheme-parser
#f
(string-join (buffer state) "\n")))
(set! (tree state) parse-tree)
(set! (point-node state)
(or (ts-node-child (ts-tree-root-node parse-tree)
0)
(ts-tree-root-node parse-tree))))
;; These are stubs for now, but they'll get more complex
;; as we add features and more processing is needed on updates
(define (string-delete-kth s k)
(string-append
(string-take s k)
(string-drop s (+ k 1))))
(define (backward-delete-char state)
(define x (getcurx (sloth-state-win state)))
(define y (getcury (sloth-state-win state)))
(delch (sloth-state-win state) #:y y #:x (- x 1))
state)
(define buf (buffer state))
(define x (curx state))
(define y (cury state))
(list-set! buf y
(string-delete-kth (list-ref buf y) (- x 1))))
(define (delete-char state)
(delch (sloth-state-win state))
state)
(define buf (buffer state))
(define x (curx state))
(define y (cury state))
(list-set! buf y
(string-delete-kth (list-ref buf y) x)))
(define (move-cursor state y x)
(move (sloth-state-win state) y x)
state)
(define* (move-cursor state
#:key
(x (curx state))
(y (cury state))
(relative? #f))
(set! (curx state)
(if relative?
(+ x (curx state))
x))
(set! (cury state)
(if relative?
(+ y (cury state))
y))
(set-cursor-pos (get-frontend state)
(curx state)
(cury state)))
(define (string-insert s ch k)
(string-append
(string-take s k)
(string ch)
(string-drop s k)))
(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)
(define buf (buffer state))
(define x (curx state))
(define y (cury state))
(list-set! buf y
(string-insert (list-ref buf y) char x)))
(define (next-node state)
(define target (or (ts-node-next-sibling
(sloth-state-point-node state)
(point-node state)
#t)
(false-if-exception
(ts-node-next-sibling
(ts-node-parent
(sloth-state-point-node state))
(point-node state))
#t))))
(if target
(let ((point (ts-node-start-point target)))
(move (sloth-state-win state)
(car point) (cdr point))
(set-sloth-state-point-node state target))
state))
(move-cursor (get-frontend state)
#:y (car point) #:x (cdr point))
(set! (point-node state) target))))
(define (prev-node state)
(define target (or (ts-node-prev-sibling
(sloth-state-point-node state)
(point-node state)
#t)
(ts-node-parent
(sloth-state-point-node state))))
(point-node state))))
(if target
(let ((point (ts-node-start-point target)))
(move (sloth-state-win state)
(car point) (cdr point))
(set-sloth-state-point-node state target))
state))
(move-cursor (get-frontend state)
#:y (car point) #:x (cdr point))
(set! (point-node state) target))))
(define (down-node state)
(define target (false-if-exception
(car (ts-node-childs
(sloth-state-point-node state)
(point-node state)
#t))))
(if target
(let ((point (ts-node-start-point target)))
(move (sloth-state-win state)
(car point) (cdr point))
(set-sloth-state-point-node state target))
state))
(move-cursor (get-frontend state)
#:y (car point) #:x (cdr point))
(set! (point-node state) target))))
(define (up-node state)
(define target (ts-node-parent (sloth-state-point-node state)))
(define target (ts-node-parent (point-node state)))
(if (and target
(not (equal? target (ts-tree-root-node (sloth-state-tree state)))))
(not (equal? target (ts-tree-root-node (tree state)))))
(let ((point (ts-node-start-point target)))
(move (sloth-state-win state)
(car point) (cdr point))
(set-sloth-state-point-node state target))
state))
(move-cursor (get-frontend state)
#:y (car point) #:x (cdr point))
(set! (point-node state) target))))

16
sloth/interface.scm
View File

@ -1,15 +1,15 @@
(define-module (sloth interface)
#:use-module (sloth common)
#:use-module (sloth ncurses)
#:use-module (ice-9 exceptions)
#:use-module (oop goops)
#:use-module (rnrs enums)
#:use-module (ice-9 exceptions)
#:export (init-frontend
sloth-input-code->insertable-char
#:use-module (sloth common)
#:use-module (sloth ncurses)
#:export (get-main-win
insertable-char->sloth-input-code
insertable-characters
sloth-input-code->insertable-char
sloth-input-keys
get-main-win))
init-frontend))
(define sloth-input-keys
(make-enumeration
@ -34,7 +34,7 @@
c-seven c-eight c-nine c-zero
c-~ c-backtick c-! @ c-hash c-$ c-%
c-^ c-& c-* c-lparen c-rparen c-dash
c-_ c-lbrace c-rbrace c-lbracket c-rbracket
v c-_ c-lbrace c-rbrace c-lbracket c-rbracket
c-pipe c-backslash c-/ c-? c-< c->
c-comma c-dot c-: c-semicolon c-+ c-=
c-apostrophe c-quote
@ -354,5 +354,3 @@
(make-exception
(make-exception-with-message "Unknown frontend")
(make-exception-with-irritants frontend))))))
(define-generic fetch-input)

11
sloth/ncurses.scm
View File

@ -5,7 +5,12 @@
#:use-module (oop goops)
#:export (init-ncurses))
(define-class <ncurses-frontend> (<sloth-frontend>))
(define-class <ncurses-frontend> (<sloth-frontend>)
;; Since writing text in ncurses typically requires setting and moving the
;; cursor, our frontend class needs to know where the cursor is supposed to
;; be so it can ensure it always gets reset to that point.
(curx #:init-keyword #:curx #:accessor curx)
(cury #:init-keyword #:cury #:accessor cury))
(define (init-ncurses)
(define win (initscr))
@ -129,3 +134,7 @@
;; and otherwise it's just ESC.
))))
(define-method (set-cursor-pos (frontend <ncurses-frontend>) x y)
(set! (curx frontend) x)
(set! (cury frontend) y)
(move (get-main-win) y x))