sloth/sloth/editor.scm

(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)
  #: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* (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 (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))

(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)
    (backward-delete-char state))
   ((eqv? key KEY_DC)
    (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))
   (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)))

(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))
  (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)))))

;; 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)
  (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 (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)

(define (next-node state)
  (define target (or (ts-node-next-sibling
                      (sloth-state-point-node state)
                      #t)
                     (false-if-exception
                      (ts-node-next-sibling
                       (ts-node-parent
                        (sloth-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))

(define (prev-node state)
  (define target (or (ts-node-prev-sibling
                      (sloth-state-point-node state)
                      #t)
                     (ts-node-parent
                      (sloth-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))

(define (down-node state)
  (define target (false-if-exception
                  (car (ts-node-childs
                        (sloth-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))

(define (up-node state)
  (define target (ts-node-parent (sloth-state-point-node state)))
  (if (and target
           (not (equal? target (ts-tree-root-node (sloth-state-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))