aboutsummaryrefslogtreecommitdiff
path: root/module/hnh/util
diff options
context:
space:
mode:
Diffstat (limited to 'module/hnh/util')
-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
9 files changed, 624 insertions, 2 deletions
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:29:05 +0200