diff options
Diffstat (limited to '')
-rw-r--r-- | module/entry-points/text.scm | 2 | ||||
-rw-r--r-- | module/main.scm | 2 | ||||
-rw-r--r-- | module/output/html.scm | 3 | ||||
-rw-r--r-- | module/output/terminal.scm | 1 | ||||
-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 | ||||
-rw-r--r-- | module/util/options.scm | 117 | ||||
-rw-r--r-- | module/vcomponent/recurrence/display.scm | 5 |
10 files changed, 224 insertions, 207 deletions
diff --git a/module/entry-points/text.scm b/module/entry-points/text.scm index 4a0dfb91..d6ebd72e 100644 --- a/module/entry-points/text.scm +++ b/module/entry-points/text.scm @@ -1,6 +1,6 @@ (define-module (entry-points text) :export (main) - :use-module (output text) + :use-module (text flow) :use-module (ice-9 getopt-long) :use-module (util io) :use-module (util options) diff --git a/module/main.scm b/module/main.scm index 3f5397ad..331268f8 100644 --- a/module/main.scm +++ b/module/main.scm @@ -27,6 +27,8 @@ ((entry-points server) :prefix server-) + (text markup) + (ice-9 getopt-long) (ice-9 regex) diff --git a/module/output/html.scm b/module/output/html.scm index 64d4e3df..00e4eacb 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -17,8 +17,7 @@ #:use-module (output general) #:use-module (ice-9 curried-definitions) #:use-module (ice-9 match) - #:use-module (output text) - + #:use-module (text util) #:use-module (git) ;; #:use-module (module config all) diff --git a/module/output/terminal.scm b/module/output/terminal.scm index 691dcde8..0146ea42 100644 --- a/module/output/terminal.scm +++ b/module/output/terminal.scm @@ -1,6 +1,5 @@ (define-module (output terminal) #:use-module (output general) - #:use-module (output text) #:use-module (srfi srfi-1) #:use-module (datetime) #:use-module (datetime util) 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))))])) 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))))) diff --git a/module/vcomponent/recurrence/display.scm b/module/vcomponent/recurrence/display.scm index c30a7344..dc9f61e8 100644 --- a/module/vcomponent/recurrence/display.scm +++ b/module/vcomponent/recurrence/display.scm @@ -6,9 +6,10 @@ ;;; Code: (define-module (vcomponent recurrence display) - :use-module (vcomponent recurrence internal) :use-module (util) - :use-module (output text) + :use-module (vcomponent recurrence internal) + :use-module (text util) + :use-module (text numbers) :use-module ((datetime) :select (time)) :use-module (datetime util) ) |