#!/usr/bin/guile \
-q -e main -s
!#

(add-to-load-path (dirname (current-filename)))
(add-to-load-path (string-append (dirname (current-filename)) "/monad/"))

(add-to-load-path "/home/hugo/code/calp/module")  ; For (util), move that to a library

(use-modules (sxml match)

             (srfi srfi-1)
             (srfi srfi-43)             ; Vector iteration
             (srfi srfi-71)

             (ice-9 regex)
             (ice-9 popen)
             (ice-9 match)
             (ice-9 format)

             (hnh util)
             (hnh util path)

             (monad)
             (monad state)
             (monad stack)

             (fmt-stack)

             (sxml gumbo)
             (json parser)

             ((xdg basedir) :prefix xdg-))

(define-macro (regex-case str . cases)
  `(cond
    ,@(map (lambda (case)
                (let ((pattern (car case))
                      (rest (cdr case)))
                  (if (eq? pattern 'else)
                      `(else ,@rest)
                      `((string-match ,pattern ,str) ,@rest))))
           cases)))

(define (substr-1 match)
  (match:substring match 1))

(define (class-handlers class)
  (fold (lambda (cl obj)
          (regex-case
           cl
           ("^DH$"           (set-style obj 'bold))
           ("^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.

;;; 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)
  (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)))
         (arr (hashq-ref table 'content))
         (text (array-ref arr 0)))
    text))

(define (max-date vect)
  (-> (find-max (vector->list vect)
                (lambda (el) (assoc-ref el "date_updated_unix")))
      (assoc-ref "date_updated_unix")))

(define (cache-path)
  (path-append (xdg-cache-home) "texttv"))

(define (cache-file path)
  "Gives path to file in cache directory."
  (path-append (cache-path) path))

(define* (display-status-bar n max #:optional (port #t))
  (let* ((progress (/ n max))
         (trnc (truncate (* 60 progress))))
    (format port
            "\rProgress [~a~a] ~3d%"
            (make-string trnc #\#)
            (make-string (- 60 trnc) #\-)
            (truncate (* 100 progress)))))

(define (main args)
  (let* ((self filename pagestr (apply values args))
         (page (string->number pagestr)))

    (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 (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" (cache-file filename))

       (let* ((json (call-with-input-file (cache-file filename) json->scm))
              (update (max-date json)))

         (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 (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))
                    (-> (html->sxml text
                                    #:trim-whitespace? #f
                                    #:full-document? #f)
                        fmt-tag
                        (run-state (list (make-fmt-frame "" "" "")))
                        car display)))))
            json))
         (display-status-bar 1 1 (current-error-port))
         (newline (current-error-port))))

     (let ((p1 (cache-file (format #f "~a.ansi" page)))
           (p2 (cache-file (format #f "~a.ansi" (1+ page)))))
       (system* "paste" p1 p2)))))