1 files changed, 334 insertions, 0 deletions
diff --git a/module/calp/terminal.scm b/module/calp/terminal.scm
new file mode 100644
index 00000000..fd513a63
--- /dev/null
+++ b/module/calp/terminal.scm
@@ -0,0 +1,334 @@
+(define-module (calp terminal)
+  #: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 (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 (vcomponent search)
+
+  #:use-module (text util)
+  #:use-module (text flow)
+
+  #:use-module (ice-9 format)
+  #:use-module (ice-9 readline)
+  #:use-module (ice-9 match)
+
+  #:use-module (vulgar termios)
+
+  #:use-module (oop goops)
+  #:use-module (oop goops describe)
+
+  #:autoload (vcomponent instance) (global-event-object)
+
+  #: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 (get-line prompt)
+  (let* ((attr (make-termios))
+         (input-string #f))
+    (tcgetattr! attr)
+    (set! (lflag attr) (logior ECHO (lflag attr)))
+    (tcsetattr! attr)
+    (system "tput cnorm")
+    (set! input-string (readline prompt))
+    (system "tput civis")
+    (set! (lflag attr) (logand (lognot ECHO) (lflag attr)))
+    (tcsetattr! attr)
+    input-string
+    ))
+
+(define-method (input (this <day-view>) char)
+  (set! (page-length this) (length (cached-events this)))
+
+  (case char
+    ((#\L #\l right)
+     (set! (current-page this) = add-day
+           (cached-events this) #f
+           (active-element this) 0))
+
+    ((#\h #\H left)
+     (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 ((search-term (get-line "quick search: ")))
+       `(push ,(search-view
+                (format #f "(regexp-exec (make-regexp \"~a\" regexp/icase) (prop event 'SUMMARY))"
+                        search-term)
+                (get-event-set this)))))
+
+    ((#\() (set-cursor-pos 0 (1- height))
+     (let ((search-term (get-line "search: ")))
+       `(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:))
+
+(define (search-view search-term event-set)
+  (make <search-view> search-term: search-term event-set: event-set))
+
+
+(define-method (initialize (this <search-view>) args)
+  (set! (current-page this) 0)
+  (next-method)
+
+  (set! (search-term this)
+    (prepare-string (search-term this)))
+
+  (let ((q (build-query-proc (search-term this))))
+    (slot-set! this 'search-result
+               (prepare-query
+                q (get-event-set this))))
+  ;; (define current-page 0)
+  ;; (define current-entry 0)
+  )
+
+(define-method (output (this <search-view>))
+
+  (define paginator (slot-ref this 'search-result))
+
+  (define page
+    (catch 'max-page
+      (lambda () (get-page paginator (current-page this)))
+      (lambda (err page-number)
+        (set! (current-page this) page-number)
+        (get-page paginator page-number))))
+
+
+  (cls)
+
+  (display "== Search View ==\n")
+
+  ;; display search term
+  (format #t "~y" (search-term this))
+
+  ;; display event list
+  (display-event-table
+   page
+   #:active-element (active-element this)
+   #:location-width 15)
+
+  (paginator->sub-list
+   paginator (current-page this)
+   (lambda (i)
+     (if (= i (current-page this))
+         (format #t "[~2@a]" i)
+         (format #t " ~2@a " i)))
+   head-proc:
+   (lambda (start)
+     (if (= start 0)
+         "|" "<"))
+   tail-proc:
+   (lambda (end)
+     (if (= end (get-max-page paginator))
+         (if (true-max-page? paginator)
+             "|" "?")
+         ">")))
+  (newline))
+
+(define-method (input (this <view>) char)
+  (case char
+    ((#\j #\J down) (unless (= (active-element this) (1- (page-length this)))
+                      (set! (active-element this) = (+ 1))))
+    ((#\k #\K up) (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)
+  ;; TODO update this to match actual page length
+  (set! (page-length this) 10)
+
+  (case char
+    ((#\newline) `(push ,(day-view (get-event-set this)
+                                   (as-date (prop (list-ref (get-page (slot-ref this 'search-result)
+                                                                      (current-page this))
+                                                           (active-element this))
+                                                 'DTSTART)))))
+    ((#\h left) (set! (current-page this) = ((lambda (old) (max 0 (1- old))))))
+    ((#\l right)
+     (display "\n loading...\n")
+     (set! (current-page this)
+       (next-page (slot-ref this 'search-result)
+                  (current-page this))))
+    (else (next-method))))
+
+(define-public (main-loop date)
+  (define state (list (day-view (get-event-set global-event-object) date)))
+
+  (while #t
+    (output (car state))
+
+    (let ((char (read-char)))
+      (when (eof-object? char)
+        (break))
+
+      (when (char=? char #\escape)
+        (case (read-char)
+          ((#\[)
+           (case (read-char)
+             ((#\A) (set! char 'up))
+             ((#\B) (set! char 'down))
+             ((#\C) (set! char 'right))
+             ((#\D) (set! char 'left))))))
+
+      (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)))))