(define-module (text markup) :use-module (hnh util) :use-module (srfi srfi-1) :use-module (srfi srfi-71) :use-module (ice-9 match) :use-module (ice-9 pretty-print) :use-module (text util) :use-module (text flow) :use-module (texinfo string-utils) :export (sxml->ansi-text)) ;; Takes an HTML-like sxml coded tree, and produces a string with ;; appropriate spacing and ANSI-escapes for different tags. (define (sxml->ansi-text tree) ((parse-tree ontree onleaf) tree)) (define (esc . effect) (format #f "\x1b[~am" (if (null? effect) ; NOCOV "" (case (car effect) ; NOCOV [(bold) 1] [(italic) 3] [(invert) 7] [else (scm-error 'misc-error "esc" "Unknown escape: ~s" (car effect) #f)])))) ;; tag := (tag-name [(@ attributes ...)] body ...) ;; alist → tag → tag (define (add-attributes args) (match-lambda [(name ('@ tagargs ...) body ...) `(,name (@ ,@(assq-limit (assq-merge tagargs args))) ,@body)] [(name body ...) `(,name (@ ,@args) ,@body)] [nonlist nonlist])) (define (get-attr args key default) (aif (assoc-ref args key) (car it) default)) (define (dt? x) (and (list? x) (eq? 'dt (car x)))) (define (dd? x) (and (list? x) (eq? 'dd (car x)))) ;; NOTE Some tags can be given a `width' attribute. This is however not yet ;; fully supported. (define* (ontree tag body optional: (args '())) (case tag [(*TOP* group block) (string-concatenate (map (compose sxml->ansi-text (add-attributes args)) body))] [(header) (sxml->ansi-text `(group (center (@ ,@args) (b ,@body)) (br)))] [(center) (center-string (string-concatenate (map sxml->ansi-text body)) (get-attr args 'width 70))] [(p) (string-append (string-join (flow-text (string-concatenate (map sxml->ansi-text body)) width: (get-attr args 'width 70)) "\n") (if (assoc-ref args 'inline) "" "\n\n") )] [(b) (string-append (esc 'bold) (string-concatenate (map sxml->ansi-text body)) (esc))] [(i em) (string-append (esc 'italic) (string-concatenate (map sxml->ansi-text body)) (esc))] ;; NOOP, but for future use. [(code) (string-concatenate (map sxml->ansi-text body))] [(blockquote) (string-concatenate (map (lambda (line) (sxml->ansi-text `(group (ws (@ (minwidth 4))) ,line (br)))) (flow-text (string-concatenate (map sxml->ansi-text body)) ;; TODO shouldn't this use (- width 4)? width: 66)))] [(ws) (make-string (aif (assoc-ref args 'minwidth) (car it) 1) #\space)] [(br) "\n"] ;; TODO width [(hr) (string-append " " (make-string 60 #\─) " \n")] [(dl) (let* ((body (map (lambda (el) (cond ((dt? el) (list 'dt (sxml->ansi-text el))) ((dd? el) el) (else (scm-error 'wrong-type-arg "ontree" "Only
and are valid children of