aboutsummaryrefslogtreecommitdiff
path: root/module/hnh/util
diff options
context:
space:
mode:
Diffstat (limited to '')
-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
6 files changed, 239 insertions, 18 deletions
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-10 19:49:59 +0200