### Implement record based lenses.

* lens.scm

Showing

;; 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))))) |

Please register or sign in to comment