(define-module (sloth ncurses)
  #:use-module (ncurses curses)
  #:use-module (sloth editor)
  #:use-module (sloth common)
  #:use-module (sloth interface)
  #:use-module (oop goops)
  #:export (init-ncurses))

(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-value 0 #:accessor curx)
  (cury #:init-value 0 #:accessor cury))

(define-method (initialize (nc <ncurses-frontend>) . initargs)
  (set! (height nc) (lines))
  (set! (width nc) (cols))
  (next-method))

(define (init-ncurses)
  (define win (initscr))
  (define state (make <ncurses-frontend>
		  #:main-win win))
  (raw!)
  (noecho!)
  (keypad! win #t)
  state)

(define (input-waiting? win)
  (nodelay! win #t)
  (define result (getch win))
  (nodelay! win #f)
  result)

(define-method (fetch-input (nc <ncurses-frontend>))
  (let ((ch (getch (get-main-win nc))))
    (if (memq ch insertable-characters)
	(insertable-char->sloth-input-code ch)
	(case ch
	  ;; You might note a lack of c-s-[letter], and other input
	  ;; options. This is due to terminals being Strange. Try C-A in
	  ;; Emacs and it moves to the front of the line while marking,
	  ;; a distinct behavior from C-a. Try this in *terminal* Emacs,
	  ;; and it doesn't work. In conclusion, terminals are a kludge
	  ;; from the days of teletypewriters. If multiple inputs map to
	  ;; the same charactes in the terminal, I've just picked
	  ;; whichever is first (or seems like it *should* be prior)
	  ((#\soh) 'c-a)
	  ((#\etx) 'c-c)
	  ((#\eot) 'c-d)
	  ((#\enq) 'c-e)
	  ((#\ack) 'c-f)
	  ((#\alarm) 'c-g)
	  ((#\vtab) 'c-k)
	  ((#\page) 'c-l)
	  ((#\so) 'c-n)
	  ((#\si) 'c-o)
	  ((#\dle) 'c-p)
	  ((#\dc1) 'c-q)
	  ((#\dc2) 'c-r)
	  ((#\dc3) 'c-s)
	  ((#\dc4) 'c-t)
	  ((#\nak) 'c-u)
	  ((#\syn) 'c-v)
	  ((#\etb) 'c-w)
	  ((#\can) 'c-x)
	  ((#\em) 'c-y)
	  ((#\sub) 'c-z)
	  ((#\nul) 'c-backtick)
	  ((#\rs) 'c-~)
	  ((#\fs) 'c-four)
	  ((#\gs) 'c-five)
	  ((#\us) 'c-seven)
	  ((258) 'down)
	  ((259) 'up)
	  ((260) 'left)
	  ((261) 'right)
	  ((262) 'home)
	  ((263) 'backspace)
	  ((265) 'f1)
	  ((266) 'f2)
	  ((267) 'f3)
	  ((268) 'f4)
	  ((269) 'f5)
	  ((270) 'f6)
	  ((271) 'f7)
	  ((272) 'f8)
	  ((273) 'f9)
	  ((274) 'f10)
	  ((275) 'f11)
	  ((276) 'f12)
	  ((277) 's-f1)
	  ((278) 's-f2)
	  ((279) 's-f3)
	  ((280) 's-f4)
	  ((281) 's-f5)
	  ((282) 's-f6)
	  ((283) 's-f7)
	  ((284) 's-f8)
	  ((285) 's-f9)
	  ((286) 's-f10)
	  ((287) 's-f11)
	  ((288) 's-f12)
	  ((289) 'c-f1)
	  ((290) 'c-f2)
	  ((291) 'c-f3)
	  ((292) 'c-f4)
	  ((293) 'c-f5)
	  ((294) 'c-f6)
	  ((295) 'c-f7)
	  ((296) 'c-f8)
	  ((297) 'c-f9)
	  ((298) 'c-f10)
	  ((299) 'c-f11)
	  ((300) 'c-f12)
	  ((301) 'c-s-f1)
	  ((302) 'c-s-f2)
	  ((303) 'c-s-f3)
	  ((304) 'c-s-f4)
	  ((305) 'c-s-f5)
	  ((306) 'c-s-f6)
	  ((307) 'c-s-f7)
	  ((308) 'c-s-f8)
	  ((309) 'c-s-f9)
	  ((310) 'c-s-f10)
	  ((311) 'c-s-f11)
	  ((312) 'c-s-f12)
	  ((313) 'm-f1)
	  ((314) 'm-f2)
	  ((315) 'm-f3)
	  ((316) 'm-f4)
	  ((317) 'm-f5)
	  ((318) 'm-f6)
	  ((319) 'm-f7)
	  ((320) 'm-f8)
	  ((321) 'm-f9)
	  ((322) 'm-f10)
	  ((323) 'm-f11)
	  ((324) 'm-f12)
          ((330) 'delete)
          ((331) 'insert)
          ((336) 's-down)
          ((337) 's-up)
          ((360) 'end)
          ((383) 's-delete)
          ((386) 's-end)
          ((391) 's-home)
          ((393) 's-left)
          ((512) 'm-delete)
          ((513) 'c-delete)
          ((516) 'c-m-delete)
          ((518) 'm-down)
          ((519) 'm-s-down)
          ((520) 'c-down)
          ((521) 'c-s-down)
          ((522) 'c-m-down)
          ((523) 'm-end)
          ((525) 'c-end)
          ((527) 'c-m-end)
          ((528) 'm-home)
          ((530) 'c-home)
          ((532) 'c-m-home)
          ((533) 'm-insert)
          ((535) 'c-insert)
          ((537) 'c-m-insert)
          ((538) 'm-left)
          ((539) 'm-s-left)
          ((540) 'c-left)
          ((541) 'c-s-left)
          ((542) 'c-m-left)
          ((553) 'm-right)
          ((554) 'm-s-right)
          ((555) 'c-right)
          ((556) 'c-s-right)
          ((557) 'c-m-right)
          ((559) 'm-up)
          ((560) 'm-s-up)
          ((561) 'c-up)
          ((562) 'c-s-up)
          ((563) 'c-m-up)
	  ;; TODO: M-characters. Most of the time this is ESC
	  ;; immediately followed by the character, so M-6 is ESC 6.
	  ;; So when we see ESC we need to check if there's another
	  ;; character waiting, and if there is then it's M-[char],
	  ;; and otherwise it's just ESC.
	  ((#\esc)
           (let ((more? (input-waiting? (get-main-win nc))))
             (if (not more?)
                 'escape
                 (case more?
                   ((#f) 'escape)
                   ((#\a) 'm-a)
                   ((#\b) 'm-b)
                   ((#\c) 'm-c)
                   ((#\d) 'm-d)
                   ((#\e) 'm-e)
                   ((#\f) 'm-f)
                   ((#\g) 'm-g)
                   ((#\h) 'm-h)
                   ((#\i) 'm-i)
                   ((#\j) 'm-j)
                   ((#\k) 'm-k)
                   ((#\l) 'm-l)
                   ((#\m) 'm-m)
                   ((#\n) 'm-n)
                   ((#\o) 'm-o)
                   ((#\p) 'm-p)
                   ((#\q) 'm-q)
                   ((#\r) 'm-r)
                   ((#\s) 'm-s)
                   ((#\t) 'm-t)
                   ((#\u) 'm-u)
                   ((#\v) 'm-v)
                   ((#\w) 'm-w)
                   ((#\x) 'm-x)
                   ((#\y) 'm-y)
                   ((#\z) 'm-z)
                   ((#\A) 'm-s-a)
                   ((#\B) 'm-s-b)
                   ((#\C) 'm-s-c)
                   ((#\D) 'm-s-d)
                   ((#\E) 'm-s-e)
                   ((#\F) 'm-s-f)
                   ((#\G) 'm-s-g)
                   ((#\H) 'm-s-h)
                   ((#\I) 'm-s-i)
                   ((#\J) 'm-s-j)
                   ((#\K) 'm-s-k)
                   ((#\L) 'm-s-l)
                   ((#\M) 'm-s-m)
                   ((#\N) 'm-s-n)
                   ((#\O) 'm-s-o)
                   ((#\P) 'm-s-p)
                   ((#\Q) 'm-s-q)
                   ((#\R) 'm-s-r)
                   ((#\S) 'm-s-s)
                   ((#\T) 'm-s-t)
                   ((#\U) 'm-s-u)
                   ((#\V) 'm-s-v)
                   ((#\W) 'm-s-w)
                   ((#\X) 'm-s-x)
                   ((#\Y) 'm-s-y)
                   ((#\Z) 'm-s-z)
                   ((#\0) 'm-zero)
                   ((#\1) 'm-one)
                   ((#\2) 'm-two)
                   ((#\3) 'm-three)
                   ((#\4) 'm-four)
                   ((#\5) 'm-five)
                   ((#\6) 'm-six)
                   ((#\7) 'm-seven)
                   ((#\8) 'm-eight)
                   ((#\9) 'm-nine)
                   ((#\`) 'm-backtick)
                   ((#\~) 'm-~)
                   ((#\!) 'm-!)
                   ((#\@) 'm-@)
                   ((#\$) 'm-$)
                   ((#\%) 'm-%)
                   ((#\^) 'm-^)
                   ((#\&) 'm-&)
                   ((#\*) 'm-*)
                   ((#\() 'm-lparen)
                   ((#\)) 'm-rparen)
                   ((#\-) 'm-dash)
                   ((#\_) 'm-_)
                   ((#\=) 'm-=)
                   ((#\+) 'm-+)
                   ((#\[) 'm-lbracket)
                   ((#\]) 'm-rbracket)
                   ((#\{) 'm-lbrace)
                   ((#\}) 'm-rbrace)
                   ((#\\) 'm-backslash)
                   ((#\|) 'm-pipe)
                   ((#\;) 'm-semicolon)
                   ((#\:) 'm-:)
                   ((#\') 'm-apostrophe)
                   ((#\") 'm-quote)
                   ((#\,) 'm-comma)
                   ((#\<) 'm-<)
                   ((#\.) 'm-dot)
                   ((#\>) 'm->)
                   ((#\/) 'm-/)
                   ((#\?) 'm-?)))))))))

(define-method (set-cursor-pos (nc <ncurses-frontend>) x y scroll line)
  (define y-real (max 0 (- y scroll)))
  (define tabcount (string-count line #\tab))
  (define x-real (+ (- x tabcount)
                    (* (tabsize) tabcount)))
  (set! (curx nc) x-real)
  (set! (cury nc) y-real)
  (move (get-main-win nc) y-real x-real))

(define-method (end (nc <ncurses-frontend>))
  (erase (get-main-win nc))
  (refresh (get-main-win nc))
  (endwin))

(define-method (write-buffer (nc <ncurses-frontend>) buffer scroll)
  (define win (get-main-win nc))
  (erase win)
  (do ((i 0 (1+ i)))
      ((or (> i (lines))
           (>= (+ i scroll) (length buffer))))
    (addstr win (list-ref buffer (+ i scroll))
            #:y i #:x 0))
  (move win (cury nc) (curx nc))
  (refresh win))