aboutsummaryrefslogtreecommitdiff
path: root/module/hnh
diff options
context:
space:
mode:
Diffstat (limited to 'module/hnh')
-rw-r--r--module/hnh/module-introspection.scm22
-rw-r--r--module/hnh/module-introspection/all-modules.scm55
-rw-r--r--module/hnh/module-introspection/module-uses.scm116
-rw-r--r--module/hnh/module-introspection/static-util.scm9
-rw-r--r--module/hnh/test/testrunner.scm126
-rw-r--r--module/hnh/test/util.scm57
-rw-r--r--module/hnh/test/xmllint.scm27
-rw-r--r--module/hnh/util.scm55
-rw-r--r--module/hnh/util/env.scm13
-rw-r--r--module/hnh/util/io.scm20
-rw-r--r--module/hnh/util/path.scm35
-rw-r--r--module/hnh/util/state-monad.scm120
-rw-r--r--module/hnh/util/uuid.scm14
13 files changed, 651 insertions, 18 deletions
diff --git a/module/hnh/module-introspection.scm b/module/hnh/module-introspection.scm
new file mode 100644
index 00000000..83e561f1
--- /dev/null
+++ b/module/hnh/module-introspection.scm
@@ -0,0 +1,22 @@
+(define-module (hnh module-introspection)
+ :use-module (srfi srfi-1)
+ :use-module (hnh util)
+ :export (unique-symbols
+ find-module-declaration
+ module-declaration?
+ ))
+
+
+(define (unique-symbols tree)
+ (uniq
+ (sort* (filter symbol? (flatten tree))
+ string<? symbol->string)))
+
+(define (module-declaration? form)
+ (cond ((null? form) #f)
+ ((not (pair? form)) #f)
+ (else (eq? 'define-module (car form)))))
+
+(define (find-module-declaration forms)
+ (and=> (find module-declaration? forms)
+ cadr))
diff --git a/module/hnh/module-introspection/all-modules.scm b/module/hnh/module-introspection/all-modules.scm
new file mode 100644
index 00000000..1bf39e1e
--- /dev/null
+++ b/module/hnh/module-introspection/all-modules.scm
@@ -0,0 +1,55 @@
+(define-module (hnh module-introspection all-modules)
+ :use-module (ice-9 regex)
+ :use-module (srfi srfi-1)
+ :use-module (ice-9 ftw)
+ :use-module (ice-9 match)
+ :use-module (hnh util path)
+ :use-module (hnh module-introspection)
+ :use-module ((hnh module-introspection static-util) :select (get-forms))
+ :export (all-files-and-modules-under-directory
+ all-modules-under-directory
+ fs-find-base fs-find
+ module-file-mapping
+ ))
+
+(define (fs-find dir)
+ (define files '())
+ (ftw dir (lambda args (set! files (cons args files)) #t))
+ files)
+
+;; (define (fs-find proc dir)
+;; (filter proc (fs-find-base dir)))
+
+(define (all-files-and-modules-under-directory dir)
+ (define re (make-regexp "\\.scm$"))
+
+ (define files
+ (map car
+ (filter (match-lambda ((filename _ 'regular)
+ (and (regexp-exec re filename)
+ (not (file-hidden? filename))))
+ (_ #f))
+ (fs-find dir))))
+
+ (map (lambda (file)
+ (list file
+ (call-with-input-file file
+ (compose find-module-declaration get-forms))))
+ files))
+
+(define (all-modules-under-directory dir)
+ "Returns two values, all scm files in dir, and all top
+level modules in those files"
+
+ (define pairs (all-files-and-modules-under-directory dir))
+ (values
+ (map car pairs)
+ (filter identity (map cadr pairs))))
+
+;; Returns an association list from module names the modules
+;; containing filename
+(define (module-file-mapping dir)
+ (filter
+ car
+ (map (lambda (pair) (cons (cadr pair) (car pair)))
+ (all-files-and-modules-under-directory dir))))
diff --git a/module/hnh/module-introspection/module-uses.scm b/module/hnh/module-introspection/module-uses.scm
new file mode 100644
index 00000000..3bed2a5e
--- /dev/null
+++ b/module/hnh/module-introspection/module-uses.scm
@@ -0,0 +1,116 @@
+(define-module (hnh module-introspection module-uses)
+ :use-module (ice-9 match)
+ :use-module (hnh util)
+ :use-module ((srfi srfi-1) :select (concatenate))
+ :use-module ((srfi srfi-88) :select (string->keyword))
+ :use-module (rnrs records syntactic)
+ :export (module-uses*))
+
+;;; Commentary:
+;;; Static analyze version of guile's built in module-uses.
+;;; Will give a less accurate result, but in turn doesn't
+;;; require that the target module compiles.
+;;; Code:
+
+(define-record-type (module make-module% module?)
+ (fields name select hide prefix renamer version))
+
+(define* (make-module name key:
+ (select #f)
+ (hide '())
+ (prefix #f)
+ (renamer #f)
+ (version #f))
+ (make-module% name select hide prefix renamer version))
+
+(define (module->list module)
+ (append
+ (list (module-name module))
+ (awhen (module-select module) `(#:select ,it))
+ (awhen (module-hide module) `(#:hide ,it))
+ (awhen (module-prefix module) `(#:prefix ,it))
+ (awhen (module-renamer module) `(#:renamer ,it))
+ (awhen (module-version module) `(#:version ,it))))
+
+;; Normalizes keywords (#:key) and pseudo keywords (:key) used by define-module syntax.
+(define (normalize-keyword kw-or-symb)
+ (cond ((symbol? kw-or-symb)
+ (-> (symbol->string kw-or-symb)
+ (string-drop 1)
+ string->keyword))
+ ((keyword? kw-or-symb)
+ kw-or-symb)
+ (else (error "Bad keyword like" kw-or-symb))))
+
+;; Takes one argument as taken by @code{use-modules}, or following #:use-module
+;; in @code{define-module}.
+;; returns a list on the form
+;; (module-name (key value) ...)
+;; where module name is something like (srfi srfi-1)
+(define (parse-interface-specification interface-specification)
+ (match interface-specification
+ ;; matches `((srfi srfi-1) :select (something))
+ (((parts ...) args ...)
+ (apply make-module
+ `(,parts ,@(concatenate
+ (map (lambda (pair)
+ (cons (normalize-keyword (car pair))
+ (cdr pair)))
+ (group args 2))))))
+ ;; matches `(srfi srfi-1)
+ ((parts ...)
+ (make-module parts))
+ (_ (error "Bad module declaration"))))
+
+;; Finds all define-module forms, and returns what they
+;; pull in (including autoloads)
+(define (module-declaration-uses forms)
+ (match forms
+ (('define-module module-name directives ...)
+ (let loop ((directives directives))
+ (cond ((null? directives) '())
+ ((memv (car directives) '(#:use-module #{:use-module}#))
+ (cons (parse-interface-specification (cadr directives))
+ (loop (cddr directives))))
+ ((memv (car directives) '(#:autoload #{:autoload}#))
+ (cons (cadr directives)
+ (loop (cdddr directives))))
+ (else (loop (cdr directives))))))
+ ((form forms ...)
+ (append (module-declaration-uses form)
+ (module-declaration-uses forms)))
+ (_ '())))
+
+;; find all use-modules forms, and return what they pull in
+;; NOTE this will pull in all forms looking like a (use-modules ...)
+;; form, even if they are quoted, or in a cond-expand
+(define (module-use-module-uses forms)
+ (match forms
+ (('use-modules modules ...)
+ (map parse-interface-specification modules))
+ ((form forms ...)
+ (append (module-use-module-uses form)
+ (module-use-module-uses forms)))
+ (_ '())))
+
+;; find all explicit module references (e.g.
+;; (@ (module) var) and (@@ (module) private-var)),
+;; and return those modules
+(define (module-refer-uses forms)
+ (match forms
+ (((or '@ '@@) module symb)
+ (list (make-module module select: (list symb))))
+ ((form forms ...)
+ (append (module-refer-uses form)
+ (module-refer-uses forms)))
+ (_ '())))
+
+;; List of all modules pulled in in any of forms
+;; Returns a list where each element suitable to have
+;; resolve-interface applied to it.
+(define (module-uses* forms)
+ (map module->list
+ (append
+ (module-declaration-uses forms)
+ (module-use-module-uses forms)
+ (module-refer-uses forms))))
diff --git a/module/hnh/module-introspection/static-util.scm b/module/hnh/module-introspection/static-util.scm
new file mode 100644
index 00000000..7593ce3c
--- /dev/null
+++ b/module/hnh/module-introspection/static-util.scm
@@ -0,0 +1,9 @@
+(define-module (hnh module-introspection static-util)
+ :export (get-forms))
+
+(define (get-forms port)
+ (let loop ((done '()))
+ (let ((form (read port)))
+ (if (eof-object? form)
+ done
+ (loop (cons form done))))))
diff --git a/module/hnh/test/testrunner.scm b/module/hnh/test/testrunner.scm
new file mode 100644
index 00000000..384afd4b
--- /dev/null
+++ b/module/hnh/test/testrunner.scm
@@ -0,0 +1,126 @@
+(define-module (hnh test testrunner)
+ :use-module (srfi srfi-64)
+ :use-module (hnh test util)
+ :use-module (ice-9 pretty-print)
+ :use-module (ice-9 format)
+ :export (verbose? construct-test-runner)
+ )
+
+(define verbose? (make-parameter #f))
+
+(define (pp form indent prefix-1)
+ (let ((prefix (make-string (+ (string-length indent)
+ (string-length prefix-1))
+ #\space)))
+ (string-replace-head
+ (with-output-to-string
+ (lambda () (pretty-print
+ form
+ display?: #t
+ per-line-prefix: prefix
+ width: (- 79 (string-length indent)))))
+ (string-append indent prefix-1))))
+
+
+(define (construct-test-runner)
+ (define runner (test-runner-null))
+ (define depth 0)
+ ;; end of individual test case
+ (test-runner-on-test-begin! runner
+ (lambda (runner)
+ (test-runner-aux-value! runner (transform-time-of-day (gettimeofday)))))
+ (test-runner-on-test-end! runner
+ (lambda (runner)
+ (when (verbose?) (display (make-indent depth)))
+ (case (test-result-kind runner)
+ ((pass) (display (green "X")))
+ ((fail) (display (red "E")))
+ ((xpass) (display (yellow "X")))
+ ((xfail) (display (yellow "E")))
+ ((skip) (display (yellow "-"))))
+ (when (or (verbose?) (eq? 'fail (test-result-kind)))
+ (format #t " ~a~%"
+ (cond ((test-runner-test-name runner)
+ (negate string-null?) => identity)
+ ((test-result-ref runner 'expected-value)
+ => (lambda (p) (with-output-to-string
+ (lambda ()
+ (display (bold "[SOURCE]: "))
+ (truncated-print p width: 60))))))))
+ (when (eq? 'fail (test-result-kind))
+ (cond ((test-result-ref runner 'actual-error)
+ => (lambda (err)
+ (if (and (list? err)
+ (= 5 (length err)))
+ (let ((err (list-ref err 0))
+ (proc (list-ref err 1))
+ (fmt (list-ref err 2))
+ (args (list-ref err 3)))
+ (format #t "~a~a in ~a: ~?~%"
+ (make-indent (1+ depth))
+ err proc fmt args))
+ (format #t "~aError: ~s~%" (make-indent (1+ depth)) err))))
+ (else
+ (let ((unknown-expected (gensym))
+ (unknown-actual (gensym)))
+ (let ((expected (test-result-ref runner 'expected-value unknown-expected))
+ (actual (test-result-ref runner 'actual-value unknown-actual)))
+ (let ((indent (make-indent (1+ depth))))
+ (if (eq? expected unknown-expected)
+ (format #t "~aAssertion failed~%" indent)
+ (begin
+ (display (pp expected indent "Expected: "))
+ (display (pp actual indent "Received: "))
+ (let ((d (diff (pp expected "" "")
+ (pp actual "" ""))))
+ (display
+ (string-join
+ (map (lambda (line) (string-append indent "|" line))
+ (string-split d #\newline))
+ "\n" 'suffix))))))))))
+ (format #t "~aNear ~a:~a~%"
+ (make-indent (1+ depth))
+ (test-result-ref runner 'source-file)
+ (test-result-ref runner 'source-line))
+ (pretty-print (test-result-ref runner 'source-form)
+ (current-output-port)
+ per-line-prefix: (string-append (make-indent (1+ depth)) "> ")
+ ))
+
+ (let ((start (test-runner-aux-value runner))
+ (end (transform-time-of-day (gettimeofday))))
+ (when (< (µs 1) (- end start))
+ (format #t "~%Slow test: ~s, took ~a~%"
+ (test-runner-test-name runner)
+ (exact->inexact (/ (- end start) (µs 1)))
+ )))))
+
+ ;; on start of group
+ (test-runner-on-group-begin! runner
+ ;; count is number of #f
+ (lambda (runner name count)
+ (if (<= depth 1)
+ (format #t "~a ~a ~a~%"
+ (make-string 10 #\=)
+ name
+ (make-string 10 #\=))
+ (when (verbose?)
+ (format #t "~a~a~%" (make-string (* depth 2) #\space) name)))
+ (set! depth (1+ depth))))
+ (test-runner-on-group-end! runner
+ (lambda (runner)
+ (set! depth (1- depth))
+ (when (<= depth 1)
+ (newline))))
+ ;; after everything else is done
+ (test-runner-on-final! runner
+ (lambda (runner)
+ (format #t "Guile version ~a~%~%" (version))
+ (format #t "pass: ~a~%" (test-runner-pass-count runner))
+ (format #t "fail: ~a~%" (test-runner-fail-count runner))
+ (format #t "xpass: ~a~%" (test-runner-xpass-count runner))
+ (format #t "xfail: ~a~%" (test-runner-xfail-count runner))
+ ))
+
+ runner)
+
diff --git a/module/hnh/test/util.scm b/module/hnh/test/util.scm
new file mode 100644
index 00000000..3d51e162
--- /dev/null
+++ b/module/hnh/test/util.scm
@@ -0,0 +1,57 @@
+(define-module (hnh test util)
+ :use-module ((hnh util) :select (begin1))
+ :use-module ((hnh util io) :select (call-with-tmpfile))
+ :use-module (ice-9 pretty-print)
+ :use-module ((ice-9 rdelim) :select (read-string))
+ :use-module ((ice-9 popen)
+ :select (open-pipe*
+ close-pipe))
+ :export (µs
+ transform-time-of-day
+ green
+ red
+ yellow
+ bold
+ make-indent
+ string-replace-head
+ diff
+ ))
+
+(define (µs x)
+ (* x #e1e6))
+
+(define (transform-time-of-day tod)
+ (+ (* (µs 1) (car tod))
+ (cdr tod)))
+
+(define (escaped sequence string)
+ (format #f "\x1b[~am~a\x1b[m" sequence string))
+
+;; Terminal output formatting. Doesn NOT compose
+(define (green s) (escaped 32 s))
+(define (red s) (escaped 31 s))
+(define (yellow s) (escaped 33 s))
+(define (bold s) (escaped 1 s))
+
+(define (make-indent depth)
+ (make-string (* 2 depth) #\space))
+
+(define (string-replace-head s1 s2)
+ (string-replace s1 s2
+ 0 (string-length s2)))
+
+
+(define diff-cmd
+ ;; '("diff")
+ '("git" "diff" "--no-index" "--color-moved=default" "--color=always"; "--word-diff=color"
+ )
+ )
+
+(define (diff s1 s2)
+ (let ((filename1 (call-with-tmpfile (lambda (p f) (pretty-print s1 p display?: #t) f)))
+ (filename2 (call-with-tmpfile (lambda (p f) (pretty-print s2 p display?: #t) f))))
+ (let ((pipe (apply open-pipe*
+ OPEN_READ
+ (append diff-cmd (list filename1 filename2)))))
+ (begin1 (read-string pipe)
+ (close-pipe pipe)))))
diff --git a/module/hnh/test/xmllint.scm b/module/hnh/test/xmllint.scm
new file mode 100644
index 00000000..95362607
--- /dev/null
+++ b/module/hnh/test/xmllint.scm
@@ -0,0 +1,27 @@
+(define-module (hnh test xmllint)
+ :use-module (srfi srfi-1)
+ :use-module (srfi srfi-71)
+ :use-module (srfi srfi-88)
+ :use-module ((rnrs io ports) :select (get-string-all))
+ :use-module ((hnh util) :select (begin1))
+ :export (xmllint)
+ )
+
+
+(define (xmllint str)
+ (let ((in* out (car+cdr (pipe)))
+ (in out* (car+cdr (pipe)))
+ (cmdline (string-split "xmllint --format -" #\space)))
+ (define pid
+ (spawn (car cmdline) cmdline
+ input: in*
+ output: out*))
+ (close-port in*)
+ (close-port out*)
+
+ (display str out)
+ (force-output out)
+ (close-port out)
+
+ (begin1 (get-string-all in)
+ (close-port in))))
diff --git a/module/hnh/util.scm b/module/hnh/util.scm
index d2c0dd5f..c88a029e 100644
--- a/module/hnh/util.scm
+++ b/module/hnh/util.scm
@@ -17,6 +17,7 @@
find-extreme find-min find-max
filter-sorted
!=
+ init+last
take-to
string-take-to
string-first
@@ -55,6 +56,12 @@
assq-ref-all
assv-ref-all
+ uniqx
+ uniq
+ univ
+ uniqv
+ unique
+
vector-last
->string
@@ -64,6 +71,10 @@
:replace (set! define-syntax
when unless))
+(cond-expand
+ (guile-3 (use-modules ((ice-9 copy-tree) :select (copy-tree))))
+ (else))
+
((@ (guile) define-syntax) define-syntax
(syntax-rules ()
((_ (name args ...) body ...)
@@ -112,6 +123,9 @@
((for (<var> <vars> ...) in <collection> b1 body ...)
(map ((@ (ice-9 match) match-lambda) [(<var> <vars> ...) b1 body ...])
<collection>))
+ ((for (<var> <vars> ... . <tail>) in <collection> b1 body ...)
+ (map ((@ (ice-9 match) match-lambda) [(<var> <vars> ... . <tail>) b1 body ...])
+ <collection>))
((for <var> in <collection> b1 body ...)
(map (lambda (<var>) b1 body ...)
<collection>))))
@@ -137,9 +151,12 @@
+;; TODO this is called flip in Haskell land
(define (swap f)
(lambda args (apply f (reverse args))))
-
+;; Swap would be
+;; (define (swap p)
+;; (xcons (car p) (cdr p)))
;; Allow set to work on multiple values at once,
;; similar to Common Lisp's @var{setf}
@@ -240,6 +257,12 @@
;; (define (!= a b) (not (= a b)))
(define != (negate =))
+
+(define (init+last l)
+ (let ((last rest (car+cdr (reverse l))))
+ (values (reverse rest) last)))
+
+
(define (take-to lst i)
"Like @var{take}, but might lists shorter than length."
(if (> i (length lst))
@@ -307,7 +330,8 @@
(define (kvlist->assq kvlist)
(map (lambda (pair)
- (cons (keyword->symbol (car pair)) (cdr pair)))
+ (cons (keyword->symbol (car pair))
+ (cadr pair)))
(group kvlist 2)))
(define* (assq-limit alist optional: (number 1))
@@ -320,8 +344,7 @@
(for value in lst
(let ((key (proc value)))
(hash-set! h key (cons value (hash-ref h key '())))))
- ;; NOTE changing this list to cons allows the output to work with assq-merge.
- (hash-map->list list h)))
+ (hash-map->list cons h)))
;; (split-by '(0 1 2 3 4 2 5 6) 2)
;; ⇒ ((0 1) (3 4) (5 6))
@@ -383,7 +406,7 @@
(reverse (cons (map list last) rest ))))))
;; Given an arbitary tree, do a pre-order traversal, appending all strings.
-;; non-strings allso allowed, converted to strings and also appended.
+;; non-strings also allowed, converted to strings and also appended.
(define (string-flatten tree)
(cond [(string? tree) tree]
[(list? tree) (string-concatenate (map string-flatten tree))]
@@ -506,6 +529,19 @@
(define (assv-ref-all alist key) (ass%-ref-all alist key eqv?))
+(define (uniqx = lst)
+ (cond ((null? lst) lst)
+ ((null? (cdr lst)) lst)
+ ((and (pair? lst)
+ (= (car lst) (cadr lst)))
+ (uniqx = (cons (car lst) (cddr lst))))
+ (else (cons (car lst)
+ (uniqx = (cdr lst))))))
+
+(define (uniq lst) (uniqx eq? lst))
+(define (univ lst) (uniqx eqv? lst))
+(define (unique lst) (uniqx equal? lst))
+
(define (vector-last v)
@@ -517,9 +553,12 @@
(define-syntax catch*
- (syntax-rules ()
+ (syntax-rules (pre-unwind)
+ ((_ thunk ((pre-unwind key) handler))
+ (with-throw-handler (quote key) thunk handler))
((_ thunk (key handler))
(catch (quote key) thunk handler))
- ((_ thunk (key handler) rest ...)
- (catch* (lambda () (catch (quote key) thunk handler))
+
+ ((_ thunk pair rest ...)
+ (catch* (lambda () (catch* thunk pair))
rest ...))))
diff --git a/module/hnh/util/env.scm b/module/hnh/util/env.scm
index 18ec0543..32ea1cc1 100644
--- a/module/hnh/util/env.scm
+++ b/module/hnh/util/env.scm
@@ -1,5 +1,7 @@
(define-module (hnh util env)
- :export (let-env with-working-directory))
+ :export (let-env
+ with-working-directory
+ with-locale1))
(define-syntax let-env
(syntax-rules ()
@@ -33,3 +35,12 @@
thunk
(lambda () (chdir old-cwd)))))
+
+(define-syntax-rule (with-locale1 category locale thunk)
+ (let ((old #f))
+ (dynamic-wind
+ (lambda ()
+ (set! old (setlocale category))
+ (setlocale category locale))
+ thunk
+ (lambda () (setlocale category old)))))
diff --git a/module/hnh/util/io.scm b/module/hnh/util/io.scm
index d638ebb4..09900f8d 100644
--- a/module/hnh/util/io.scm
+++ b/module/hnh/util/io.scm
@@ -4,7 +4,9 @@
:export (open-input-port
open-output-port
read-lines
- with-atomic-output-to-file))
+ with-atomic-output-to-file
+ call-with-tmpfile
+ ->port))
(define (open-input-port str)
(if (string=? "-" str)
@@ -62,3 +64,19 @@
;; counted on, since anything with an unspecified return
;; value might as well return #f)
#f))))
+
+(define* (call-with-tmpfile proc key: (tmpl "/tmp/file-XXXXXXX"))
+ (let* ((filename (string-copy tmpl))
+ (port (mkstemp! filename)))
+ (with-continuation-barrier
+ (lambda ()
+ (begin1
+ (proc port filename)
+ (close-port port))))))
+
+(define (->port port-or-string)
+ (cond ((port? port-or-string) port-or-string)
+ ((string? port-or-string) (open-input-string port-or-string))
+ (else (scm-error 'misc-error "->port"
+ "Not a port or string"
+ (list port-or-string) #f))))
diff --git a/module/hnh/util/path.scm b/module/hnh/util/path.scm
index ea081e85..b0991073 100644
--- a/module/hnh/util/path.scm
+++ b/module/hnh/util/path.scm
@@ -3,15 +3,20 @@
:use-module (srfi srfi-71)
:use-module (hnh util)
:export (path-append
+ path-absolute?
path-join
path-split
file-hidden?
filename-extension
- realpath))
+ realpath
+ relative-to))
(define // file-name-separator-string)
(define /? file-name-separator?)
+(define path-absolute? absolute-file-name?)
+
+;; TODO remove intermidiate period components
(define (path-append . strings)
(fold (lambda (s done)
(string-append
@@ -87,3 +92,31 @@
(if (absolute-file-name? filename)
filename
(path-append (getcwd) filename)))
+
+
+(define (relative-to base path)
+ ;; (typecheck base string?)
+ ;; (typecheck path string?)
+
+ (when (string-null? base)
+ (error "Base can't be empty" ))
+
+ (let ((base (if (absolute-file-name? base)
+ base
+ (path-append (getcwd) base))))
+
+ (cond ((equal? '("") base) path)
+ ((not (absolute-file-name? path))
+ (path-append base path))
+ (else
+ (let loop ((a (path-split base))
+ (b (path-split path)))
+ (cond
+ ((null? a) (path-join b))
+ ((null? b) path)
+ ((string=? (car a) (car b)) (loop (cdr a) (cdr b)))
+ (else
+ (path-join
+ (append
+ (make-list (length a) "..")
+ (drop b (length a)))))))))))
diff --git a/module/hnh/util/state-monad.scm b/module/hnh/util/state-monad.scm
new file mode 100644
index 00000000..91201583
--- /dev/null
+++ b/module/hnh/util/state-monad.scm
@@ -0,0 +1,120 @@
+;;; Commentary:
+;;; A state monad similar to (and directly influenced by) the one found in in
+;;; Haskell
+;;; Each procedure can either explicitly take the state as a curried last
+;;; argument, or use the `do' notation, which handles that implicitly.
+;;; Each procedure MUST return two values, where the second value is the state
+;;; value which will be chained.
+;;;
+;;; Code borrowed from guile-dns
+;;; Code:
+
+(define-module (hnh util state-monad)
+ :use-module (ice-9 curried-definitions)
+ :replace (do mod)
+ :export (with-temp-state
+ <$> return get get* put put* sequence lift
+ eval-state exec-state))
+
+(define-syntax do
+ (syntax-rules (<- let =)
+ ((_ (a ...) <- b rest ...)
+ (lambda state-args
+ (call-with-values (lambda () (apply b state-args))
+ (lambda (a* . next-state)
+ (apply (lambda (a ...)
+ (apply (do rest ...)
+ next-state))
+ a*)))))
+ ((_ a <- b rest ...)
+ (lambda state-args
+ (call-with-values (lambda () (apply b state-args))
+ (lambda (a . next-state)
+ (apply (do rest ...)
+ next-state)))))
+
+ ((_ a = b rest ...)
+ (let ((a b))
+ (do rest ...)))
+
+ ((_ a)
+ (lambda state (apply a state)))
+ ((_ a rest ...)
+ (lambda state
+ (call-with-values (lambda () (apply a state))
+ (lambda (_ . next-state)
+ (apply (do rest ...)
+ next-state)))))))
+
+
+(define (with-temp-state state* op)
+ (do old <- (get*)
+ (apply put* state*)
+ ret-value <- op
+ (apply put* old)
+ (return ret-value)))
+
+
+(define (<$> f y)
+ (do tmp <- y
+ (return (f tmp))))
+
+(define ((return x) . y)
+ (apply values x y))
+
+(define ((get*) . state)
+ "Like @code{get}, but always returns a list"
+ (values state state))
+
+(define ((get) fst . state)
+ "If state contains a single variable return that, otherwise, return a list of all variables in state"
+ (if (null? state)
+ (values fst fst)
+ (apply values (cons fst state) fst state)))
+
+(define ((put . new-state) fst . old-state)
+ (if (null? old-state)
+ (apply values fst new-state)
+ (apply values (cons fst old-state) new-state)))
+
+;; Like put, but doesn't return anything (useful)
+(define ((put* . new-state) . _)
+ (apply values #f new-state))
+
+(define (mod proc)
+ (do
+ a <- (get)
+ (put (proc a))))
+
+;; ms must be a list of continuations
+(define (sequence ms)
+ (if (null? ms)
+ (return '())
+ (do
+ fst <- (car ms)
+ rest <- (sequence (cdr ms))
+ (return (cons fst rest)))))
+
+
+(define (lift proc . arguments)
+ (do xs <- (sequence arguments)
+ (return (apply proc xs))))
+
+
+;; Run state, returning value
+(define (eval-state st init)
+ (call-with-values
+ (lambda ()
+ (if (procedure? init)
+ (call-with-values init st)
+ (st init)))
+ (lambda (r . _) r)))
+
+;; Run state, returning state
+(define (exec-state st init)
+ (call-with-values
+ (lambda ()
+ (if (procedure? init)
+ (call-with-values init st)
+ (st init)))
+ (lambda (_ . v) (apply values v))))
diff --git a/module/hnh/util/uuid.scm b/module/hnh/util/uuid.scm
index 68455243..8e0434e3 100644
--- a/module/hnh/util/uuid.scm
+++ b/module/hnh/util/uuid.scm
@@ -1,19 +1,19 @@
(define-module (hnh util uuid)
:use-module (ice-9 format)
- :export (uuid uuid-v4))
+ :export (seed uuid uuid-v4))
-(define %seed (random-state-from-platform))
+(define seed (make-parameter (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)
+ (random (ash 1 (* 4 8)) (seed))
+ (random (ash 1 (* 4 4)) (seed))
(logior (ash version (* 4 3))
- (random (1- (ash 1 (* 4 3))) %seed))
+ (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)))
+ (random (ash 1 (+ 2 (* 4 3))) (seed)))
+ (random (ash 1 (* 4 12)) (seed))))
(define uuid uuid-v4)
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-03 15:03:05 +0200