From 6297081081857b38da56665df7a1e91ca7e8ef82 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sat, 30 Jul 2022 21:52:54 +0200 Subject: Update all dependencies to work. --- main.scm | 150 +++++++++++++++++++++++++++++++-------------------------------- 1 file changed, 74 insertions(+), 76 deletions(-) (limited to 'main.scm') diff --git a/main.scm b/main.scm index fc11a26..9d23614 100755 --- a/main.scm +++ b/main.scm @@ -4,33 +4,33 @@ (add-to-load-path (dirname (current-filename))) (add-to-load-path (string-append (dirname (current-filename)) "/monad/")) -(add-to-load-path "/home/hugo/lib/guile") -(add-to-load-path "/home/hugo/code/calparse") ; For (util), move that to a library +(add-to-load-path "/home/hugo/code/calp/module") ; For (util), move that to a library -(setenv "LD_LIBRARY_PATH" (dirname (current-filename))) - -(use-modules #; (sxml simple) - ;; (sxml match) +(use-modules (sxml match) (srfi srfi-1) - (srfi srfi-26) (srfi srfi-43) ; Vector iteration + (srfi srfi-71) - ;; (ice-9 rdelim) (ice-9 regex) (ice-9 popen) + (ice-9 match) + (ice-9 format) - (macros arrow) - (util) + (hnh util) + (hnh util path) (monad) (monad state) (monad stack) (fmt-stack) - (html) - (json)) + + (sxml gumbo) + (json parser) + + ((xdg basedir) :prefix xdg-)) (define-macro (regex-case str . cases) `(cond @@ -50,59 +50,58 @@ (regex-case cl ("^DH$" (set-style obj 'bold)) - ("^bg([BYC])$" => (compose (cut set-bg obj <>) string->symbol substr-1)) - ("^([BYC])$" => (compose (cut set-fg obj <>) string->symbol substr-1)) + ("^bg([BYC])$" => (lambda (m) (->> (substr-1 m) string->symbol (set-bg obj)))) + ("^([BYC])$" => (lambda (m) (->> (substr-1 m) string->symbol (set-fg obj)))) (else obj))) (empty-fmt-frame) (string-split class #\space))) ;;; TODO every push and pop should emit current ANSI-escape after it has run. -(use-modules (ice-9 match)) - ;;; TODO Every clause should return a string, in the state context of a state. +(define (handle-h1-or-span class nodes) + (do fmt-before <- (get-attr) + (push (class-handlers class)) + fmt-with <- (get-attr) + ret <- (<$> (lambda (s) (string-append fmt-with s fmt-before)) + (<$> string-concatenate (sequence (map fmt-tag nodes)))) + (pop) + (return-state ret))) + ;; +-- State storage, "mutable" ;; | +- Return value, static ;; V V ;; sxml → State (define (fmt-tag tag) - (match tag - - [('a _ body ...) - (do fmt-before <- (get-attr) - (push (make-fmt-frame 'underline 'B #f)) - fmt-with <- (get-attr) - (pop) - (return-state - (string-append fmt-with (car body) fmt-before)))] - - [((or 'h1 'span) attrs nodes ...) - (do let class = (hashq-ref attrs 'class) - fmt-before <- (get-attr) - (push (class-handlers class)) - fmt-with <- (get-attr) - ret <- (<$> (cut string-append fmt-with <> fmt-before) - (<$> string-concatenate (sequence (map fmt-tag nodes)))) - (pop) - (return-state ret))] - - ;; Default rule, since the above case requires a class list - [(tag _ node nodes ...) - (<$> string-concatenate (sequence (map fmt-tag (cons node nodes))))] - - ;; Just ignore tags without children - [(tag _) (return-state "")] - - [(? string? str) (return-state str)] - - [default (return-state (format #f "[|~a|]" default))])) - -(define (parse-html-string str) - (let ((fname (tmpnam))) - (with-output-to-file fname - (lambda () (display str))) - (parse-html fname))) + (sxml-match + tag + [(a ,body ...) + (do fmt-before <- (get-attr) + (push (make-fmt-frame 'underline 'B #f)) + fmt-with <- (get-attr) + (pop) + (return-state + (string-append fmt-with (car body) fmt-before)))] + + [(h1 (@ (class ,class)) ,nodes ...) + (handle-h1-or-span class nodes)] + + [(span (@ (class ,class)) ,nodes ...) + (handle-h1-or-span class nodes)] + + + [,str (guard (string? str)) (return-state str)] + + ;; Just ignore tags without children + [,default + (match default + ((tag ('@ args ..) node nodes ...) + (<$> string-concatenate (sequence (map fmt-tag (cons node nodes))))) + ((tag node nodes ...) + (<$> string-concatenate (sequence (map fmt-tag (cons node nodes))))) + ((tag) (return-state "")) + (default (return-state (format #f "[|~a|]" default))))])) (define (text-for-num j int) (let* ((table (vector-ref j (- int 100))) @@ -111,19 +110,16 @@ text)) (define (max-date vect) - (vector-fold (lambda (i accum el) (max accum (hashq-ref el 'date_updated_unix))) - 0 vect)) + (-> (find-max (vector->list vect) + (lambda (el) (assoc-ref el "date_updated_unix"))) + (assoc-ref "date_updated_unix"))) -(define (cache-dir) - (string-append - (or (getenv "XDG_CACHE_HOME") - (and=> (getenv "HOME") (cut string-append <> "/.cache")) - "/tmp") - "/texttv/")) +(define (cache-path) + (path-append (xdg-cache-home) "texttv")) -(define (cfile path) +(define (cache-file path) "Gives path to file in cache directory." - (string-append (cache-dir) path)) + (path-append (cache-path) path)) (define* (display-status-bar n max #:optional (port #t)) (let* ((progress (/ n max)) @@ -135,37 +131,39 @@ (truncate (* 100 progress))))) (define (main args) - (let* (((self filename pagestr) args) + (let* ((self filename pagestr (apply values args)) (page (string->number pagestr))) - (unless (file-exists? (cache-dir)) - (mkdir (cache-dir)) - (with-output-to-file (cfile "last-updated") + (unless (file-exists? (cache-path)) + (mkdir (cache-path)) + (with-output-to-file (cache-file "last-updated") (lambda () (display 0)))) - (let ((last-updated (call-with-input-file (cfile "last-updated") read))) + (let ((last-updated (call-with-input-file (cache-file "last-updated") read))) (when (> (- (current-time) last-updated) 10000) (display "Downloading new data, please stand by...") (system* "curl" "-s" "http://api.texttv.nu/api/get/100-999?app=hugonikanor" - "-o" (cfile filename)) + "-o" (cache-file filename)) - (let* ((json (get-json (cfile filename))) + (let* ((json (call-with-input-file (cache-file filename) json->scm)) (update (max-date json))) - (with-output-to-file (cfile "last-updated") (lambda () (display update))) + (with-output-to-file (cache-file "last-updated") (lambda () (display update))) (let ((vlen (vector-length json))) (format (current-error-port) "~%Rendering HTML~%") (vector-for-each (lambda (i el) - (let ((num (hashq-ref el 'num)) - (text (vector-ref (hashq-ref el 'content) 0))) - (with-output-to-file (cfile (format #f "~a.ansi" num)) + (let ((num (assoc-ref el "num")) + (text (-> el (assoc-ref "content") (vector-ref 0)))) + (with-output-to-file (cache-file (format #f "~a.ansi" num)) (lambda () (display-status-bar i vlen (current-error-port)) - (-> (parse-html-string text) + (-> (html->sxml text + #:trim-whitespace? #f + #:full-document? #f) fmt-tag (run-state (list (make-fmt-frame "" "" ""))) car display))))) @@ -173,6 +171,6 @@ (display-status-bar 1 1 (current-error-port)) (newline (current-error-port)))) - (let ((p1 (cfile (format #f "~a.ansi" page))) - (p2 (cfile (format #f "~a.ansi" (1+ page))))) + (let ((p1 (cache-file (format #f "~a.ansi" page))) + (p2 (cache-file (format #f "~a.ansi" (1+ page))))) (system* "paste" p1 p2))))) -- cgit v1.2.3