;;; (yolk attrs) --- text attributes

(import (scheme base)
        (scheme write)
        (chicken string)
        (yolk common))

(define %props-alist
  '((reset . "0")
    ;; name . (on . off)
    (bold . ("1" . "22"))
    (dim . ("2" . "22"))
    (italic . ("3" . "23"))
    (underline . ("4" . "24"))
    (blink . ("5" . "25"))
    (inverse . ("7" . "27"))
    (hidden . ("8" . "28"))
    (strikethrough . ("9" . "29"))))

(define (prop? x)
  (let ((x? (memq x (map car %props-alist))))
    (if x? x #f)))

(define %colors-alist
  '((reset . "0")
    ;; color . (fg . bg)
    (black . ("30" . "40"))
    (red . ("31" . "41"))
    (green . ("32" . "42"))
    (yellow . ("33" . "43"))
    (blue . ("34" . "44"))
    (magenta . ("35" . "45"))
    (cyan . ("36" . "46"))
    (white . ("37" . "47"))
    (default . ("39" . "49"))))

(define (color? x)
  (let ((x? (memq x (map car %colors-alist))))
    (if x? x #f)))

(define (attrs as)
  (let loop ((as as)
             (acc '()))
    (cond
     ((null? as)
      (attr-list->escape (reverse acc)))
     ((eq? as 'reset)
      (csi "0m"))
     (else
      (loop (cdr as)
           (cons (attr->code (car as))
                 acc))))))

(define (attr-list->escape al)
  (let ((code-string (string-intersperse (map ->string al) ";")))
    (csi code-string "m")))

(define (attr->code attr)
  (cond
   ((number? attr) attr)
   ((or (color? attr)
        (and (pair? attr)
             (eq? (car attr) 'fg)
             (or (color? (cdr attr))
                 (color? (cadr attr)))))
    => (lambda (clr)
         (cadr (assq clr %colors-alist))))
   ((and (pair? attr)
         (eq? (car attr) 'bg)
         (or (color? (cdr attr))
             (color? (cadr attr))))
    => (lambda (clr)
         (cddr (assq clr %colors-alist))))
   ((or (prop? attr)
        (and (pair? attr)
             (eq? (car attr) 'set)
             (or (prop? (cdr attr))
                 (prop? (cadr attr)))))
    => (lambda (prop)
         (cadr (assq prop %props-alist))))
   ((and (pair? attr)
         (eq? (car attr) 'reset)
         (or (prop? (cdr attr))
             (prop? (cadr attr))))
    => (lambda (prop)
         (cddr (assq prop %props-alist))))
   (else (error "Bad attribute" attr))))

(define (with-attrs as str)
  (string-append
   (attrs as)
   str
   (attrs 'reset)))