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

(use-modules (sxml simple)
             (sxml match)
             (ice-9 match)
             (srfi srfi-1))

(define (setmode . args)
  "Sets display mode"
  (with-output-to-string
    (lambda ()
     (for-each display
               `(#\escape #\[ ,@args #\m)))))


(define* (deffunc name idx
           #:optional (func-pre '#{}#) (mode-pre ""))
  (let ((str (gensym)))
    `(define (,(symbol-append func-pre name) . ,str)
       (string-append 
        (setmode ,mode-pre ,idx)
        #; (string #\escape #\[ #\K)
        (string-concatenate ,str)
        (setmode 0)))))

(define-macro (create-modes modes)
  `(begin
     ,@(map deffunc
            modes
            (iota (length modes)))))

(define-macro (create-colors modes)
  `(begin
     ,@(apply append
              (map (lambda (itm idx)
                     (list (deffunc itm idx 'fg- "0;3")
                           (deffunc itm idx 'bg- "0;4")))
                   modes
                   (iota (length modes))))))

(create-modes (off bold dim slant underline))
(create-colors (black red green yellow blue purple cyan white))

(define classmap
  (match-lambda ("B"   fg-blue)
                ("bgB" bg-blue)
                ("Y"   fg-yellow)
                ("C"   fg-cyan)
                ("DH"  bold)
                (_ identity)))

(define (class-handlers class-str)
  (fold compose identity
        (map classmap (string-split class-str #\space))))

(define (fmt-sub nodes)
  (string-concatenate (map fmt-tag nodes)))

(define (fmt-tag tag)
  (sxml-match tag
              [(a #; (@ (class ,class)) ,text)
               (underline text)]

              [(h1 (@ (class ,class)) ,nodes ...)
               ((class-handlers class)
                (bold (fmt-sub nodes)))]

              [(span (@ (class ,class)) ,nodes ...)
               ((class-handlers class)
                (fmt-sub nodes))]

              [,str (guard (string? str)) str]

              [,default (format #f "[|~a|]" default)]
              ))

(define (parse-doc sxml)
  (sxml-match sxml
              [(*TOP* (div #; (span (@ (class "toprow")) ,top-row ...)
                           ,spans ...))
               spans
               ]))

(define (main args)
  (define d (call-with-input-file "100-2.html" xml->sxml))
  (display (string-concatenate (map fmt-tag (parse-doc d))))
  (newline))