diff options
Diffstat (limited to '')
-rw-r--r-- | module/util/options.scm | 117 |
1 files changed, 2 insertions, 115 deletions
diff --git a/module/util/options.scm b/module/util/options.scm index 17d77006..41514a8f 100644 --- a/module/util/options.scm +++ b/module/util/options.scm @@ -1,9 +1,7 @@ (define-module (util options) :use-module (util) - :use-module (ice-9 match) - :use-module (ice-9 pretty-print) :use-module (srfi srfi-1) - :use-module ((output text) :select (flow-text))) +) ;; option-assoc → getopt-valid option-assoc (define-public (getopt-opt options) @@ -41,119 +39,8 @@ `((blockquote ,@it) (br))))))) -(define (esc . effect) - (format #f "\x1b[~am" - (if (null? effect) - "" - (case (car effect) - [(bold) 1] - [(italic) 3] - [(invert) 7] - [else 4])))) +(use-modules (text markup)) -(use-modules (texinfo string-utils)) - -(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* (true-string-pad str len optional: (chr #\space)) - (let ((strlen ((@@ (output text) true-string-length) str))) - (if (> strlen len) - str - (string-append (make-string (- len strlen) chr) str)))) - -(define (get-attr args key default) - (aif (assoc-ref args key) - (car it) default)) - -;; NOTE width is hard coded to 70 chars -(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)) - width: 66)))] - [(ws) (make-string (aif (assoc-ref args 'minwidth) - (car it) 1) - #\space)] - [(br) "\n"] - [(hr) (string-append " " (make-string 60 #\_) " \n")] - [(dl) - (let* ((dts dds (partition (lambda (x) (eq? 'dt (car x))) body))) - (let* ((dts* (map sxml->ansi-text dts)) - (m (if (null? dts*) 0 (apply max (map (@@ (output text) true-string-length) dts*))))) - (string-concatenate - (map (lambda (dt dd) - (let ((dds (string-split dd #\newline))) - (string-concatenate - (map (lambda (left right) - (string-append (true-string-pad left m) " │ " right "\n")) - (cons dt (map (const "") (iota (1- (length dds))))) - dds)))) - dts* - (map (compose sxml->ansi-text (add-attributes `((width ,(- 70 m 5))))) - dds)))))] - [(dt) (string-concatenate (map (compose sxml->ansi-text (add-attributes args)) - body))] - [(dd) - (string-concatenate - (map (compose sxml->ansi-text (add-attributes args)) - body))] - - [(scheme) - (string-concatenate - (map (lambda (form) - (with-output-to-string - (lambda () (pretty-print form width: (aif (assoc-ref args 'width) (car it) 70))))) - body))] - - [else (string-append (esc 'bold) "??" - "`" - (esc 'invert) - (string-concatenate (map sxml->ansi-text body)) - (esc) "'")] - ) - ) - -(define (onleaf leaf) - (format #f "~a" leaf)) - -(define (parse-tree tree-callback leaf-callback) - (match-lambda - [(tag ('@ args ...) body ...) - (tree-callback tag body args)] - [(tag body ...) - (tree-callback tag body) - ] - [() ""] - [(any ...) (map leaf-callback any)] - [any (leaf-callback any)])) - - -(define-public (sxml->ansi-text tree) - ((parse-tree ontree onleaf) tree)) (define-public (format-arg-help options) (sxml->ansi-text (cons '*TOP* (map sxml->ansi-text (map fmt-help options))))) |