Commit a6bec81e authored by Alex Sassmannshausen's avatar Alex Sassmannshausen

Implement record based lenses.

* lens.scm
parent 8abd6081
;; lens.scm --- lens implementation -*- coding: utf-8 -*-
;;
;; Copyright (C) 2018 Alex Sassmannshausen <[email protected]>
;;
;; Author: Alex Sassmannshausen <[email protected]>
;;
;; This file is part of guile-lens.
;;
;; guile-lens is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by the Free
;; Software Foundation; either version 3 of the License, or (at your option)
;; any later version.
;;
;; guile-lens is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
;; for more details.
;;
;; You should have received a copy of the GNU General Public License along
;; with guile-lens; if not, contact:
;;
;; Free Software Foundation Voice: +1-617-542-5942
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
;; Boston, MA 02111-1307, USA [email protected]
;;; Commentary:
;;
;;; Code:
(define-module (lens)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#: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)))))
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