diff options
Diffstat (limited to '')
-rw-r--r-- | module/hnh/util/coverage.scm | 9 | ||||
-rw-r--r-- | module/hnh/util/lens.scm | 136 | ||||
-rw-r--r-- | module/hnh/util/object.scm | 41 | ||||
-rw-r--r-- | module/hnh/util/table.scm | 25 |
4 files changed, 124 insertions, 87 deletions
diff --git a/module/hnh/util/coverage.scm b/module/hnh/util/coverage.scm index 15bdd250..8dc65bb8 100644 --- a/module/hnh/util/coverage.scm +++ b/module/hnh/util/coverage.scm @@ -67,14 +67,15 @@ (fold (lambda (line state) (match (parse-coverage-line line) (('DA line hits) - (modify state (compose-lenses car* lines) + ;; TODO focus further? + (modify state (compose-lens car* lines*) (lambda (lines) (cons (cons line hits) lines)))) (('SF source) - (set state car* filename source)) + (set state (lens-compose car* filename*) source)) (('LH hit) - (set state car* hit-lines hit)) + (set state (lens-compose car* hit-lines*) hit)) (('LF lines) - (set state car* total-lines lines)) + (set state (lens-compose car* total-lines*) lines)) (('end-of-record) (cons (coverage-info) state)))) (list (coverage-info)) diff --git a/module/hnh/util/lens.scm b/module/hnh/util/lens.scm index 00f7fe1e..5932cce6 100644 --- a/module/hnh/util/lens.scm +++ b/module/hnh/util/lens.scm @@ -1,106 +1,82 @@ (define-module (hnh util lens) :use-module (srfi srfi-1) + :use-module (ice-9 control) + :use-module (ice-9 curried-definitions) :export (modify - modify* set get identity-lens - compose-lenses + compose-lens 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 ...)))) - - + focus-matching + traversed + ref car* cdr* + )) -(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 ((car* lst) f) + (cons (f (car lst)) ; ← focus + (cdr lst))) - +(define ((cdr* lst) f) + (cons (car lst) + (f (cdr lst)))) -(define identity-lens - (case-lambda ((a) a) - ((_ a) a))) +(define (((ref idx) list) f) + (let loop ((idx idx) (rem list)) + (if (zero? idx) + (cons (f (car rem)) + (cdr rem)) + (cons (car rem) + (loop (1- idx) + (cdr rem)))))) -(define (compose-lenses% f g) - (build-lens (get f g) (set f g))) +(define (((focus-matching predicate) list) f) + (map (lambda (x) + (if (predicate x) + (f x) + x)) + list)) -(define (compose-lenses . fs) - (reduce-right compose-lenses% identity-lens fs)) -(define lens-compose compose-lenses) +;;; Lens l i :: l i → (i → i) → l i - +;;; modify :: (l i, Lens l i, (i → i)) → l i +(define (modify container lens f) + ((lens container) f)) -(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))))) +;;; set :: (l i, Lens l i, i) → l i +(define (set container lens value) + (modify container lens (const value))) +;;; get :: (l i, Lens l i) → i +(define (get container lens) + (call/ec (lambda (return) + (modify container lens return)))) +(define (traversed container lens) + (define v '()) + ((lens container) (lambda (x) (set! v (cons x v)))) + v) -(define (ref idx) - (build-lens (list-ref idx) (list-change idx))) +(define lens-compose + (case-lambda + ((lens) + (lambda (object) + (lambda (operator) + (modify object lens operator)))) + ((lens . lenses) + (lambda (object) + (lambda (operator) + (modify object lens + (lambda (focus) (((apply lens-compose lenses) focus) operator)))))))) -(define car* - (case-lambda ((pair) (car pair)) - ((pair value) (cons value (cdr pair))))) +(define compose-lens lens-compose) -(define cdr* - (case-lambda ((pair) (cdr pair)) - ((pair value) (cons (car pair) value)))) -(define (each obj lens proc) - (modify obj lens - (lambda (lst) (map proc lst)))) +(define ((identity-lens object) op) + (op object)) diff --git a/module/hnh/util/object.scm b/module/hnh/util/object.scm index 813a59ce..68703e1e 100644 --- a/module/hnh/util/object.scm +++ b/module/hnh/util/object.scm @@ -112,11 +112,35 @@ (datum->syntax stx)))) #'(name name-get name-set))))) +;;; Name of the created accessor +(define (accessor-name field) + (syntax-case field () + ((name kvs ...) + (cond ((kv-ref #'(kvs ...) accessor:) + => identity) + (else #'name))) + (name #'name))) + +;;; Name of the created lens +(define (lens-name field) + (syntax-case field () + ((name kvs ...) + (cond ((kv-ref #'(kvs ...) lens:) + => identity) + (else (->> (syntax->datum #'name) + (format #f "~a*") + string->symbol + (datum->syntax field))))) + (name (->> (syntax->datum #'name) + (format #f "~a*") + string->symbol + (datum->syntax field))))) + ;; Accessors are procedures for getting and setting fields in records (define-syntax (build-accessor stx) (syntax-case stx () ((_ type-name (name kvs ...)) - #'(define name + #`(define #,(accessor-name #'(name kvs ...)) (case-lambda ((datum) ((field-get type-name name) datum)) ((datum new-value) @@ -126,10 +150,23 @@ ;; while keeping name bound to the accessor in the outer scope. (let ((name new-value)) (validator name (name kvs ...))) + ((field-set type-name name) datum new-value))))) + ((_ type-name name) #'(build-accessor type-name (name))))) +(define (build-lenses stx fields) + (map (lambda (field) + (with-syntax ((lens* (lens-name field)) + (accessor (accessor-name field))) + #'(define (lens* object) + (lambda (op) + (accessor object + (op (accessor object))))))) + fields)) + + (define (syntax-name field) (syntax-case field () ((name kvs ...) @@ -187,6 +224,8 @@ ;; Field accessors (build-accessor name field) ... + #,@(build-lenses stx #'(field ...)) + ;; if printer in attribute #,@(cond ((kv-ref #'(attribute ...) printer:) => (lambda (printer) diff --git a/module/hnh/util/table.scm b/module/hnh/util/table.scm index 23ce6cd4..b318cf77 100644 --- a/module/hnh/util/table.scm +++ b/module/hnh/util/table.scm @@ -49,12 +49,33 @@ (or (tree-node? x) (tree-terminal? x))) +;;; A lens +;;; This function (tree-focus) +;;; returns a function (f), +;;; which takes a function (g). +;;; +;;; g will be given the focused value in the tree, and should return +;;; the new value for that node +;;; +;;; f takes such a modifier function, and returns a new tree identical +;;; to the old tree, but with the value of that node changed +(define (tree-focus tree k) + (lambda (op) + (cond ((tree-terminal? tree) ;; new node + (tree-node key: k value: (op 'not-a-value))) + ((eq? k (key tree)) ;; this node + (value tree (op (value truee)))) + (else + (if (symbol<? k (key tree)) + (lens-compose left* (tree-focus (left tree) k)) + (lens-compose right* (tree-focus (right tree k)))))))) + (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)))) + (modify tree (if (symbol<? k (key tree)) left* right*) + (lambda (branch) (tree-put branch k v)))))) (define* (tree-get tree k optional: default) (cond ((tree-terminal? tree) default) |