diff options
Diffstat (limited to 'module/hnh/util')
| -rw-r--r-- | module/hnh/util/exceptions.scm | 16 | ||||
| -rw-r--r-- | module/hnh/util/graph.scm | 9 | ||||
| -rw-r--r-- | module/hnh/util/io.scm | 28 | ||||
| -rw-r--r-- | module/hnh/util/path.scm | 31 | ||||
| -rw-r--r-- | module/hnh/util/uuid.scm | 19 |
5 files changed, 59 insertions, 44 deletions
diff --git a/module/hnh/util/exceptions.scm b/module/hnh/util/exceptions.scm index bcfd506d..eed310bb 100644 --- a/module/hnh/util/exceptions.scm +++ b/module/hnh/util/exceptions.scm @@ -6,7 +6,7 @@ #:use-module ((system vm frame) :select (frame-bindings binding-ref)) - #:export (assert)) + ) (define-public warning-handler @@ -31,20 +31,6 @@ (raise 2) ) -(define (prettify-tree tree) - (cond [(pair? tree) (cons (prettify-tree (car tree)) - (prettify-tree (cdr tree)))] - [(and (procedure? tree) (procedure-name tree)) - => identity] - [else tree])) - - -(define-macro (assert form) - `(unless ,form - (throw 'assertion-error "Assertion failed. ~a expected, ~a got" - (quote ,form) - ((@@ (calp util exceptions) prettify-tree) (list ,form))))) - (define-public (filter-stack pred? stk) (concatenate diff --git a/module/hnh/util/graph.scm b/module/hnh/util/graph.scm index 912f9612..03c2ae3c 100644 --- a/module/hnh/util/graph.scm +++ b/module/hnh/util/graph.scm @@ -73,8 +73,9 @@ (define-public (find-and-remove-node-without-dependencies graph) (let ((node (find-node-without-dependencies graph))) (unless node - (throw 'graph-error 'find-and-remove-node-without-dependencies - "No node without dependencies in graph" '() graph)) + (scm-error 'graph-error "find-and-remove-node-without-dependencies" + "No node without dependencies in graph" + #f (list graph))) (values node (remove-node graph node)))) ;; Assumes that the edges of the graph are dependencies. @@ -89,5 +90,5 @@ '() (let* ((node graph* (find-and-remove-node-without-dependencies graph))) (cons node (loop graph*)))))) - (lambda (err caller fmt args graph . data) - graph))) + (lambda (err caller fmt args data) + (car graph)))) diff --git a/module/hnh/util/io.scm b/module/hnh/util/io.scm index 161e09a0..3a595b67 100644 --- a/module/hnh/util/io.scm +++ b/module/hnh/util/io.scm @@ -1,4 +1,5 @@ (define-module (hnh util io) + :use-module ((hnh util) :select (begin1)) :use-module ((ice-9 rdelim) :select (read-line))) (define-public (open-input-port str) @@ -13,18 +14,18 @@ (define-public (read-lines port) - (with-input-from-port port - (lambda () - (let loop ((line (read-line))) - (if (eof-object? line) - '() (cons line (loop (read-line)))))))) + (let ((line (read-line port))) + (if (eof-object? line) + '() (cons line (read-lines port))))) ;; Same functionality as the regular @var{with-output-to-file}, but ;; with the difference that either everything is written, or nothing ;; is written, and if anything is written it's all written atomicaly at ;; once (the original file will never contain an intermidiate state). ;; Does NOT handle race conditions between threads. -;; Return #f on failure, something truthy otherwise +;; +;; 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) ;; copy to enusre writable string (define tmpfile (string-copy (string-append @@ -36,13 +37,14 @@ (dynamic-wind (lambda () (set! port (mkstemp! tmpfile))) (lambda () - (with-output-to-port port thunk) - ;; Closing a port forces a write, due to buffering - ;; some of the errors that logically would come - ;; from write calls are first raised here. But since - ;; crashing is acceptable here, that's fine. - (close-port port) - (rename-file tmpfile filename)) + (begin1 + (with-output-to-port port thunk) + ;; Closing a port forces a write, due to buffering + ;; some of the errors that logically would come + ;; from write calls are first raised here. But since + ;; crashing is acceptable here, that's fine. + (close-port port) + (rename-file tmpfile filename))) (lambda () (when (access? tmpfile F_OK) ;; I'm a bit unclear on how to trash our write buffer. diff --git a/module/hnh/util/path.scm b/module/hnh/util/path.scm index 7e40259a..28a026bc 100644 --- a/module/hnh/util/path.scm +++ b/module/hnh/util/path.scm @@ -2,31 +2,38 @@ :use-module (srfi srfi-1) :use-module (hnh util)) +(define // file-name-separator-string) +(define /? file-name-separator?) + (define-public (path-append . strings) (fold (lambda (s done) - (string-append - done - (if (string-null? s) - (string-append s file-name-separator-string) - (if (file-name-separator? (string-last done)) - (if (file-name-separator? (string-first s)) - (string-drop s 1) s) - (if (file-name-separator? (string-first s)) - s (string-append file-name-separator-string s)))))) + (string-append + done + (cond ((string-null? s) //) + ((and (/? (string-first s)) + (/? (string-last done))) + (string-drop s 1)) + ((or (/? (string-first s)) + (/? (string-last done))) + s) + (else (string-append // s))))) ;; If first component is empty, add a leading slash to make ;; the path absolute. This isn't exactly correct if we have ;; drive letters, but on those system the user should make ;; sure that the first component of the path is non-empty. (let ((s (car strings))) (if (string-null? s) - file-name-separator-string s)) - (cdr strings))) + // s)) + (cdr strings) + )) (define-public (path-join lst) (apply path-append lst)) ;; @example ;; (path-split "usr/lib/test") ;; ⇒ ("usr" "lib" "test") +;; (path-split "usr/lib/test/") +;; ⇒ ("usr" "lib" "test") ;; (path-split "/usr/lib/test") ;; ⇒ ("" "usr" "lib" "test") ;; (path-split "//usr////lib/test") @@ -38,7 +45,7 @@ (reverse (map reverse-list->string (fold (lambda (c done) - (if (file-name-separator? c) + (if (/? c) (cons '() done) (cons (cons c (car done)) (cdr done)))) '(()) diff --git a/module/hnh/util/uuid.scm b/module/hnh/util/uuid.scm new file mode 100644 index 00000000..68455243 --- /dev/null +++ b/module/hnh/util/uuid.scm @@ -0,0 +1,19 @@ +(define-module (hnh util uuid) + :use-module (ice-9 format) + :export (uuid uuid-v4)) + +(define %seed (random-state-from-platform)) + +(define (uuid-v4) + (define version 4) + (define variant #b10) + (format #f "~8'0x-~4'0x-~4'0x-~4'0x-~12'0x" + (random (ash 1 (* 4 8)) %seed) + (random (ash 1 (* 4 4)) %seed) + (logior (ash version (* 4 3)) + (random (1- (ash 1 (* 4 3))) %seed)) + (logior (ash variant (+ 2 (* 4 3))) + (random (ash 1 (+ 2 (* 4 3))) %seed)) + (random (ash 1 (* 4 12)) %seed))) + +(define uuid uuid-v4) |