Update all dependencies to work.

1 files changed, 74 insertions, 76 deletions

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)))))