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