path: root/module/output/terminal.scm

(define-module (output terminal)
  #:use-module (output general)
  #:use-module (srfi srfi-1)
  #:use-module (datetime)
  #:use-module (srfi srfi-17)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-41)
  #:use-module (srfi srfi-41 util)
  #:use-module (util)
  #:use-module ((util app) :prefix app/)
  #:use-module (vulgar)
  #:use-module (vulgar info)
  #:use-module (vulgar color)
  #:use-module (vulgar components)
  #:use-module (vcomponent group)

  #:use-module (vcomponent)
  #:use-module (vcomponent datetime)

  #:use-module (text util)
  #:use-module (text flow)

  #:use-module (ice-9 format)
  #:use-module (ice-9 readline)
  #:use-module (ice-9 sandbox)
  #:use-module (ice-9 match)

  #:use-module (vulgar termios)

  #:use-module (oop goops)
  #:use-module (oop goops describe)

  #:export (main-loop))

(define-values (height width) (get-terminal-size))

(define (open-in-editor fname)
  (system (string-append (getenv "EDITOR") " " fname)))


(define (box-top intersection line . lengths)
  (reduce (lambda (str done) (string-append done (string intersection) str))
          "" (map (cut make-string <> line) lengths)))

(define* (display-event-table events #:key
                              (active-element -1)
                              ;; (summary-width 30)
                              (date-width 17)
                              (location-width 20))
  (define summary-width (- width date-width location-width 6))

  (displayln
   (box-top #\┬ #\─ date-width (+ summary-width 2) (1+ location-width)))
  (for-each
   (lambda (ev i)
     (display
      (string-append
       (if (datetime? (prop ev 'DTSTART))
           (datetime->string (prop ev 'DTSTART) "~Y-~m-~d ~H:~M")
           (date->string (prop ev 'DTSTART) "~Y-~m-~d --:--"))
       " │ "
       (if (= i active-element) "\x1b[7m" "")
       (color-escape (prop (parent ev) 'COLOR))
       ;; Summary filter is a hook for the user
       (let ((dirty (prop ev '-X-HNH-DIRTY)))
         (string-append
          (if dirty "* " "")
          ;; TODO reintroduce summary-filter
          (trim-to-width (prop ev 'SUMMARY) (- summary-width
                                               (if dirty 2 0)))))
       STR-RESET
       " │ "
       (if (prop ev 'LOCATION) "" "\x1b[1;30m")
       (trim-to-width
        (or (prop ev 'LOCATION) "INGEN LOKAL") location-width)
       STR-RESET
       "\n")))
   events
   (iota (length events)))
  (displayln
   (box-top #\┴ #\─ date-width (+ summary-width 2) (1+ location-width))))

(define (displayln a)
  (display a) (newline))


(define-class <view> ()
  (event-set getter: get-event-set init-keyword: event-set:)
  (active-element accessor: active-element
                  init-value: 0)
  (current-page accessor: current-page
                init-keyword: current-page:)
  (page-length accessor: page-length
               init-value: 0)

  )


(define-class <day-view> (<view>)
  #;
  (date accessor: view-date
        init-keyword: date:)

  (cached-events accessor: cached-events
                 init-value: #f)
  (groups accessor: groups))


(define-method (initialize (this <day-view>) args)
  (next-method)
  (set! (groups this) (group-stream (get-event-set this))))

(define-method (output (this <day-view>))

  (define events
    (aif (cached-events this)
         it
         (set/r! (cached-events this)
                 (group->event-list (stream-car (get-groups-between
                                                 (groups this)
                                                 (current-page this)
                                                 (current-page this)))))))

  (cls)

  (display "== Day View ==\n")

  (display-calendar-header! (current-page this))

  ;; display event list
  (display-event-table
   events
   active-element: (active-element this)
   location-width: 15)

  ;; display highlighted event
  (unless (null? events)
    (let ((ev (list-ref events (active-element this))))
      (format #t "~a~%~%  ~a~%~%~a\x1b[1mStart:\x1b[m ~a	\x1b[1mSlut:\x1b[m ~a~%~%~a~%"
              (prop ev '-X-HNH-FILENAME)
              (prop ev 'SUMMARY)
              (or (and=> (prop ev 'LOCATION)
                         (cut string-append "\x1b[1mPlats:\x1b[m " <> "\n")) "")
              ;; NOTE RFC 5545 says that DTSTART and DTEND MUST
              ;; have the same type. However we believe that is
              ;; another story.
              (let ((start (prop ev 'DTSTART)))
                (if (datetime? start)
                    (datetime->string (prop ev 'DTSTART) "~Y-~m-~d ~H:~M:~S")
                    (date->string start)))
              (let ((end (prop ev 'DTEND)))
                (if (datetime? end)
                    (datetime->string (prop ev 'DTEND) "~Y-~m-~d ~H:~M:~S")
                    (date->string end)))
              (unlines (take-to (flow-text (or (prop ev 'DESCRIPTION) "")
                                           #:width (min 70 width))
                                (- height 8 5 (length events) 5)))))))

(define-method (input (this <day-view>) char)
  (set! (page-length this) (length (cached-events this)))

  (case char
    ((#\L #\l)
     (set! (current-page this) = add-day
           (cached-events this) #f
           (active-element this) 0))

    ((#\h #\H)
     (set! (current-page this) = remove-day
           (cached-events this) #f
           (active-element this) 0))

    ((#\t)
     ;; TODO this should be local time
     ;; currently it's UTC (maybe?)
     (set! (current-page this) (current-date)
           (active-element this) 0))

    ((#\() (set-cursor-pos 0 (1- height))
     (let* ((attr (make-termios))
            (search-term #f))
       (tcgetattr! attr)
       (set! (lflag attr) (logior ECHO (lflag attr)))
       (tcsetattr! attr)
       (system "tput cnorm")
       (set! search-term (readline "search: "))
       (system "tput civis")
       (set! (lflag attr) (logand (lognot ECHO) (lflag attr)))
       (tcsetattr! attr)
       `(push ,(search-view search-term (get-event-set this)))
       ))
    (else (next-method))))

(define (day-view event-set date)
  (make <day-view> event-set: event-set current-page: date))

(define-class <search-view> (<view>)
  (search-result getter: search-result)
  (search-term accessor: search-term
               init-keyword: search-term:)
  (max-page accessor: max-page
            init-form: (cons #f 0))
  (cached-page accessor: cached-page
               init-value: #f )
  )

(define (search-view search-term event-set)
  (make <search-view> search-term: search-term event-set: event-set))

(define (prepare-string str)
  (define missing-parenthesis-count
    (string-fold (lambda (char count)
                   (case char
                     ((#\() (1+ count))
                     ((#\)) (1- count))
                     (else count)))
                 0 str))

  (string-append str (make-string missing-parenthesis-count #\))))

(define-method (initialize (this <search-view>) args)
  (set! (current-page this) 0)
  (next-method)
  ;; (display (search-term this)) (newline)
  (slot-set! this 'search-result
             (stream-paginate
              (stream-filter
               (eval `(lambda (event) ,(set/r! (search-term this)
                                          (call-with-input-string
                                              (prepare-string (search-term this))
                                            read)))
                     (make-sandbox-module
                      `(
                        ((vcomponent base) prop)
                        ((ice-9 regex) string-match)
                        #;
                        ((datetime) ,@(module-map (lambda (a . _) a) ; ;
                        (resolve-module '(datetime))))
                        ,@all-pure-bindings)
                      ))
               (get-event-set this))))
  ;; (define current-page 0)
  ;; (define current-entry 0)
  )

(define-method (output (this <search-view>))
  (unless (cached-page this)
    (set! (cached-page this)
      (catch #t
        (lambda ()
          (call-with-time-limit
           1
           (lambda () (stream->list (stream-ref (search-result this) (current-page this))))
           (lambda _ (throw 'timed-out))))
        (lambda (err . args)
          (display (cons err args) (current-error-port))
          (newline  (current-error-port))
          (case err
            ((timed-out) (set! (max-page this) (cons #t (1- (current-page this)))
                               (current-page this) (cdr (max-page this)))))
          'timed-out                     ; when search took to long
          'unbound-variable              ; when search term has unbound variables
          'wrong-type-arg                ;; stream-ref
          '()

          )
        )))

  (cls)

  (display "== Search View ==\n")

  ;; display search term
  (format #t "~y" (search-term this))

  ;; display event list
  (display-event-table
   (cached-page this)
   #:active-element (active-element this)
   #:location-width 15)

  ;; display page counter
  (let ((start (max 0 (- (current-page this) 5)))
        (end (min (+ (current-page this) 5) (cdr (max-page this)))))

    (display
     (if (= start 0)
         "|" "<"))

    (for-each (lambda (i)
                (if (= i (current-page this))
                    (format #t "[~2@a]" i)
                    (format #t " ~2@a " i)))
              (iota (1+ (- end start)) start))


    (display
     (if (= end (cdr (max-page this)))
         (if (car (max-page this))
             "|" "?")
         ">"))
    (newline)))

(define-method (input (this <view>) char)
  (case char
    ((#\j #\J) (unless (= (active-element this) (1- (page-length this)))
                 (set! (active-element this) = (+ 1))))
    ((#\k #\K) (unless (= (active-element this) 0)
                 (set! (active-element this) = (- 1))))

    ((#\g) (set! (active-element this) 0))
    ((#\G) (set! (active-element this) (1- (page-length this))))

    ((#\q) '(pop)))

  )

(define-method (input (this <search-view>) char)
  (set! (page-length this) 10)

  (case char
    ((#\newline) `(push ,(day-view (get-event-set this)
                                  (as-date (prop (list-ref (cached-page this)
                                                           (active-element this))
                                                 'DTSTART)))))
    ((#\h) (set! (current-page this) = ((lambda (old) (max 0 (1- old))))
                 (cached-page this) #f))
    ((#\l) (set! (current-page this) = ((lambda (old)
                                          ;; true final page
                                          (if (car (max-page this))
                                              (min (1+ old) (cdr (max-page this)))
                                              (begin
                                                (set! (cdr (max-page this))
                                                  (max (1+ old) (cdr (max-page this))))
                                                (1+ old)))))
                 (cached-page this) #f))
    (else (next-method))))

(app/define-method (main-loop date)
  (define state (list (day-view (car (app/getf 'event-set)) date)))

  (while #t
    (output (car state))

    (let ((char (read-char)))
      (when (eof-object? char)
        (break))

      (match (input (car state) char)
        (('push new-state) (set! state (cons new-state state)))
        (('pop)
         (set! state (cdr state))
         (when (null? state) (break)))
        (('break) (break))
        (else 'continue)))))