#!/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-60) :select (list->integer))
             (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)
             (img-parse)


             (sxml gumbo)
             (json parser)

             ((xdg basedir) :prefix xdg-))

(define-syntax regex-case
  (syntax-rules (else)
    ((_ str var (else body ...))
     (begin body ...))

    ((_ str var (pat body ...) rest ...)
     (cond ((string-match pat str)
            => (lambda (var) body ...))
           (else (regex-case str var rest ...))))))

(define (class-handlers class)
  (fold (lambda (cl obj)
          (regex-case
           cl m
           ("^DH$"    (set-style obj 'bold))
           ("^bgImg$" obj)
           ("^bg([BCGMRWY]|Bl)$" (->> (match:substring m 1)
                                      string-upcase
                                      string->symbol
                                      (set-bg obj)))
           ("^([BCGMRWY]|bl)$"   (->> (match:substring m 1)
                                      string-upcase
                                      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.

;; "<id>.gif": #\x<num>
(define bg-cache (make-hash-table))

(define (save-bg-cache)
  (with-output-to-file (cache-file "bg.scm")
    (lambda ()
      (write (hash-map->list list bg-cache))
      (newline))))

(define (load-bg-cache)
  (define file (cache-file "bg.scm"))
  (when (file-exists? file)
    (let ((forms (call-with-input-file file read)))
      (when (list? forms)
        (for-each (lambda (form) (apply hash-set! bg-cache form))
                  forms)))))


(define bg-img-url "https://l.texttv.nu/storage/chars")

(define (get-bg-image-char frame img)
  (or (and=> (hash-ref bg-cache img) string)
      (let ((img-file (cache-file (path-append "img" img))))
        (unless (file-exists? img-file)
          (download-file (format #f "~a/~a" bg-img-url img)
                         img-file))

        (let ((char
               (->> (map (lambda (x)
                           (cond ((eq? x (get-fg frame)) #t)
                                 ((eq? x (get-bg frame)) #f)
                                 (else (scm-error 'misc-error "get-bg-image-char"
                                                  "Color neither foreground or background. fg: ~s, bg: ~s, file: ~s"
                                                  (list (get-fg frame) (get-bg frame)
                                                        img-file)
                                                  #f))))
                         (parse-image-file img-file))
                    list->integer
                    (vector-ref lookup-table))))
          (hash-set! bg-cache img char)
          (return-state (string char))))))


(define bg-rx (make-regexp (format #f "background: url\\(~a/([^)]*)\\)" bg-img-url)))

(define (handle-h1-or-span class style nodes)
  (define (err fmt . args)
    (scm-error 'misc-error "handle-h1-or-span"
               fmt args
               #f))

  (do fmt-before <- (get-attr)
      (push (class-handlers class))
      fmt-with <- (get-attr)
      frame <- (get-frame)
      ret <- (<$> (lambda (s) (string-append fmt-with s fmt-before))
                  (if (member "bgImg" (string-split class #\space))
                      (cond ((regexp-exec bg-rx style)
                             => (lambda (m) (get-bg-image-char frame (match:substring m 1))))
                            (else (err "bgImg without background image style")))
                      (<$> 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 #f #f))
        fmt-with <- (get-attr)
        (pop)
        (return-state
         (string-append fmt-with (car body) fmt-before)))]

   [(h1 (@ (class ,class) (style (,style ""))) ,nodes ...)
    (handle-h1-or-span class style nodes)]

   [(span (@ (class ,class) (style (,style ""))) ,nodes ...)
    (handle-h1-or-span class style nodes)]


   [,str (guard (string? str)) (return-state str)]

   [,default
    (match default
      ((tag) (return-state ""))
      ((tag ('@ args ...)) (return-state ""))
      ((tag ('@ args ...) nodes ...)
       (<$> string-concatenate (sequence (map fmt-tag nodes))))
      ((tag nodes ...)
       (<$> string-concatenate (sequence (map fmt-tag nodes))))
      (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 (build-cache-dir)
  (unless (file-exists? (cache-path))
    (mkdir (cache-path)))

  (let ((last-updated (cache-file "last-updated")))
    (unless (file-exists? last-updated)
      (with-output-to-file last-updated
        (lambda () (display 0)))))

  (unless (file-exists? (cache-file "img"))
    (mkdir (cache-file "img")))

  (unless (file-exists? (cache-file "rendered"))
    (mkdir (cache-file "rendered")))

  )

(define (render-page file el)
  (with-output-to-file file
    (lambda ()
      (-> el
          (assoc-ref "content")
          (vector-ref 0)
          (html->sxml #:trim-whitespace? #f
                      #:full-document? #f)
          fmt-tag
          (run-state (list (make-fmt-frame "" "" "")))
          car
          display))))


;; Render all pages in vector
(define (render-pages vect)
  (define (status i)
    (display-status-bar i (vector-length vect) (current-error-port)))

  (format (current-error-port) "~%Rendering HTML~%")

  (vector-for-each
   (lambda (i el)
     (status i)
     (render-page (cache-file (path-append
                               "rendered"
                               (format #f "~a.ansi" (assoc-ref el "num"))))
                  el))
   vect)

  (display-status-bar 1 1 (current-error-port))
  (newline (current-error-port)))

(define (download-file url destination)
  (system* "curl"
           "-s" url
           "-o" destination))

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

    (build-cache-dir)
    (load-bg-cache)

    (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...")
        (download-file "http://api.texttv.nu/api/get/100-999?app=hugonikanor"
                       json-cache)
        (newline)

        (let ((page-data (call-with-input-file json-cache json->scm)))
          (with-output-to-file (cache-file "last-updated")
            (lambda () (write (max-date page-data)) (newline)))
          (render-pages page-data))))

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

    (save-bg-cache)))