From 1976980d4a272fb7fc3694c734bfc6825edfc721 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 23 Jun 2022 03:23:44 +0200 Subject: Centralize (almost) all exports to :export in define-module. --- module/hnh/util.scm | 142 +++++++++++++++++++++++++++-------------- module/hnh/util/exceptions.scm | 17 +++-- module/hnh/util/graph.scm | 35 ++++++---- module/hnh/util/io.scm | 14 ++-- module/hnh/util/options.scm | 11 ++-- module/hnh/util/path.scm | 21 +++--- 6 files changed, 156 insertions(+), 84 deletions(-) (limited to 'module/hnh') diff --git a/module/hnh/util.scm b/module/hnh/util.scm index 1fa3eb83..1e79781f 100644 --- a/module/hnh/util.scm +++ b/module/hnh/util.scm @@ -2,20 +2,66 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-71) #:use-module (srfi srfi-88) ; postfix keywords - #:use-module ((ice-9 optargs) #:select (define*-public)) #:use-module ((sxml fold) #:select (fold-values)) #:use-module ((srfi srfi-9 gnu) #:select (set-fields)) - #:re-export (define*-public fold-values) - #:export (for sort* sort*! - set/r! - -> ->> set set-> aif awhen - let-lazy - case* - and=>> label - print-and-return - begin1 - catch* - ) + #:re-export (fold-values) + #:export (aif + awhen + for + begin1 + print-and-return + swap + case* + set/r! + label + sort* sort*! + find-extreme find-min find-max + filter-sorted + != + take-to + string-take-to + string-first + string-last + as-symb + enumerate + unval + flatten + let-lazy + map/dotted + + assq-merge + kvlist->assq + assq-limit + + group-by + split-by + + span-upto + cross-product + + string-flatten + intersperse + insert-ordered + + -> ->> + set set-> + and=>> + + downcase-symbol + group + iterate + valued-map + + assoc-ref-all + assq-ref-all + assv-ref-all + + vector-last + + ->str ->string ->quoted-string + + catch* + ) #:replace (set! define-syntax when unless)) @@ -92,7 +138,7 @@ -(define-public (swap f) +(define (swap f) (lambda args (apply f (reverse args)))) @@ -183,7 +229,7 @@ ;; Returns 2 values. The extremest item in @var{items}, ;; and the other items in some order. ;; Ord b => (list a) [, (b, b -> bool), (a -> b)] -> a, (list a) -(define*-public (find-extreme items optional: (< <) (access identity)) +(define* (find-extreme items optional: (< <) (access identity)) (when (null? items) (scm-error 'wrong-type-arg "find-extreme" "Can't find extreme in an empty list" @@ -199,51 +245,51 @@ ;; seeds: (car items) '())) -(define*-public (find-min list optional: (access identity)) +(define* (find-min list optional: (access identity)) (find-extreme list < access)) -(define*-public (find-max list optional: (access identity)) +(define* (find-max list optional: (access identity)) (find-extreme list > access)) -(define-public (filter-sorted proc list) +(define (filter-sorted proc list) (take-while proc (drop-while (negate proc) list))) ;; (define (!= a b) (not (= a b))) -(define-public != (negate =)) +(define != (negate =)) -(define-public (take-to lst i) +(define (take-to lst i) "Like @var{take}, but might lists shorter than length." (if (> i (length lst)) lst (take lst i))) -(define-public (string-take-to str i) +(define (string-take-to str i) (if (> i (string-length str)) str (string-take str i))) -(define-public (string-first str) +(define (string-first str) (string-ref str 0)) -(define-public (string-last str) +(define (string-last str) (string-ref str (1- (string-length str)))) -(define-public (as-symb s) +(define (as-symb s) (if (string? s) (string->symbol s) s)) -(define-public (enumerate lst) +(define (enumerate lst) (zip (iota (length lst)) lst)) ;; Takes a procedure returning multiple values, and returns a procedure which ;; takes the same arguments as the original procedure, but only returns one of ;; the return values. Which value to return can be sent as an additional parameter. -(define*-public (unval proc #:optional (n 0)) +(define* (unval proc #:optional (n 0)) (lambda args (call-with-values (lambda () (apply proc args)) (lambda args (list-ref args n))))) -(define-public (flatten lst) +(define (flatten lst) (fold (lambda (subl done) (append done ((if (list? subl) flatten list) subl))) '() lst)) @@ -256,7 +302,7 @@ (let-syntax ((field (identifier-syntax (force field))) ...) body ...))])) -(define-public (map/dotted proc dotted-list) +(define (map/dotted proc dotted-list) (cond ((null? dotted-list) '()) ((not-pair? dotted-list) (proc dotted-list)) (else @@ -271,24 +317,24 @@ ;; (assq-merge '((k 1)) '((k 2))) ;; => ((k 2 1)) ;; @end example -(define-public (assq-merge a b) +(define (assq-merge a b) (fold (lambda (entry alist) (let* ((k v (car+cdr entry)) (o (assq-ref alist k))) (assq-set! alist k (append v (or o '()))))) (copy-tree a) b)) -(define-public (kvlist->assq kvlist) +(define (kvlist->assq kvlist) (map (lambda (pair) (cons (keyword->symbol (car pair)) (cdr pair))) (group kvlist 2))) -(define*-public (assq-limit alist optional: (number 1)) +(define* (assq-limit alist optional: (number 1)) (map (lambda (pair) (take-to pair (1+ number))) alist)) -(define-public (group-by proc lst) +(define (group-by proc lst) (let ((h (make-hash-table))) (for value in lst (let ((key (proc value))) @@ -298,7 +344,7 @@ ;; (split-by '(0 1 2 3 4 2 5 6) 2) ;; ⇒ ((0 1) (3 4) (5 6)) -(define-public (split-by list item) +(define (split-by list item) (let loop ((done '()) (current '()) (rem list)) @@ -325,7 +371,7 @@ ;; ⇒ () ;; ⇒ (#\H #\1 #\2 #\3 #\4 #\5 #\6) ;; @end example -(define-public (span-upto count predicate list) +(define (span-upto count predicate list) (let loop ((remaining count) (taken '()) (list list)) @@ -348,7 +394,7 @@ l2)) l1))) -(define-public (cross-product . args) +(define (cross-product . args) (if (null? args) '() (let ((last rest (car+cdr (reverse args)))) @@ -357,12 +403,12 @@ ;; Given an arbitary tree, do a pre-order traversal, appending all strings. ;; non-strings allso allowed, converted to strings and also appended. -(define-public (string-flatten tree) +(define (string-flatten tree) (cond [(string? tree) tree] [(list? tree) (string-concatenate (map string-flatten tree))] [else (format #f "~a" tree)])) -(define-public (intersperse item list) +(define (intersperse item list) (let loop ((flipflop #f) (rem list)) (if (null? rem) @@ -376,7 +422,7 @@ ;; (insert-ordered 5 (iota 10)) ;; ⇒ (0 1 2 3 4 5 5 6 7 8 9) ;; @end example -(define*-public (insert-ordered item collection optional: (< <)) +(define* (insert-ordered item collection optional: (< <)) (cond [(null? collection) (list item)] [(< item (car collection)) @@ -430,7 +476,7 @@ (and=>> (and=> value proc) rest ...)])) -(define-public (downcase-symbol symb) +(define (downcase-symbol symb) (-> symb symbol->string string-downcase @@ -442,7 +488,7 @@ ;; ⇒ ((0 1) (2 3) (4 5) (6 7) (8 9)) ;; @end example ;; Requires that width|(length list) -(define-public (group list width) +(define (group list width) (unless (null? list) (let ((row rest (split-at list width))) (cons row (group rest width))))) @@ -450,14 +496,14 @@ ;; repeatedly apply @var{proc} to @var{base} ;; unitl @var{until} is satisfied. ;; (a → a), (a → bool), a → a -(define-public (iterate proc until base) +(define (iterate proc until base) (let loop ((o base)) (if (until o) o (loop (proc o))))) ;; (a → values a), list ... → values a -(define-public (valued-map proc . lists) +(define (valued-map proc . lists) (apply values (apply append-map (lambda args @@ -474,22 +520,22 @@ ;; (assoc-ref-all '((a . 1) (b . 2) (a . 3)) 'a) ;; ⇒ (1 3) ;; @end -(define-public (assoc-ref-all alist key) (ass%-ref-all alist key equal?)) -(define-public (assq-ref-all alist key) (ass%-ref-all alist key eq?)) -(define-public (assv-ref-all alist key) (ass%-ref-all alist key eqv?)) +(define (assoc-ref-all alist key) (ass%-ref-all alist key equal?)) +(define (assq-ref-all alist key) (ass%-ref-all alist key eq?)) +(define (assv-ref-all alist key) (ass%-ref-all alist key eqv?)) -(define-public (vector-last v) +(define (vector-last v) (vector-ref v (1- (vector-length v)))) -(define-public (->str any) +(define (->str any) (with-output-to-string (lambda () (display any)))) -(define-public ->string ->str) +(define ->string ->str) -(define-public (->quoted-string any) +(define (->quoted-string any) (with-output-to-string (lambda () (write any)))) diff --git a/module/hnh/util/exceptions.scm b/module/hnh/util/exceptions.scm index eed310bb..36b018d1 100644 --- a/module/hnh/util/exceptions.scm +++ b/module/hnh/util/exceptions.scm @@ -6,33 +6,38 @@ #:use-module ((system vm frame) :select (frame-bindings binding-ref)) - ) + :export (warning-handler + warnings-are-errors + warning + fatal + filter-stack + )) -(define-public warning-handler +(define warning-handler (make-parameter (lambda (fmt . args) (format #f "WARNING: ~?~%" fmt args)))) -(define-public warnings-are-errors +(define warnings-are-errors (make-parameter #f)) ;; forwards return from warning-hander. By default returns an unspecified value, ;; but instances are free to provide a proper return value and use it. -(define-public (warning fmt . args) +(define (warning fmt . args) (display (apply (warning-handler) fmt (or args '())) (current-error-port)) (when (warnings-are-errors) (throw 'warning fmt args))) -(define-public (fatal fmt . args) +(define (fatal fmt . args) (display (format #f "FATAL: ~?~%" fmt (or args '())) (current-error-port)) (raise 2) ) -(define-public (filter-stack pred? stk) +(define (filter-stack pred? stk) (concatenate (for i in (iota (stack-length stk)) (filter pred? (map binding-ref (frame-bindings (stack-ref stk i))))))) diff --git a/module/hnh/util/graph.scm b/module/hnh/util/graph.scm index 01e9a63a..9aff7c77 100644 --- a/module/hnh/util/graph.scm +++ b/module/hnh/util/graph.scm @@ -8,7 +8,16 @@ :use-module (hnh util) :use-module (srfi srfi-1) :use-module (srfi srfi-71) - :use-module (srfi srfi-9 gnu)) + :use-module (srfi srfi-9 gnu) + :export (make-graph + rebuild-graph + graph-empty? + add-node + get-node + remove-node + find-node-without-dependencies + find-and-remove-node-without-dependencies + resolve-dependency-graph)) ;; Immutable directed graph (define-immutable-record-type @@ -20,23 +29,23 @@ (node-equal? node-equal?) ; node, node -> symb ) -(define*-public (make-graph optional: - (node-key-proc identity) - (node-equal? eq?)) +(define* (make-graph optional: + (node-key-proc identity) + (node-equal? eq?)) (make-graph% '() '() node-key-proc node-equal?)) -(define*-public (rebuild-graph optional: old-graph - (nodes '()) (edges '())) +(define* (rebuild-graph optional: old-graph + (nodes '()) (edges '())) (make-graph% nodes edges (if old-graph (node-key-proc old-graph) identity) (if old-graph (node-equal? old-graph) eq?))) -(define-public (graph-empty? graph) +(define (graph-empty? graph) (null? (graph-nodes graph))) ;; Add node to graph. Adds directed edges from node to neighbours ;; graph, node, (list node-key) → graph -(define-public (add-node graph node edge-neighbours) +(define (add-node graph node edge-neighbours) (rebuild-graph graph (lset-adjoin (node-equal? graph) (graph-nodes graph) @@ -46,12 +55,12 @@ edge-neighbours)))) ;; get node by key -(define-public (get-node graph key) +(define (get-node graph key) (find (lambda (node) (eq? key ((node-key-proc graph) node))) (graph-nodes graph))) ;; Remove node by @var{node-equal?} -(define-public (remove-node graph node) +(define (remove-node graph node) (rebuild-graph graph (remove (lambda (other) ((node-equal? graph) node other)) @@ -64,14 +73,14 @@ ;; NOTE this is O(n^2) (maybe, sort of?) ;; Getting it faster would require building an index, which ;; is hard since there isn't a total order on symbols. -(define-public (find-node-without-dependencies graph) +(define (find-node-without-dependencies graph) (find (lambda (node) (let ((key ((node-key-proc graph) node))) (not (find (lambda (edge) (eq? key (car edge))) (graph-edges graph))))) (graph-nodes graph))) ;; graph → node x graph -(define-public (find-and-remove-node-without-dependencies graph) +(define (find-and-remove-node-without-dependencies graph) (let ((node (find-node-without-dependencies graph))) (unless node (scm-error 'graph-error "find-and-remove-node-without-dependencies" @@ -83,7 +92,7 @@ ;; Returns a list of all nodes so that each node is before its dependants. ;; A missing dependency (and probably a loop) is an error, and currently ;; leads to some weird error messages. -(define-public (resolve-dependency-graph graph) +(define (resolve-dependency-graph graph) (catch 'graph-error (lambda () (let loop ((graph graph)) diff --git a/module/hnh/util/io.scm b/module/hnh/util/io.scm index 3a595b67..d638ebb4 100644 --- a/module/hnh/util/io.scm +++ b/module/hnh/util/io.scm @@ -1,19 +1,23 @@ (define-module (hnh util io) :use-module ((hnh util) :select (begin1)) - :use-module ((ice-9 rdelim) :select (read-line))) + :use-module ((ice-9 rdelim) :select (read-line)) + :export (open-input-port + open-output-port + read-lines + with-atomic-output-to-file)) -(define-public (open-input-port str) +(define (open-input-port str) (if (string=? "-" str) (current-input-port) (open-input-file str))) -(define-public (open-output-port str) +(define (open-output-port str) (if (string=? "-" str) (current-output-port) (open-output-file str))) -(define-public (read-lines port) +(define (read-lines port) (let ((line (read-line port))) (if (eof-object? line) '() (cons line (read-lines port))))) @@ -26,7 +30,7 @@ ;; ;; propagates the return value of @var{thunk} upon successfully writing ;; the file, and @code{#f} otherwise. -(define-public (with-atomic-output-to-file filename thunk) +(define (with-atomic-output-to-file filename thunk) ;; copy to enusre writable string (define tmpfile (string-copy (string-append (dirname filename) diff --git a/module/hnh/util/options.scm b/module/hnh/util/options.scm index 57473816..0faebf89 100644 --- a/module/hnh/util/options.scm +++ b/module/hnh/util/options.scm @@ -3,10 +3,13 @@ :use-module (ice-9 match) :use-module (srfi srfi-1) :use-module (text markup) - ) + :export (getopt-opt + format-arg-help + print-arg-help + )) ;; option-assoc → getopt-valid option-assoc -(define-public (getopt-opt options) +(define (getopt-opt options) (define ice-9-names '(single-char required? value predicate)) (for (option-name flags ...) in options (cons option-name @@ -38,8 +41,8 @@ `((blockquote ,@it) (br)))))))) -(define-public (format-arg-help options) +(define (format-arg-help options) (sxml->ansi-text (cons '*TOP* (map sxml->ansi-text (map fmt-help options))))) -(define*-public (print-arg-help options optional: (port (current-error-port))) +(define* (print-arg-help options optional: (port (current-error-port))) (display (format-arg-help options) port)) diff --git a/module/hnh/util/path.scm b/module/hnh/util/path.scm index 340c2d8b..ac6df491 100644 --- a/module/hnh/util/path.scm +++ b/module/hnh/util/path.scm @@ -1,12 +1,18 @@ (define-module (hnh util path) :use-module (srfi srfi-1) :use-module (srfi srfi-71) - :use-module (hnh util)) + :use-module (hnh util) + :export (path-append + path-join + path-split + file-hidden? + filename-extension + realpath)) (define // file-name-separator-string) (define /? file-name-separator?) -(define-public (path-append . strings) +(define (path-append . strings) (fold (lambda (s done) (string-append done @@ -28,7 +34,7 @@ (cdr strings) )) -(define-public (path-join lst) (apply path-append lst)) +(define (path-join lst) (apply path-append lst)) ;; @example ;; (path-split "usr/lib/test") @@ -40,7 +46,7 @@ ;; (path-split "//usr////lib/test") ;; ⇒ ("" "usr" "lib" "test") ;; @end example -(define-public (path-split path) +(define (path-split path) (let ((head tail (car+cdr (reverse @@ -54,16 +60,15 @@ (cons head (remove string-null? tail)))) -(define-public (file-hidden? path) +(define (file-hidden? path) (define base (basename path)) (and (not (string-null? base)) (char=? #\. (string-ref base 0)))) -(define-public (filename-extension filename) +(define (filename-extension filename) (car (reverse (string-split filename #\.)))) - -(define-public (realpath filename) +(define (realpath filename) (unless (string? filename) (scm-error 'wrong-type-arg "realpath" "filename not a string: ~a" -- cgit v1.2.3