sloth/sloth/editor.scm

(define-module (sloth editor)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 textual-ports)
  #:use-module (oop goops)
  #:use-module (sloth common)
  #:use-module (sloth interface)
  #: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)
  (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))))

;;; merges k and k+1
(define (merge-lines buffer k)
  (append (list-head buffer k)
          (list
           (string-append (list-ref buffer k)
                          (list-ref buffer (1+ k))))
          (list-tail buffer (+ k 2))))

(define (backward-delete-char state)
  (define buf (buffer state))
  (define x (curx state))
  (define y (cury state))
  (if (> x 0)
      (list-set! buf y
                 (string-delete-kth (list-ref buf y) (1- x)))
      (set! (buffer state) (merge-lines buf (1- y))))
  (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 (clamp n lowest highest)
  (if (< n lowest)
      lowest
      (if (> n highest)
          highest
          n)))

(define* (move-cursor state #:key x y relative?)
  (define newx (if x
                   (if relative?
                       (+ x (curx state))
                       x)
                   (curx state)))
  (define newy (if y
                   (if relative?
                       (+ y (cury state))
                       y)
                   (cury state)))
  (set! (cury state) (clamp newy 0 (1- (length (buffer state)))))
  (set! (curx state) (clamp newx 0 (string-length
                                    (list-ref (buffer state) (cury state)))))
  (define scroll (lines-scrolled state))
  (define screen-height (height (get-frontend state)))
  (define relative-y (- (cury state) scroll))
  (if (>= relative-y
          screen-height)
      (set! (lines-scrolled state) (cury state)))
  (if (< relative-y 0)
      (set! (lines-scrolled state)
            (max 0 (- (cury state) screen-height))))
  (set-cursor-pos (get-frontend state)
                  (curx state)
                  (cury state)
                  (lines-scrolled state)
                  (list-ref (buffer 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
                      (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 (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)))))