Update all dependencies to work.

8 files changed, 77 insertions, 346 deletions

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 <gumbo.h>
-#include <libguile.h>
-
-#include <sys/mman.h>
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <fcntl.h>
-
-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 <hashtable>) port)
-  (display (fmt-hash-table t) port))
-
-(define-method (display (t <hashtable>) 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 <cjson/cJSON.h>
-#include <libguile.h>
-
-#include <sys/mman.h>
-#include <sys/types.h>
-#include <sys/stat.h>
-#include <fcntl.h>
-
-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 <fmt-stack> <string>
 (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)))))