diff options
Diffstat (limited to '')
-rw-r--r-- | module/hnh/module-introspection/module-uses.scm | 2 | ||||
-rw-r--r-- | module/hnh/test/testrunner.scm | 126 | ||||
-rw-r--r-- | module/hnh/test/util.scm | 57 | ||||
-rw-r--r-- | module/hnh/test/xmllint.scm | 27 | ||||
-rw-r--r-- | module/hnh/util.scm | 18 | ||||
-rw-r--r-- | module/hnh/util/assert.scm | 9 | ||||
-rw-r--r-- | module/hnh/util/env.scm | 13 | ||||
-rw-r--r-- | module/hnh/util/io.scm | 10 | ||||
-rw-r--r-- | module/hnh/util/lens.scm | 105 | ||||
-rw-r--r-- | module/hnh/util/object.scm | 169 | ||||
-rw-r--r-- | module/hnh/util/set.scm | 46 | ||||
-rw-r--r-- | module/hnh/util/state-monad.scm | 120 | ||||
-rw-r--r-- | module/hnh/util/table.scm | 108 | ||||
-rw-r--r-- | module/hnh/util/type.scm | 46 |
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))))) + |