192 lines
6.1 KiB
Scheme
192 lines
6.1 KiB
Scheme
(define-module (sloth editor)
|
|
#:use-module (ice-9 textual-ports)
|
|
#:use-module (oop goops)
|
|
#:use-module (sloth interface)
|
|
#:use-module (sloth common)
|
|
#:use-module (ts)
|
|
#:export (start-loop))
|
|
|
|
(define-class <sloth-state> ()
|
|
(frontend #:init-keyword #:frontend #:getter get-frontend)
|
|
(mode #:init-value 'normal-mode #:accessor mode)
|
|
(buffer #:init-value (list "") #: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 frontend #:optional (file #f))
|
|
(define state (make <sloth-state>
|
|
#:frontend frontend))
|
|
(find-file state file)
|
|
(write-buffer (get-frontend state)
|
|
(buffer state)
|
|
(lines-scrolled state))
|
|
(core-loop state))
|
|
|
|
(define (core-loop 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)))))
|
|
(write-buffer (get-frontend state)
|
|
(buffer state)
|
|
(lines-scrolled state))
|
|
(core-loop state))
|
|
|
|
(define (insert-mode-process-input state key)
|
|
(if (memq key insertable-characters)
|
|
(insert-char state key)
|
|
(case key
|
|
((backspace)
|
|
(backward-delete-char state))
|
|
((delete)
|
|
(delete-char state))
|
|
((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)))))
|
|
|
|
(define (normal-mode-process-input state key)
|
|
(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)
|
|
(when (and file (file-exists? file))
|
|
(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 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))))
|
|
|
|
(define (string-delete-kth s k)
|
|
(string-append
|
|
(string-take s k)
|
|
(string-drop s (1+ k))))
|
|
|
|
(define (backward-delete-char state)
|
|
(define buf (buffer state))
|
|
(define x (curx state))
|
|
(define y (cury state))
|
|
(list-set! buf y
|
|
(string-delete-kth (list-ref buf y) (1- x)))
|
|
(move-cursor state #:x -1 #:relative? #t))
|
|
|
|
(define (delete-char 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 #:key (x #f) (y #f) (relative? #f))
|
|
(if x (set! (curx state)
|
|
(if relative?
|
|
(+ x (curx state))
|
|
x)))
|
|
(if y (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 buf (buffer state))
|
|
(define x (curx state))
|
|
(define y (cury state))
|
|
(list-set! buf y
|
|
(string-insert (list-ref buf y)
|
|
(sloth-input-code->insertable-char char)
|
|
x))
|
|
(move-cursor state #:x 1 #:relative? #t))
|
|
|
|
(define (next-node state)
|
|
(define target (or (ts-node-next-sibling
|
|
(point-node state)
|
|
#t)
|
|
(false-if-exception
|
|
(ts-node-next-sibling
|
|
(ts-node-parent
|
|
(point-node state))
|
|
#t))))
|
|
(if target
|
|
(let ((point (ts-node-start-point target)))
|
|
(set! (point-node state) target)
|
|
(move-cursor state
|
|
#:y (car point) #:x (cdr point)))))
|
|
|
|
(define (prev-node state)
|
|
(define target (or (ts-node-prev-sibling
|
|
(point-node state)
|
|
#t)
|
|
(ts-node-parent
|
|
(point-node state))))
|
|
(if target
|
|
(let ((point (ts-node-start-point target)))
|
|
(set! (point-node state) target)
|
|
(move-cursor state
|
|
#:y (car point) #:x (cdr point)))))
|
|
|
|
(define (down-node state)
|
|
(define target (false-if-exception
|
|
(car (ts-node-childs
|
|
(point-node state)
|
|
#t))))
|
|
(if target
|
|
(let ((point (ts-node-start-point target)))
|
|
(set! (point-node state) target)
|
|
(move-cursor state
|
|
#:y (car point) #:x (cdr point)))))
|
|
|
|
(define (up-node state)
|
|
(define target (ts-node-parent (point-node state)))
|
|
(if (and target
|
|
(not (equal? target (ts-tree-root-node (tree state)))))
|
|
(let ((point (ts-node-start-point target)))
|
|
(set! (point-node state) target)
|
|
(move-cursor state
|
|
#:y (car point) #:x (cdr point)))))
|