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. --- .gitmodules | 2 +- Makefile | 27 ----------- README | 4 +- html.c | 101 ---------------------------------------- html.scm | 19 -------- json.c | 112 --------------------------------------------- json.scm | 8 ---- main.scm | 150 ++++++++++++++++++++++++++++++------------------------------ 8 files changed, 77 insertions(+), 346 deletions(-) delete mode 100644 Makefile delete mode 100644 html.c delete mode 100644 html.scm delete mode 100644 json.c delete mode 100644 json.scm diff --git a/.gitmodules b/.gitmodules index 0c205dd..bff6f6c 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,3 @@ [submodule "monad"] path = monad - url = git.hornquist.se:git/scheme-monad.git + url = git@hornquist.se:git/scheme-monad.git diff --git a/Makefile b/Makefile deleted file mode 100644 index 8f867c9..0000000 --- a/Makefile +++ /dev/null @@ -1,27 +0,0 @@ -CFLAGS := -fPIC $(shell guile-config compile) \ - $(shell pkg-config --cflags gumbo) \ - -I/usr/local/include/ -Wall -LFLAGS := $(shell guile-config link) \ - $(shell pkg-config --libs gumbo) \ - -L/usr/local/lib -lcjson -CC := gcc - -.PHONY: all clean - -all: libguile-json.so libguile-html.so - -%: %.oo - $(CC) -o $@ $< $(LFLAGS) - -%.x: %.c - guile-snarf -o $@ $< $(CFLAGS) - -libguile-%.so: %.oo - $(CC) -shared -o $@ $< $(LFLAGS) - -%.oo: %.c %.x - $(CC) -c -o $@ $(CFLAGS) $< - -clean: - -rm *.oo - -rm libguile-*.so diff --git a/README b/README index b744e05..1044c1a 100644 --- a/README +++ b/README @@ -1,4 +1,4 @@ Dependencies ------------ -- cJSON -- Gumbo +- guile-gumbo +- guile-json diff --git a/html.c b/html.c deleted file mode 100644 index 79d8615..0000000 --- a/html.c +++ /dev/null @@ -1,101 +0,0 @@ -#include -#include - -#include -#include -#include -#include - -SCM handle_node (GumboNode* n) { - - SCM dummytagname, scm_children = SCM_EOL; - GumboNode* ch; - switch (n->type) { - case GUMBO_NODE_DOCUMENT: - ; - GumboDocument doc = n->v.document; - for (int i = 0; i < doc.children.length; i++) { - ch = doc.children.data[i]; - scm_children = scm_cons (handle_node(ch), scm_children); - } - scm_children = scm_reverse_x(scm_children, SCM_EOL); - - return scm_cons ( scm_from_utf8_symbol("*TOP*"), - scm_cons ( SCM_BOOL_F, scm_children)); - - case GUMBO_NODE_TEMPLATE: - case GUMBO_NODE_ELEMENT: - ; - SCM attributes; - - GumboElement el = n->v.element; - GumboVector attr = el.attributes; - - attributes = scm_c_eval_string("(make-hash-table)"); - - GumboAttribute* a; - for (int i = 0; i < attr.length; i++) { - a = attr.data[i]; - scm_hashq_set_x (attributes, - scm_from_utf8_symbol(a->name), - scm_from_utf8_stringn(a->value, strlen(a->value))); - } - - for (int i = 0; i < el.children.length; i++) { - ch = el.children.data[i]; - scm_children = scm_cons (handle_node(ch), scm_children); - } - scm_children = scm_reverse_x(scm_children, SCM_EOL); - - return scm_cons (scm_from_utf8_symbol(gumbo_normalized_tagname(el.tag)), - scm_cons (attributes, scm_children)); - - case GUMBO_NODE_TEXT: - case GUMBO_NODE_WHITESPACE: - return scm_from_utf8_stringn(n->v.text.text, strlen(n->v.text.text)); - - case GUMBO_NODE_CDATA: - dummytagname = scm_from_utf8_symbol("cdata"); - goto rettext; - case GUMBO_NODE_COMMENT: - dummytagname = scm_from_utf8_symbol("comment"); - -rettext: - return scm_cons (dummytagname, - scm_cons ( SCM_BOOL_F, - scm_from_utf8_stringn(n->v.text.text, strlen(n->v.text.text)))); - } - return SCM_BOOL_F; -} - -SCM_DEFINE (parse_html, "parse-html", 1, 0, 0, - (SCM filename), - "") -{ - char* fname = scm_to_utf8_string(filename); - int fd = open(fname, O_RDONLY); - struct stat sb; - fstat(fd, &sb); - const char* buf = mmap(NULL, sb.st_size, PROT_READ, MAP_SHARED, fd, 0); - - - if (buf == NULL) { - fprintf(stderr, "Error MMAPing file\n"); - return scm_from_utf8_symbol("mmap-err"); - } - - GumboOutput* output = gumbo_parse(buf); - - SCM ret = handle_node (output->root); - // GumboNode* p = n->parent; - - gumbo_destroy_output(&kGumboDefaultOptions, output); - - return ret; -} - -void init_html (void) { -#ifndef SCM_MAGIC_SNARFER -#include "html.x" -#endif -} diff --git a/html.scm b/html.scm deleted file mode 100644 index 90dd039..0000000 --- a/html.scm +++ /dev/null @@ -1,19 +0,0 @@ -(define-module (html) - #:export (parse-html) - #:re-export (write) - #:use-module (oop goops) - ) - -;; (setenv "LD_LIBRARY_PATH" (dirname (current-filename))) - -;; exposes the parse-html symbol -(load-extension "libguile-html" "init_html") - -(define (fmt-hash-table t) - `(@ ,@(hash-map->list cons t))) - -(define-method (write (t ) port) - (display (fmt-hash-table t) port)) - -(define-method (display (t ) port) - (display (fmt-hash-table t) port)) diff --git a/json.c b/json.c deleted file mode 100644 index 9504e35..0000000 --- a/json.c +++ /dev/null @@ -1,112 +0,0 @@ -#include -#include - -#include -#include -#include -#include - -static SCM json_type; - -static inline void assert_json (SCM item) - { scm_assert_foreign_object_type (json_type, item); } -static inline cJSON* to_json (SCM item) - { return scm_foreign_object_ref (item, 0); } -static inline SCM from_json (cJSON* item) - { return scm_make_foreign_object_1 (json_type, item); } - -SCM_DEFINE (parse_json, "parse-json", 1, 0, 0, - (SCM filename), - "") -{ - char* fname = scm_to_utf8_stringn (filename, NULL); - - int fd = open(fname, O_RDONLY); - struct stat sb; - fstat(fd, &sb); - const char* buf = mmap(NULL, sb.st_size, PROT_READ, MAP_SHARED, fd, 0); - - return from_json (cJSON_Parse(buf)); -} - -SCM json_to_scheme (cJSON* j) { - cJSON* node; - switch (j->type) { - case cJSON_Invalid: - return scm_from_utf8_symbol("invalid"); - - case cJSON_False: - return SCM_BOOL_F; - - case cJSON_True: - return SCM_BOOL_T; - - case cJSON_NULL: - return SCM_EOL; - - case cJSON_Number: - return scm_values(scm_list_2( - scm_from_int(j->valueint), - scm_from_double(j->valuedouble))); - - case cJSON_String: - return scm_from_utf8_string(j->valuestring); - - case cJSON_Array: - node = j->child; - - SCM list = SCM_EOL; - while (node != NULL) { - list = scm_cons(json_to_scheme(node), list); - node = node->next; - } - return scm_vector(scm_reverse_x (list, SCM_EOL)); - - case cJSON_Object: - node = j->child; - SCM table = scm_c_eval_string ("(make-hash-table)"); - while (node->next != NULL) { - scm_hashq_set_x (table, - scm_from_utf8_symbol(node->string), - json_to_scheme(node)); - node = node->next; - } - return table; - - - case cJSON_Raw: - return scm_from_utf8_symbol("raw"); - } - - return scm_from_utf8_symbol("nocase"); -} - -SCM_DEFINE(json_to_scheme_, "json->scm", 1, 0, 0, - (SCM json), - "") -{ - assert_json(json); - cJSON* j = to_json(json); - - return json_to_scheme (j); -} - -static void finilize_json (SCM json) { - cJSON* j = to_json(json); - cJSON_Delete (j); -} - -static void init_json_type (void) { - SCM name = scm_from_utf8_symbol("json"); - SCM slot = scm_list_1(scm_from_utf8_symbol("data")); - scm_t_struct_finalize finilizer = finilize_json;; - json_type = scm_make_foreign_object_type (name, slot, finilizer); -} - -void init_json (void) { - init_json_type (); - -#ifndef SCM_MAGIC_SNARFER -#include "json.x" -#endif -} diff --git a/json.scm b/json.scm deleted file mode 100644 index bb33e5d..0000000 --- a/json.scm +++ /dev/null @@ -1,8 +0,0 @@ -(define-module (json) - #:export (get-json parse-json json->scm)) -;; (setenv "LD_LIBRARY_PATH" (string-append "/usr/local/lib:" (getcwd))) - -(load-extension "libguile-json" "init_json") - -(define (get-json filename) - (json->scm (parse-json filename))) 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