(define-module (terminal)
  :use-module (oop goops)
  :use-module (pretext)
  :use-module (characters)
  :export (<terminal> full-reset
           tty-raw-mode tty-sane-mode
           SRM-echo-off SRM-echo-on
           cursor-home
           cursor-up cursor-down
           cursor-forward cursor-backward
           erase-line erase-display
           get-dimensions
           start-event-loop print))

;;
;; Terminal Class Interface Implementation
;;

(define-class <terminal> ()
  (port #:init-value #f
        #:getter get-port
        #:init-keyword #:port))

(define-method (control (terminal <terminal>) control-characters)
  (display (list->string control-characters) (get-port terminal)))

(define-method (full-reset (terminal <terminal>))
  (control terminal '(#\esc #\c)))

;;
;; Control Sequence Introduction
(define CSI '(#\esc #\[))

;;
;; SRM: Send Receive Mode
;; turn terminal echo on or off
(define-method (SRM-echo-off (terminal <terminal>))
  (control terminal (append CSI '(#\1 #\2 #\h))))
(define-method (SRM-echo-on (terminal <terminal>))
  (control terminal (append CSI '(#\1 #\2 #\l))))

;;
;; CSI: Cursor Control
(define-method (cursor-home (terminal <terminal>))
  (control terminal (append CSI '(#\0 #\; #\0 #\f))))
(define-method (cursor-up (terminal <terminal>))
  (control terminal (append CSI '(#\A))))
(define-method (cursor-down (terminal <terminal>))
  (control terminal (append CSI '(#\B))))
(define-method (cursor-forward (terminal <terminal>))
  (control terminal (append CSI '(#\C))))
(define-method (cursor-backward (terminal <terminal>))
  (control terminal (append CSI '(#\D))))

;;
;; CSI: Erase
(define-method (erase-line (terminal <terminal>))
  (control terminal (append CSI '(#\2 #\K))))
(define-method (erase-display (terminal <terminal>))
  (control terminal (append CSI '(#\2 #\J))))

;;
;; CSI: Window Control (dtterm&extensions, XTerm)
(define (CSI-window-control string)
  (append CSI (string->list string)))
(define-method (get-dimensions (terminal <terminal>)) ;XXX XXX XXX
  (let ((response-introduction (append CSI '(#\9)))
        (port (get-port terminal))
        (x '()) (y '()))
   (control terminal (append CSI (string->list "18t")))
   (my-debug " READ CHAR AHEAD")
   (let response-reader ((char (read-char port)))
     (my-debug " RED CHAR ")
     (if (null? response-introduction)
       (begin
         (let y-value ((char (read-char port)))
           (if (not (eq? char #\;))
             (begin
               (set! y (append y (list char)))
               (y-value (read-char port)))))
         (let x-value ((char (read-char port)))
           (if (not (eq? char #\t))
             (begin
               (set! x (append x (list char)))
               (x-value (read-char port)))) ))
       (begin
         (set! response-introduction (cdr response-introduction))
         (response-reader (read-char) ))) )
   (values (string->number (list->string x))
           (string->number (list->string y))) ))

(define (private/tty-raw-mode tty)
  (system (string-append "stty --file=" (ttyname tty) " "
                         "raw" " "
                         "-echo")))
(define (private/tty-sane-mode tty)
  (system (string-append "stty --file=" (ttyname tty) " "
                         "sane")))
(define-method (tty-raw-mode (terminal <terminal>))
  (private/tty-raw-mode (get-port terminal)))
(define-method (tty-sane-mode (terminal <terminal>))
  (private/tty-sane-mode (get-port terminal)))

(define (print . args) ;; this is not even virtual print vt220 terms
  (for-each display args))
(define (print-safely char)
  (if (printable? char)
      (print char)
      (print "#" (char->integer char))))

(define (convert-csi-input port)
  (let ((char (read-char port)))
    (case char
      ((#\A) 'up)
      ((#\B) 'down)
      ((#\C) 'right)
      ((#\D) 'left)
      ((#\H) 'home)
      ((#\F) 'end)
      ((#\3) 'delete)
      ;((#\5) 'page-up) ; XXX there appears a "~" behind these
      ;((#\6) 'page-down)
      (else ; unknown CSI input follow-up XXX just beep
       (print " CSI ")
       (print-safely char)) )))
(define (convert-escape-sequence port)
  (let ((char (read-char port)))
    (if (eq? #\[ char)
        (convert-csi-input port)
        (begin ; unknown escape sequence input XXX just beep
          (display " ESC-SEQ ")
          (print-safely char)) )))
(define (dispatch-on-escape port)
  (if (not (char-ready? port))
      #\esc ; user typed escape goes to event handler
      (convert-escape-sequence port) ))


(define-method (start-event-loop (terminal <terminal>) event-handler)
 (let ((port (get-port terminal)))
  (let event-loop ((char (read-char port)))
    (if (is-unicode-c0? (char->byte char))
        (event-handler (case char
                         ((#\esc) (dispatch-on-escape port))
                         (else char)))
        ;else beep perhaps
        )
    (event-loop (read-char port)) )))

;;
;; Protocol Key Event
;;
;; A key event is either a character or a symbol corresponding to the
;; respective keys.
;; '(up down forward backward home end delete ;page-up page-down)