diff options
Diffstat (limited to 'module/hnh/util')
-rw-r--r-- | module/hnh/util/exceptions.scm | 17 | ||||
-rw-r--r-- | module/hnh/util/graph.scm | 35 | ||||
-rw-r--r-- | module/hnh/util/io.scm | 14 | ||||
-rw-r--r-- | module/hnh/util/options.scm | 11 | ||||
-rw-r--r-- | module/hnh/util/path.scm | 21 |
5 files changed, 62 insertions, 36 deletions
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 <graph> @@ -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" |