Commit 69a66e43 authored by Alex Sassmannshausen's avatar Alex Sassmannshausen

Procedural lenses with composition.

* lens.scm
parent a6bec81e
......@@ -33,105 +33,180 @@
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-26)
#:export ())
(define-immutable-record-type <lens>
(lens focus put)
lens?
(focus lens-focus)
(put lens-put))
(define (focus lens thing)
((lens-focus lens) thing))
(define (put lens value thing)
((lens-put lens) value thing))
(define* (over lens action thing)
(put lens (action (focus lens thing)) thing))
(define id
(lens identity (match-lambda* ((n t) n)
(x (throw 'id-lens 'wrong-number-args x)))))
(define fst
(lens (match-lambda ((? vector? v) (vector-ref v 0))
((? list? l) (first l))
(x (throw 'fst-lens 'not-a-sequence x)))
(match-lambda* ((n (? vector? v))
(list->vector (cons n (cdr (vector->list v)))))
((n (? list? l))
(cons n (cdr l)))
((n x) (throw 'fst-lens 'not-a-sequence x))
(x (throw 'fst-lens 'wrong-number-args x)))))
(define snd
(lens (match-lambda ((? vector? v) (vector-ref v 1))
((? list? l) (second l))
(x (throw 'snd-lens 'not-a-sequence x)))
(match-lambda* ((n (? vector? v))
(match (vector->list v)
((fst _ . rest) (apply vector fst n rest))
(x (throw 'snd-lens 'not-enough-elements x))))
((n (? list? l))
(match l
((fst _ . rest) (cons* fst n rest))
(x (throw 'snd-lens 'not-enough-elements x))))
((n x) (throw 'snd-lens 'not-a-sequence x))
(x (throw 'snd-lens 'wrong-number-args x)))))
(define nth
(lambda (N)
(lens (match-lambda ((? vector? v) (vector-ref v N))
((? list? l) (list-ref l N))
(x (throw 'nth-lens 'not-a-sequence x)))
(match-lambda* ((n (? vector? v))
(match (fold (match-lambda
((current (result counter))
(if (= counter N)
(list (cons n result)
(1+ counter))
(list (cons current result)
(1+ counter)))))
'(() 0) (vector->list v))
((result _) (list->vector (reverse result)))))
((n (? list? l))
(match (fold (match-lambda*
((current (result counter))
(if (= counter N)
(list (cons n result)
(1+ counter))
(list (cons current result)
(1+ counter)))))
'(() 0) l)
((result _) (reverse result))))
((n x) (throw 'nth-lens 'not-a-sequence x))
(x (throw 'nth-lens 'wrong-number-args x))))))
(define key
(lambda (N)
(lens (cut assoc N <>)
(lambda (n t)
(map (match-lambda
(((? (cut equal? <> N)) . v) n)
(entry entry))
t)))))
(define key-ref
(lambda (N)
(lens (cut assoc-ref <> N)
(lambda (n t)
(map (match-lambda
(((? (cut equal? <> N) k) . v)
`(,k . ,n))
(entry entry))
t)))))
(define select-keys
(lambda Ns
(lens (lambda (t) (map (cut assoc <> t) Ns))
(lambda (ns t)
(filter-map (match-lambda
(((? (cut member <> Ns) k) . v) (assoc k ns))
(entry entry))
t)))))
#:export (lens
id focus over put
id nth fst snd tail key key-ref select-keys in in* passes passes*
units))
(define (lens getter setter)
"Return a composable lens, which can be used to focus, apply functions over,
or update a value in an arbitrary data structure.
GETTER is a procedure of one argument, the data structure, that can be used to
access the focused item in the data structure.
SETTER is a procedure of two arguments, the data structure & a procedure to be
applied to the data structure to transform the focused value."
(lambda (previous)
(match-lambda*
((s)
(getter (previous s)))
((s f) (previous s (cut setter <> f))))))
(define (id-setter s f)
"The identity setter. IDENTITY is the identity getter."
(f s))
(define (focus lens s)
"Focus on a value in the data structure S by using the lens LENS."
(let ((getter (lens identity)))
(getter s)))
(define (over lens f s)
"Apply the function F over the value focused on by the lens LENS in the data
structure S."
(let ((setter (lens id-setter)))
(setter s f)))
(define (put lens v s)
"Replace the value focused on by the lens LENS with the new value V in data
structure S."
(over lens (const v) s))
;;;; Lenses
(define (id)
"Return the identity lens."
(lens identity id-setter))
(define (nth n)
"Given a number N, return a lens that will focus on the N-th element of a
list."
(lens (cut list-ref <> n)
(lambda (s f)
(reverse
(second
(fold (match-lambda*
((current ((? (cut = <> n) counter) result))
(list (1+ counter) (cons (f current) result)))
((current (counter result))
(list (1+ counter) (cons current result))))
'(0 ())
s))))))
(define (fst)
"Return a lens that will focus on the first element of a list."
(nth 0))
(define (snd)
"Return a lens that will focus on the second element of a list."
(nth 1))
(define (tail)
"Return a lens that focuses on the tail of a list."
(lens cdr
(lambda (s f)
(match s
(() (f '()))
((1st . rest) (cons 1st (f rest)))))))
(define (key k)
"Given K, return a lens that will focus on the pair in an association list
who's key is K."
(lens (cut assoc k <>)
(lambda (s f)
(map (match-lambda
(((? (cut equal? k <>)) . v) (cons k (f v)))
(entry entry))
s))))
;; NOTE: KEY-REF only differs from KEY in getter, not setter. This works
;; apparently (see IN, below), but might be cause of strangeness?
(define (key-ref k)
"Given K, return a lens that will focus on the value of the pair in an
association list who's key is K."
(lens (cut assoc-ref <> k)
(lambda (s f)
(map (match-lambda
(((? (cut equal? k <>)) . v) (cons k (f v)))
(entry entry))
s))))
(define (select-keys . ks)
"Given a list of keys KS, return a lens that will select only those pairs in
an association list whose keys are in KS."
(lens (lambda (s) (map (cut assoc <> s) ks))
(lambda (s f)
;; PUT currently does not update only values of selected keys, but
;; replaces each selected key with the entire set of values
(append (filter-map (lambda (k) (and=> (assoc k s) f)) ks)
(remove (compose (cut member <> ks) first) s)))))
(define assoc?
(match-lambda
(((a . b) ...) #t)
(_ #f)))
;; FIXME: This implementation is closer to source material, but doesn't have a
;; setter yet.
(define in*
(match-lambda*
((path)
(in* path '()))
((path default)
(lens
(lambda (s)
(let lp ((next (first path))
(rest (cdr path))
(target s))
(match (assoc next target)
(#f default)
((k . v)
(match rest
(() `(,k . ,v))
((next . rst)
(lp next
rst
(if (assoc? v)
v
(throw 'in-lens 'atom-reached: v
'path-not-done: rest)))))))))
(lambda (s f)
(f s))))))
;; FIXME: current inconsistency: in focus, throw if unknown path; in put/over,
;; simply return original assoc-list
(define (in . path)
"Given the breadcrumb trail PATH, return a lens that will traverse a nested
association list and focus on the final element in PATH."
(apply compose (reverse (map (cut key-ref <>) path))))
;;;;; Conditional lenses
;; NOTE: This works nicely as the leaf in the composition of lenses, but does
;; not provide us with conditional lensing. See passes* for the latter use
;; case.
(define (passes applies?)
"Given a predicate, return a lens that focuses on an element only if it
passes the predicate."
(lens
(lambda (s) (when (applies? s) s))
(lambda (s f) (if (applies? s) (f s) s))))
(define (passes* applies? true false)
"Given a predicate, a consequent lens TRUE and an alternative lens FALSE,
return a lens that lenses an element with the consequent if it passes the
predicate, or the alternative if it fails."
(lens
(lambda (s) (if (applies? s) (focus lensT s) (focus lensF s)))
(lambda (s f) (if (applies? s) (over lensT f s) (over lensF f s)))))
;;;; Combinators
(define (units one->other other->one)
"Given a function from unit A to unit B and another in the opposite
direction, construct a lens that focuses and updates a converted value."
(lens one->other
(lambda (s f) (other->one (f (one->other s))))))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment