From 16152c437089a575c996fcd088b00a3e4f20837d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 17 Aug 2020 18:27:13 +0200 Subject: move terminal output. --- module/calp/entry-points/terminal.scm | 2 +- module/calp/terminal.scm | 334 +++++++++++++++++++++++++++++++++ module/output/terminal.scm | 335 ---------------------------------- 3 files changed, 335 insertions(+), 336 deletions(-) create mode 100644 module/calp/terminal.scm delete mode 100644 module/output/terminal.scm (limited to 'module') diff --git a/module/calp/entry-points/terminal.scm b/module/calp/entry-points/terminal.scm index 5a9b2588..fa035e7a 100644 --- a/module/calp/entry-points/terminal.scm +++ b/module/calp/entry-points/terminal.scm @@ -1,6 +1,6 @@ (define-module (calp entry-points terminal) :export (main) - :use-module (output terminal) + :use-module (calp terminal) :use-module (vcomponent) :use-module (ice-9 getopt-long) :use-module (datetime) 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 () + (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 () + #; + (date accessor: view-date + init-keyword: date:) + + (cached-events accessor: cached-events + init-value: #f) + (groups accessor: groups)) + + +(define-method (initialize (this ) args) + (next-method) + (set! (groups this) (group-stream (get-event-set this)))) + +(define-method (output (this )) + + (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 ) 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 event-set: event-set current-page: date)) + +(define-class () + (search-result getter: search-result) + (search-term accessor: search-term + init-keyword: search-term:)) + +(define (search-view search-term event-set) + (make search-term: search-term event-set: event-set)) + + +(define-method (initialize (this ) 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 )) + + (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 ) 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 ) 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))))) diff --git a/module/output/terminal.scm b/module/output/terminal.scm deleted file mode 100644 index 946f5100..00000000 --- a/module/output/terminal.scm +++ /dev/null @@ -1,335 +0,0 @@ -(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 (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 () - (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 () - #; - (date accessor: view-date - init-keyword: date:) - - (cached-events accessor: cached-events - init-value: #f) - (groups accessor: groups)) - - -(define-method (initialize (this ) args) - (next-method) - (set! (groups this) (group-stream (get-event-set this)))) - -(define-method (output (this )) - - (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 ) 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 event-set: event-set current-page: date)) - -(define-class () - (search-result getter: search-result) - (search-term accessor: search-term - init-keyword: search-term:)) - -(define (search-view search-term event-set) - (make search-term: search-term event-set: event-set)) - - -(define-method (initialize (this ) 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 )) - - (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 ) 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 ) 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))))) -- cgit v1.2.3