aboutsummaryrefslogtreecommitdiff
path: root/module/hnh
diff options
context:
space:
mode:
Diffstat (limited to 'module/hnh')
-rw-r--r--module/hnh/module-introspection/module-uses.scm2
-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.scm18
-rw-r--r--module/hnh/util/assert.scm9
-rw-r--r--module/hnh/util/env.scm13
-rw-r--r--module/hnh/util/io.scm10
-rw-r--r--module/hnh/util/lens.scm105
-rw-r--r--module/hnh/util/object.scm169
-rw-r--r--module/hnh/util/set.scm46
-rw-r--r--module/hnh/util/state-monad.scm120
-rw-r--r--module/hnh/util/table.scm108
-rw-r--r--module/hnh/util/type.scm46
14 files changed, 852 insertions, 4 deletions
diff --git a/module/hnh/module-introspection/module-uses.scm b/module/hnh/module-introspection/module-uses.scm
index b82aa6d0..3bed2a5e 100644
--- a/module/hnh/module-introspection/module-uses.scm
+++ b/module/hnh/module-introspection/module-uses.scm
@@ -82,6 +82,8 @@
(_ '())))
;; 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 ...)
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 91c081e2..9f71c1ec 100644
--- a/module/hnh/util.scm
+++ b/module/hnh/util.scm
@@ -18,6 +18,7 @@
find-extreme find-min find-max
filter-sorted
!=
+ init+last
take-to
string-take-to
string-first
@@ -70,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 ...)
@@ -179,9 +184,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}
@@ -282,6 +290,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))
@@ -425,7 +439,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))]
diff --git a/module/hnh/util/assert.scm b/module/hnh/util/assert.scm
new file mode 100644
index 00000000..74715654
--- /dev/null
+++ b/module/hnh/util/assert.scm
@@ -0,0 +1,9 @@
+(define-module (hnh util assert)
+ :use-module (rnrs base)
+ :export (assert*)
+ )
+
+(define-syntax assert*
+ (syntax-rules ()
+ ((_ assertion)
+ (assert assertion))))
diff --git a/module/hnh/util/env.scm b/module/hnh/util/env.scm
index bb42d966..f5992245 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 ()
@@ -37,3 +39,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 d73a1de8..09900f8d 100644
--- a/module/hnh/util/io.scm
+++ b/module/hnh/util/io.scm
@@ -5,7 +5,8 @@
open-output-port
read-lines
with-atomic-output-to-file
- call-with-tmpfile))
+ call-with-tmpfile
+ ->port))
(define (open-input-port str)
(if (string=? "-" str)
@@ -72,3 +73,10 @@
(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/lens.scm b/module/hnh/util/lens.scm
new file mode 100644
index 00000000..26c75be7
--- /dev/null
+++ b/module/hnh/util/lens.scm
@@ -0,0 +1,105 @@
+(define-module (hnh util lens)
+ :use-module (srfi srfi-1)
+ :export (modify
+ modify*
+ set
+ get
+
+ identity-lens
+ compose-lenses
+ lens-compose
+
+ ref car* cdr*
+
+ each))
+
+
+(define (modify object lens f . args)
+ (lens object (apply f (lens object) args)))
+
+(define-syntax modify*
+ (syntax-rules ()
+ ((_ object f) (f object))
+ ((_ object lens rest ...)
+ (modify object lens
+ (lambda (object*) (modify* object* rest ...))))))
+
+;; The simple case of getting and setting when you already have the lens is trivial
+;; (lens object)
+;; (lens object new-value)
+
+(define-syntax set
+ (syntax-rules ()
+ ((_ object lenses ... value)
+ (modify* object lenses ... (const value)))))
+
+(define-syntax get
+ (syntax-rules ()
+ ((_ object) object)
+ ((_ object f lenses ...)
+ (get (f object) lenses ...))))
+
+
+
+
+(define (make-lens getter setter)
+ (case-lambda ((datum) (getter datum))
+ ((datum new-value) (setter datum new-value))))
+
+(define-syntax build-lens
+ (syntax-rules ()
+ ((_ (getter gargs ...)
+ (setter sargs ...))
+ ;; (make-lens (lambda (datum) (getter datum gargs ...))
+ ;; (lambda (datum new-value) (setter datum sargs ... new-value)))
+ (case-lambda ((datum)
+ (getter datum gargs ...))
+ ((datum new-value)
+ (setter datum sargs ... new-value))))
+ ((_ (getter args ...) setter)
+ (build-accesor (getter args ...) (setter)))
+ ((_ getter (setter args ...))
+ (build-lens (getter) (setter args ...)))
+ ((_ getter setter)
+ (build-lens (getter) (setter)))))
+
+
+
+
+(define identity-lens
+ (case-lambda ((a) a)
+ ((_ a) a)))
+
+(define (compose-lenses% f g)
+ (build-lens (get f g) (set f g)))
+
+(define (compose-lenses . fs)
+ (reduce-right compose-lenses% identity-lens fs))
+
+(define lens-compose compose-lenses)
+
+
+
+(define (list-change list index value)
+ (cond ((zero? index)
+ (cons value (cdr list)))
+ ((null? list)
+ (scm-error 'out-of-range "list-change" "" #f #f))
+ (else
+ (cons (car list)
+ (list-change (cdr list)
+ (1- index)
+ value)))))
+
+
+
+(define (ref idx)
+ (build-lens (list-ref idx) (list-change idx)))
+
+
+(define car* (make-lens car (lambda (pair value) (cons value (cdr pair)))))
+(define cdr* (make-lens cdr (lambda (pair value) (cons (car pair) value))))
+
+(define (each obj lens proc)
+ (modify obj lens
+ (lambda (lst) (map proc lst))))
diff --git a/module/hnh/util/object.scm b/module/hnh/util/object.scm
new file mode 100644
index 00000000..4477b462
--- /dev/null
+++ b/module/hnh/util/object.scm
@@ -0,0 +1,169 @@
+(define-module (hnh util object)
+ :use-module (srfi srfi-9 gnu)
+ :use-module (ice-9 curried-definitions)
+ :use-module (hnh util)
+ :use-module (hnh util type)
+ :export (define-type))
+
+
+
+;; If given a syntax list extract the first lexeme, if given a "symbol", return that.
+(define (syntax-first stx)
+ (syntax-case stx ()
+ ((a rest ...) #'a)
+ (a #'a)))
+
+(define (construct-syntax stx base transform)
+ (->> base
+ syntax->datum
+ (format #f transform)
+ string->symbol
+ (datum->syntax stx)))
+
+;; stx should be a syntax object of a key-value list on the form
+;; (key: value key2: value2)
+;; and target-key the datum which the target key unwraps to.
+;; returns the corresponding values syntax
+;; or #f if none is found
+(define (kv-ref stx target-key)
+ (syntax-case stx ()
+ ((key value rest ...)
+ (if (eqv? target-key (syntax->datum #'key))
+ #'value
+ (kv-ref #'(rest ...) target-key)))
+ (_ #f)))
+
+
+
+;; Given (x type: predicate?), expand to a single `unless' form (otherwise #f)
+(define-syntax (validator stx)
+ (syntax-case stx ()
+ ((_ (name kvs ...))
+ (cond ((kv-ref #'(kvs ...) type:)
+ => (lambda (type-stx)
+ (with-syntax ((type type-stx))
+ #'(unless (build-validator-body name type)
+ (scm-error 'wrong-type-arg "validator"
+ "Invalid value for `~s'. Expected ~s, got ~s"
+ (list (quote name) (quote type) name) #f)))))
+ (else #f)))
+ ((_ name) #f)))
+
+
+
+
+;; Get syntax for getter-procedure's symbol
+(define-syntax (field-get stx)
+ (syntax-case stx ()
+ ;; ((_ (name kv ...)) #'(field-get name))
+ ((_ type-name name)
+ (->>
+ (format #f "~a-~a-get"
+ (syntax->datum #'type-name)
+ (syntax->datum #'name))
+ string->symbol
+ (datum->syntax stx)))))
+
+;; get syntax for setter-procedure's symbol
+(define-syntax (field-set stx)
+ (syntax-case stx ()
+ ;; ((_ (name kv ...)) #'(field-set name))
+ ((_ type-name name)
+ (->>
+ (format #f "~a-~a-set"
+ (syntax->datum #'type-name)
+ (syntax->datum #'name))
+ string->symbol
+ (datum->syntax stx)))))
+
+;; Construct a field line for define-immutable-record-type
+(define ((field-declaration type) stx)
+ (syntax-case stx ()
+ (name
+ (with-syntax ((name-get (->> (format #f "~a-~a-get"
+ (syntax->datum type)
+ (syntax->datum #'name))
+ string->symbol
+ (datum->syntax stx)))
+ (name-set (->> (format #f "~a-~a-set"
+ (syntax->datum type)
+ (syntax->datum #'name))
+ string->symbol
+ (datum->syntax stx))))
+ #'(name name-get name-set)))))
+
+;; Accessors are procedures for getting and setting fields in records
+(define-syntax (build-accessor stx)
+ (syntax-case stx ()
+ ((_ type-name (name kvs ...))
+ #'(define name
+ (case-lambda ((datum)
+ ((field-get type-name name) datum))
+ ((datum new-value)
+ ;; validator uses the first field (in the list) as both
+ ;; the name of the field, and a reference to the value of
+ ;; the field. This ensures those two are the same for validator,
+ ;; while keeping name bound to the accessor in the outer scope.
+ (let ((name new-value))
+ (validator (name kvs ...)))
+ ((field-set type-name name) datum new-value)))))
+ ((_ type-name name) #'(build-accessor type-name (name)))))
+
+
+;; Go from my concept of field deffinitions, to what lambda* wants as arguments
+(define (lambda*-stx field)
+ (syntax-case field ()
+ ((name kvs ...)
+ (cond ((kv-ref #'(kvs ...) default:)
+ => (lambda (dflt) #`(name #,dflt)))
+ (else #'name)))
+ (name #'name)))
+
+
+
+(define-syntax (define-type stx)
+ (syntax-case stx ()
+ ((_ (name attribute ...) field ...)
+ ;; These names SHOULD leak
+ (with-syntax ((<type>? (construct-syntax stx #'name "~a?")))
+ ;; These names are manually constructed, since generated identifiers are
+ ;; only dependant on the source from which they orginate, which leads to
+ ;; multiple instances of <type> being equal for similar types...
+ ;; See the manual 6.10.10 Hygiene and the Top-Level
+ (with-syntax ((<type> (construct-syntax stx #'name "<~a>"))
+ (make-<type> (construct-syntax stx #'name "make-~a%")))
+ #`(begin
+ (define-immutable-record-type <type>
+ (make-<type> #,@(map syntax-first #'(field ...)))
+ <type>?
+ #,@(map (field-declaration #'name)
+ (map syntax-first #'(field ...))))
+
+ ;; User-facing constructor
+ (define name
+ #,(cond ((kv-ref #'(attribute ...) constructor:)
+ => (lambda (constructor-builder)
+ #`(#,constructor-builder
+ ;; primitive constructor
+ make-<type>
+ ;; Type validator
+ (lambda #,(map syntax-first #'(field ...))
+ (validator field) ...))))
+ (else #`(lambda* (key: #,@(map lambda*-stx #'(field ...)))
+ ;; Type validators
+ (validator field) ...
+ (make-<type> #,@(map syntax-first #'(field ...)))))))
+
+ ;; Field accessors
+ (build-accessor name field) ...
+
+ ;; if printer in attribute
+ #,@(cond ((kv-ref #'(attribute ...) printer:)
+ => (lambda (printer)
+ (list #`(set-record-type-printer! <type> #,printer))))
+ (else '()))))))
+
+ ;; else, type name without extra attributes
+ #;
+ ((_ name field ...)
+ #'(define-type (name) field ...))))
diff --git a/module/hnh/util/set.scm b/module/hnh/util/set.scm
new file mode 100644
index 00000000..2839a231
--- /dev/null
+++ b/module/hnh/util/set.scm
@@ -0,0 +1,46 @@
+(define-module (hnh util set)
+ :use-module (hnh util object)
+ :use-module (hnh util table))
+
+(define-type (set)
+ (set-data default: (make-table)))
+
+(define (set-null) (set))
+
+(define (set-adjoin value set)
+ (modify set set-data tree-put value #t))
+
+(define (set-disjoin value set)
+ (modify set set-data tree-put value #f))
+
+(define (in-set? set value)
+ (catch 'out-of-range
+ (lambda () (tree-get (set-data set) value))
+ (lambda () #f)))
+
+(define (set-fold f done set)
+ (tree-fold (lambda (k v lst)
+ (if v
+ (f k done)
+ done))
+ done set))
+
+(define (set->list set)
+ (set-fold cons '() set))
+
+(define (set-union set1 set2)
+ (set-fold set-adjoin set1 set2))
+
+(define (set-intersection set1 set2)
+ (set-fold (lambda (v set)
+ (if (in-set? v set1)
+ set1
+ (set-disjoin v set1)))
+ set1 set2))
+
+(define (set-difference set1 set2)
+ (set-fold set-disjoin set1 set2))
+
+;; (define (set-xor set1 set2))
+
+
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/table.scm b/module/hnh/util/table.scm
new file mode 100644
index 00000000..a57e6591
--- /dev/null
+++ b/module/hnh/util/table.scm
@@ -0,0 +1,108 @@
+(define-module (hnh util table)
+ :use-module (srfi srfi-1)
+ :use-module (srfi srfi-88)
+ :use-module (srfi srfi-9)
+ :use-module (srfi srfi-9 gnu)
+ :use-module (hnh util lens)
+ :use-module (hnh util object)
+ :export ((make-tree . table)
+ (tree-get . table-get)
+ (tree-put . table-put)
+ (tree-remove . table-remove)
+ (tree->list . table->list)
+ (tree? . table?)
+ (alist->tree . alist->table)))
+
+(define (symbol<? . args)
+ (apply string<? (map symbol->string args)))
+
+(define-syntax-rule (symbol< args ...)
+ (string< (symbol->string args) ...))
+
+(define-type (tree-node)
+ (key type: symbol?)
+ value
+ (left type: tree? default: (tree-terminal))
+ (right type: tree? default: (tree-terminal)))
+
+;; Type tagged null
+(define-type (tree-terminal))
+
+;; Wrapped for better error messages
+(define (make-tree) (tree-terminal))
+
+(define (tree? x)
+ (or (tree-node? x)
+ (tree-terminal? x)))
+
+(define (tree-put tree k v)
+ (cond ((tree-terminal? tree) (tree-node key: k value: v))
+ ((eq? k (key tree)) (value tree v))
+ (else
+ (modify tree (if (symbol<? k (key tree)) left right)
+ tree-put k v))))
+
+(define (tree-get tree k)
+ (cond ((tree-terminal? tree) #f ; (throw 'out-of-range)
+ )
+ ((eq? k (key tree)) (value tree))
+ ((symbol<? k (key tree))
+ (tree-get (left tree) k))
+ (else
+ (tree-get (right tree) k))))
+
+(define (tree-remove tree k)
+ (cond ((tree-terminal? tree) tree)
+ ((eq? k (key tree))
+ (merge-trees (left tree) (right tree)))
+ ((symbol<? k (key tree))
+ (modify tree left (lambda (t) (tree-remove t k))))
+ (else
+ (modify tree right (lambda (t) (tree-remove t k))))))
+
+(define (merge-trees a b)
+ ;; TODO write a better version of this
+ (fold (lambda (item tree)
+ (apply tree-put tree item))
+ a
+ b))
+
+;; in-order traversal
+(define (tree->list tree)
+ (if (tree-terminal? tree)
+ '()
+ (append (tree->list (left tree))
+ (list (cons (key tree) (value tree)))
+ (tree->list (right tree)))))
+
+;; undefined order, probably pre-order
+(define (tree-map f tree)
+ (if (tree-terminal? tree)
+ '()
+ (tree-node key: (key tree)
+ value: (f (key tree) (value tree))
+ left: (tree-map f (left tree))
+ right: (tree-map f (right tree)))))
+
+;; pre-order
+(define (tree-fold f init tree)
+ (if (tree-terminal? tree)
+ init
+ (let ((a (f (key tree) (value tree) init)))
+ (let ((b (tree-fold f a (left tree))))
+ (tree-fold f b (right tree))))))
+
+(define (alist->tree alist)
+ (fold (lambda (kv tree) (tree-put tree (car kv) (cdr kv)))
+ (tree-terminal)
+ alist))
+
+
+
+(define (make-indent depth) (make-string (* 2 depth) #\space))
+
+(define* (print-tree tree optional: (depth 0))
+ (unless (tree-terminal? tree)
+ (format #t "~a- ~s: ~s~%" (make-indent depth) (key tree) (value tree))
+ (print-tree (left tree) (1+ depth))
+ (print-tree (right tree) (1+ depth))))
diff --git a/module/hnh/util/type.scm b/module/hnh/util/type.scm
new file mode 100644
index 00000000..800834e5
--- /dev/null
+++ b/module/hnh/util/type.scm
@@ -0,0 +1,46 @@
+(define-module (hnh util type)
+ :use-module ((srfi srfi-1) :select (every))
+ :export (build-validator-body
+ list-of pair-of
+ typecheck
+ current-procedure-name))
+
+(define-syntax list-of
+ (syntax-rules ()
+ ((_ variable (rule ...))
+ (and (list? variable)
+ (every (lambda (x) (build-validator-body x (rule ...))) variable)))
+ ((_ variable rule)
+ (and (list? variable)
+ (every rule variable)))))
+
+(define-syntax-rule (pair-of variable a b)
+ (and (pair? variable)
+ (build-validator-body (car variable) a)
+ (build-validator-body (cdr variable) b)))
+
+;; DSL for specifying type predicates
+;; Basically a procedure body, but the variable to test is implicit.
+(define-syntax build-validator-body
+ (syntax-rules (and or list-of)
+ ((_ variable (and clauses ...)) (and (build-validator-body variable clauses) ...))
+ ((_ variable (or clauses ...)) (or (build-validator-body variable clauses) ...))
+ ((_ variable (proc args ...)) (proc variable args ...))
+ ((_ variable proc) (proc variable))))
+
+(define-syntax-rule (current-procedure-name)
+ ;; 1 since make-stack is at top of stack
+ (frame-procedure-name (stack-ref (make-stack #t) 1)))
+
+(define-syntax typecheck
+ (syntax-rules ()
+ ((_ variable type-clause)
+ (let ((procedure-name (current-procedure-name)))
+ (typecheck variable type-clause procedure-name)))
+ ((_ variable type-clause procedure-name)
+ (unless (build-validator-body variable type-clause)
+ (scm-error 'wrong-type-arg procedure-name
+ "Invalid value for ~s. Expected ~s, got ~s"
+ (list (quote variable) (quote type-clause) variable)
+ #f)))))
+
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-29 09:59:53 +0200