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/output/terminal.scm | 335 --------------------------------------------- 1 file changed, 335 deletions(-) delete mode 100644 module/output/terminal.scm (limited to 'module/output/terminal.scm') 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