diff options
Diffstat (limited to '')
-rw-r--r-- | module/text/flow.scm | 51 | ||||
-rw-r--r-- | module/text/markup.scm | 117 | ||||
-rw-r--r-- | module/text/numbers.scm (renamed from module/output/text.scm) | 88 | ||||
-rw-r--r-- | module/text/util.scm | 45 |
4 files changed, 215 insertions, 86 deletions
diff --git a/module/text/flow.scm b/module/text/flow.scm new file mode 100644 index 00000000..3d97bed6 --- /dev/null +++ b/module/text/flow.scm @@ -0,0 +1,51 @@ +(define-module (text flow) + :use-module (util) + :use-module (text util) + :use-module (srfi srfi-1) + ) + + + +;; (str) -> str +(define* (justify-line-helper words #:key (width 70)) + (let* ((phrase-length (true-string-length (string-concatenate/shared words))) + (needed-spaces (- width phrase-length)) + (slots (1- (length words))) + (space-list + (let loop ((n needed-spaces) (d slots)) + (unless (zero? d) + (let ((v (round (/ n d)))) + (cons v (loop (- n v) + (1- d)))))))) + (string-concatenate/shared + (merge words (map (lambda (n) (make-string n #\space)) + space-list) + (let ((f #t)) (lambda _ (mod/r! f not))))))) + + + +;; Splits and justifies the given line to @var{#:width}. +;; Returns a list of justified strings. +;; str -> (str) +(define* (justify-line line #:key (width 70)) + (let recur ((lst (words line))) + (let* ((head tail (span + (let ((w 0)) + (lambda (word) ; Take words until we are above the limit. + (< (mod/r! w = (+ 1 (true-string-length word))) + width))) + lst))) + (cond ((null? tail) (list (unwords head))) ; Don't justify last line. + ((null? head) + ;; an empty head implies that we found a word longer + ;; than our max width. Add it as is and continue + ;; (while crying). + (cons (car tail) (recur (cdr tail)))) + (else (cons (justify-line-helper head #:width width) + (recur tail))))))) + +;; str -> (str) +(define*-public (flow-text str #:key (width 70)) + (flatten + (map (lambda (line) (justify-line line #:width width)) + (lines str)))) diff --git a/module/text/markup.scm b/module/text/markup.scm new file mode 100644 index 00000000..62b6ebe4 --- /dev/null +++ b/module/text/markup.scm @@ -0,0 +1,117 @@ +(define-module (text markup) + :use-module (util) + :use-module (srfi srfi-1) + :use-module (ice-9 match) + :use-module (ice-9 pretty-print) + :use-module (text util) + :use-module (text flow) + :use-module (texinfo string-utils)) + + +(define (esc . effect) + (format #f "\x1b[~am" + (if (null? effect) + "" + (case (car effect) + [(bold) 1] + [(italic) 3] + [(invert) 7] + [else 4])))) + + +(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)) + +;; 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 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)) diff --git a/module/output/text.scm b/module/text/numbers.scm index 4697b70a..c590c188 100644 --- a/module/output/text.scm +++ b/module/text/numbers.scm @@ -1,89 +1,5 @@ -(define-module (output text) - #:use-module (srfi srfi-1) - #:use-module (util) - #:export (justify-line flow-text)) - -(define-public (words str) (string-split str #\space)) -(define-public (unwords list) (string-join list " " 'infix)) - -(define-public (lines str) (string-split str #\newline)) -(define-public (unlines list) (string-join list "\n" 'infix)) - -;; Alternative string-length whith counts ANSI escapes as 0-length. -;; NOTE Some way to opt in and out of different features would be nice. -(define (true-string-length word) - (let loop ((chars (string->list word))) - (if (null? chars) - 0 - (let ((char (car chars))) - (if (eqv? #\escape char) - (loop (cdr (memv #\m chars))) - (1+ (loop (cdr chars)))))))) - - -;; (str) -> str -(define* (justify-line-helper words #:key (width 70)) - (let* ((phrase-length (true-string-length (string-concatenate/shared words))) - (needed-spaces (- width phrase-length)) - (slots (1- (length words))) - (space-list - (let loop ((n needed-spaces) (d slots)) - (unless (zero? d) - (let ((v (round (/ n d)))) - (cons v (loop (- n v) - (1- d)))))))) - (string-concatenate/shared - (merge words (map (lambda (n) (make-string n #\space)) - space-list) - (let ((f #t)) (lambda _ (mod/r! f not))))))) - - - -;; Splits and justifies the given line to @var{#:width}. -;; Returns a list of justified strings. -;; str -> (str) -(define* (justify-line line #:key (width 70)) - (let recur ((lst (words line))) - (let* ((head tail (span - (let ((w 0)) - (lambda (word) ; Take words until we are above the limit. - (< (mod/r! w = (+ 1 (true-string-length word))) - width))) - lst))) - (cond ((null? tail) (list (unwords head))) ; Don't justify last line. - ((null? head) - ;; an empty head implies that we found a word longer - ;; than our max width. Add it as is and continue - ;; (while crying). - (cons (car tail) (recur (cdr tail)))) - (else (cons (justify-line-helper head #:width width) - (recur tail))))))) - -;; str -> (str) -(define* (flow-text str #:key (width 70)) - (flatten - (map (lambda (line) (justify-line line #:width width)) - (lines str)))) - -(define-public (trim-to-width str len) - (let ((trimmed (string-pad-right str len))) - (if (< (string-length trimmed) - (string-length str)) - (string-append (string-drop-right trimmed 1) - "…") - trimmed))) - - - -;; TODO more options for infix strings -(define*-public (add-enumeration-punctuation - list optional: (final-delim "&")) - (cond [(null? list) ""] - [(= 1 (length list)) (car list)] - [else - (let* (((tail . rest) (reverse list))) - (reverse (cons* tail " " final-delim " " - (intersperce ", " rest))))])) +(define-module (text numbers) + :use-module (util)) ;; only used in number->string-cardinal (define (large-prefix e) diff --git a/module/text/util.scm b/module/text/util.scm new file mode 100644 index 00000000..eda2df98 --- /dev/null +++ b/module/text/util.scm @@ -0,0 +1,45 @@ +(define-module (text util) + :use-module (util)) + +(define-public (words str) (string-split str #\space)) +(define-public (unwords list) (string-join list " " 'infix)) + +(define-public (lines str) (string-split str #\newline)) +(define-public (unlines list) (string-join list "\n" 'infix)) + +;; Alternative string-length whith counts ANSI escapes as 0-length. +;; NOTE Some way to opt in and out of different features would be nice. +(define-public (true-string-length word) + (let loop ((chars (string->list word))) + (if (null? chars) + 0 + (let ((char (car chars))) + (if (eqv? #\escape char) + (loop (cdr (memv #\m chars))) + (1+ (loop (cdr chars)))))))) + +(define*-public (true-string-pad str len optional: (chr #\space)) + (let ((strlen (true-string-length str))) + (if (> strlen len) + str + (string-append (make-string (- len strlen) chr) + str)))) + + +(define-public (trim-to-width str len) + (let ((trimmed (string-pad-right str len))) + (if (< (string-length trimmed) + (string-length str)) + (string-append (string-drop-right trimmed 1) + "…") + trimmed))) + +;; TODO more options for infix strings +(define*-public (add-enumeration-punctuation + list optional: (final-delim "&")) + (cond [(null? list) ""] + [(= 1 (length list)) (car list)] + [else + (let* (((tail . rest) (reverse list))) + (reverse (cons* tail " " final-delim " " + (intersperce ", " rest))))])) |