aboutsummaryrefslogtreecommitdiff
path: root/module/hnh
diff options
context:
space:
mode:
Diffstat (limited to 'module/hnh')
-rw-r--r--module/hnh/util.scm35
-rw-r--r--module/hnh/util/io.scm8
-rw-r--r--module/hnh/util/lens.scm99
-rw-r--r--module/hnh/util/object.scm169
-rw-r--r--module/hnh/util/type.scm54
-rw-r--r--module/hnh/util/values.scm27
6 files changed, 390 insertions, 2 deletions
diff --git a/module/hnh/util.scm b/module/hnh/util.scm
index d2c0dd5f..096e38c5 100644
--- a/module/hnh/util.scm
+++ b/module/hnh/util.scm
@@ -34,6 +34,9 @@
group-by
split-by
+ split-by-one-of
+
+ break/all
span-upto
cross-product
@@ -341,6 +344,38 @@
(cdr rem))])))
+(define (split-by-one-of lst items)
+ (cond ((null? items)
+ (scm-error 'wrong-type-arg "split-by-one-of"
+ "Must have at least one item to split by, when splitting ~s"
+ (cons items '()) #f))
+ ((not (list? items))
+ (scm-error 'wrong-type-arg "split-by-one-of"
+ "Items must be list of list of symbols, got ~s"
+ (list items) #f))
+ (else
+ (call-with-values
+ (lambda ()
+ (car+cdr
+ (let loop ((token 'sentinel-token) (lst lst))
+ (let ((head tail (break (lambda (item) (memv item items))
+ lst)))
+ (let ((group (cons token head)))
+ (if (null? tail)
+ (list group)
+ (cons group (loop (car tail) (cdr tail)))))))))
+ ;; Remove the sentinel token
+ (lambda (first rest) (cons (cdr first) rest))))))
+
+
+(define (break/all predicate lst)
+ (let loop ((lst lst))
+ (if (null? lst)
+ '(())
+ (let ((fst rest (break predicate lst)))
+ (if (null? rest)
+ (list fst)
+ (cons fst (loop (cdr rest))))))))
;; Simar to span from srfi-1, but never takes more than
;; @var{count} items. Can however still take less.
diff --git a/module/hnh/util/io.scm b/module/hnh/util/io.scm
index d73a1de8..2fbad39f 100644
--- a/module/hnh/util/io.scm
+++ b/module/hnh/util/io.scm
@@ -1,11 +1,12 @@
(define-module (hnh util io)
:use-module ((hnh util) :select (begin1))
- :use-module ((ice-9 rdelim) :select (read-line))
+ :use-module ((ice-9 rdelim) :select (read-line read-string))
:export (open-input-port
open-output-port
read-lines
with-atomic-output-to-file
- call-with-tmpfile))
+ call-with-tmpfile
+ read-file))
(define (open-input-port str)
(if (string=? "-" str)
@@ -72,3 +73,6 @@
(begin1
(proc port filename)
(close-port port))))))
+
+(define (read-file path)
+ (call-with-input-file path read-string))
diff --git a/module/hnh/util/lens.scm b/module/hnh/util/lens.scm
new file mode 100644
index 00000000..7a8fbd19
--- /dev/null
+++ b/module/hnh/util/lens.scm
@@ -0,0 +1,99 @@
+(define-module (hnh util lens)
+ :use-module (srfi srfi-1)
+ :export (modify
+ modify*
+ set
+ get
+
+ identity-lens
+ compose-lenses
+ lens-compose
+
+ ref car* cdr*))
+
+
+(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))))
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/type.scm b/module/hnh/util/type.scm
new file mode 100644
index 00000000..50008a3a
--- /dev/null
+++ b/module/hnh/util/type.scm
@@ -0,0 +1,54 @@
+(define-module (hnh util type)
+ :use-module ((srfi srfi-1) :select (every))
+ :export (build-validator-body
+ list-of pair-of
+ of-type?
+ 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 not)
+ ((_ variable (and clauses ...)) (and (build-validator-body variable clauses) ...))
+ ((_ variable (or clauses ...)) (or (build-validator-body variable clauses) ...))
+ ((_ variable (not clause)) (not (build-validator-body variable clause)))
+ ((_ 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 of-type?
+ (syntax-rules ()
+ ((_ variable type-spec)
+ (build-validator-body variable type-spec))
+ ((_ type-spec)
+ (lambda (x) (build-validator-body x type-spec)))))
+
+(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)))))
diff --git a/module/hnh/util/values.scm b/module/hnh/util/values.scm
new file mode 100644
index 00000000..79f06cff
--- /dev/null
+++ b/module/hnh/util/values.scm
@@ -0,0 +1,27 @@
+(define-module (hnh util values)
+ :use-module (ice-9 control)
+ :export (abort* on-fst on-snd apply/values)
+ )
+
+
+(define-syntax-rule (abort* form)
+ (call-with-values (lambda () form) abort))
+
+
+;; (on-fst (+ 2 (abort* (values 3 4))))
+;; ⇒ 5 ⇒ 4
+
+(define-syntax-rule (on-fst form)
+ (% form
+ (lambda (prompt fst . rest)
+ (apply values (prompt fst) rest))))
+
+(define-syntax-rule (on-snd form)
+ (% form
+ (lambda (prompt fst snd . rest)
+ (apply values fst (prompt snd) rest))))
+
+
+(define-syntax-rule (apply/values proc form)
+ (call-with-values (lambda () form)
+ proc))
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-29 12:41:47 +0200