fiddlerwoaroof/data-lens
1
0
Fork 0
mirror of https://github.com/fiddlerwoaroof/data-lens.git synced 2025-11-08 18:26:32 +00:00
Code Issues Releases Wiki Activity

chore: split into files

Browse Source
This commit is contained in:
Ed L
2020-10-05 19:44:35 -07:00
parent 1dcfeff5de
commit 38133d6f0a
4 changed files with 244 additions and 242 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
data-lens.asd
View File

@ -9,5 +9,6 @@
:alexandria :alexandria
:serapeum) :serapeum)
:serial t :serial t
:components ((:file "lens"))) :components ((:file "package")
(:file "optics")
(:file "lens")))

240
lens.lisp
View File

@ -1,245 +1,5 @@
(defpackage :data-lens.lenses
(:shadow :set)
(:use :cl)
(:export :over :set :view :make-alist-lens :make-plist-lens :make-hash-table-lens
:make-list-lens))
(in-package :data-lens.lenses)
#+fw.dev
(progn
;; maybe functor implementation
(defclass maybe ()
())
(defclass just (maybe)
((%v :initarg :value :reader value)))
(defclass nothing (maybe)
())
(defun just (value)
(make-instance 'just :value value))
(defun nothing (&optional value)
(declare (ignore value))
(make-instance 'nothing))
(defgeneric maybe (default value)
(:method (default (value just))
(value value))
(:method (default (value nothing))
default))
(defgeneric maybe-apply (function value)
(:method (function (value just))
(just (funcall function (value value))))
(:method (function (value nothing))
value))
(defmethod print-object ((o just) s)
(format s "#.(~s ~s)"
'just
(value o)))
(defmethod print-object ((o nothing) s)
(format s "#.(~s)"
'nothing)))
;; identity functor, necessary for set and over
(defclass identity- ()
((%v :initarg :value :reader unidentity)))
(defun wrap-identity (v)
(make-instance 'identity- :value v))
(defmethod print-object ((o identity-) s)
(format s "#.(~s ~s)"
'wrap-identity
(unidentity o)))
;; constant functor, necessary for view
(defclass constant- ()
((%v :initarg :value :reader unconstant)))
(defun wrap-constant (v)
(make-instance 'constant- :value v))
(defmethod print-object ((o constant-) s)
(format s "#.(~s ~s)"
'wrap-constant
(unconstant o)))
(defgeneric fmap (function data)
(:method (function (data identity-))
(wrap-identity
(funcall function
(unidentity data))))
(:method (function (data constant-))
data)
(:method (function (data list))
(mapcar function data))
(:method (function (data vector))
(map 'vector function data))
#+fw.dev
(:method (function (data maybe))
(maybe-apply function data)))
(defun over (lens cb rec)
"Given a lens, a callback and a record, apply the lens to the
record, transform it by the callback and return copy of the record,
updated to contain the result of the callback. This is the fundamental
operation on a lens and SET and VIEW are implemented in terms of it.
A lens is any function of the form (lambda (fun) (lambda (rec) ...))
that obeys the lens laws (where == is some reasonable equality
operator):
(== (view lens (set lens value rec))
value)
(== (set lens (view lens rec) rec)
rec)
(== (set lens value2 (set lens value1 rec))
(set lens value2 rec))
The inner lambda returns a functor that determines the policy to be
applied to the focused part. By default, this only uses IDENTITY- and
CONSTANT- in order to implement the lens operations over, set and
view.
If these conditions are met, (over (data-lens:<>1 lens1 lens2) ...) is
equivalent to using lens2 to focus the part lens1 focuses: note that
composition is \"backwards\" from what one might expect: this is
because composition composes the wrapper lambdas and applies the
lambda that actually pulls a value out of a record later."
(unidentity
(funcall (funcall lens (lambda (x) (wrap-identity (funcall cb x))))
rec)))
(defun view (lens rec)
"Given a lens and a rec, return the focused value"
(unconstant
(funcall (funcall lens (lambda (x) (wrap-constant x)))
rec)))
(defun set (lens v rec)
"Given a lens, a value and a rec, immutably update the rec to
contain the new value at the location focused by the lens."
(unidentity
(funcall (funcall lens (lambda (_) _ (wrap-identity v)))
rec)))
#+fw.dev
(progn
;; "fake" functors that don't assume a functor result to their
;; callback
(defun over* (lens cb rec)
(funcall (funcall lens cb)
rec))
(defun set* (lens value rec)
(over lens
(lambda (_)
(declare (ignore _))
value)
rec))
(defun view* (lens rec)
(over lens
(lambda (value)
(return-from view*
value))
rec)))
(defun make-alist-history-lens (key)
"A lens for updating a alist, preserving previous values"
(lambda (cb)
(lambda (alist)
(fmap (lambda (new)
(cons (cons key new)
alist))
(funcall cb (serapeum:assocdr key alist))))))
(defun make-alist-lens (key)
"A lens for updating a alist, discarding previous values"
(lambda (cb)
(lambda (alist)
(fmap (lambda (new)
(remove-duplicates (cons (cons key new)
alist)
:key #'car
:from-end t))
(funcall cb (serapeum:assocdr key alist))))))
(defun make-list-lens (index)
"A lens for updating a sequence"
(lambda (cb)
(lambda (seq)
(fmap (lambda (new)
(let ((result (copy-seq seq)))
(prog1 result
(setf (elt result index) new))))
(funcall cb (elt seq index))))))
(defun make-plist-lens (key)
"A lens for updating a plist, preserving previous values"
(lambda (cb)
(lambda (plist)
(fmap (lambda (new)
(list* key new
plist))
(funcall cb (getf plist key))))))
(defun make-hash-table-lens (key)
"A lens for updating a hash-table, discarding previous values"
(lambda (cb)
(lambda (old-hash)
(fmap (lambda (new)
(let ((new-hash (alexandria:copy-hash-table old-hash)))
(prog1 new-hash
(setf (gethash key new-hash)
new))))
(funcall cb (gethash key old-hash))))))
;; imagine a lens here that uses the MOP to immutably update a class...
(defgeneric clone (obj &rest new-initargs &key)
(:method :around (obj &rest new-initargs &key)
(apply #'reinitialize-instance (call-next-method) new-initargs)))
#+fw.demo
(progn
(defclass foo ()
((a :initarg :a :accessor a)))
(defmethod clone ((obj foo) &key)
(make-instance 'foo :a (a obj)))
;;; needs to be updated for functor-based lens
(defun a-lens (cb)
(lambda (foo)
(fw.lu:prog1-bind (new (clone foo))
(setf (a new)
(funcall cb (a foo))))))
(view 'a-lens
(over 'a-lens '1+
(set 'a-lens 2
(make-instance 'foo :a 1)))) #|
==> 3 |#)
(defpackage :data-lens
(:use :cl)
(:import-from #:serapeum #:op #:defalias)
(:export #:regex-match #:include #:exclude #:pick #:key-transform
#:combine #:derive #:cumsum #:over #:on #:shortcut #:defun-ct #:key
#:extract-key #:element #:let-fn #:juxt #:transform-tail #:slice
#:compress-runs #:combine-matching-lists #:sorted #:applicable-when
#:of-length #:of-min-length #:of-max-length #:transform-head
#:maximizing #:zipping #:applying #:splice-elt #:transform-elt #:denest
#:op #:defalias #:<> #:<>1 #:== #:•
))
(in-package :data-lens) (in-package :data-lens)
(declaim (declaim
(inline data-lens:over data-lens:transform-tail (inline data-lens:over data-lens:transform-tail
data-lens:applicable-when data-lens:of-min-length data-lens:applicable-when data-lens:of-min-length

219
optics.lisp Normal file
View File

@ -0,0 +1,219 @@
(in-package :data-lens.lenses)
;; identity functor, necessary for set and over
(defclass identity- ()
((%v :initarg :value :reader unidentity)))
(defun wrap-identity (v)
(make-instance 'identity- :value v))
(defmethod print-object ((o identity-) s)
(format s "#.(~s ~s)"
'wrap-identity
(unidentity o)))
;; constant functor, necessary for view
(defclass constant- ()
((%v :initarg :value :reader unconstant)))
(defun wrap-constant (v)
(make-instance 'constant- :value v))
(defmethod print-object ((o constant-) s)
(format s "#.(~s ~s)"
'wrap-constant
(unconstant o)))
(defgeneric fmap (function data)
(:method (function (data identity-))
(wrap-identity
(funcall function
(unidentity data))))
(:method (function (data constant-))
data)
(:method (function (data list))
(mapcar function data))
(:method (function (data vector))
(map 'vector function data))
#+fw.dev
(:method (function (data maybe))
(maybe-apply function data)))
(defun over (lens cb rec)
"Given a lens, a callback and a record, apply the lens to the
record, transform it by the callback and return copy of the record,
updated to contain the result of the callback. This is the fundamental
operation on a lens and SET and VIEW are implemented in terms of it.
A lens is any function of the form (lambda (fun) (lambda (rec) ...))
that obeys the lens laws (where == is some reasonable equality
operator):
(== (view lens (set lens value rec))
value)
(== (set lens (view lens rec) rec)
rec)
(== (set lens value2 (set lens value1 rec))
(set lens value2 rec))
The inner lambda returns a functor that determines the policy to be
applied to the focused part. By default, this only uses IDENTITY- and
CONSTANT- in order to implement the lens operations over, set and
view.
If these conditions are met, (over (data-lens:<>1 lens1 lens2) ...) is
equivalent to using lens2 to focus the part lens1 focuses: note that
composition is \"backwards\" from what one might expect: this is
because composition composes the wrapper lambdas and applies the
lambda that actually pulls a value out of a record later."
(unidentity
(funcall (funcall lens (lambda (x) (wrap-identity (funcall cb x))))
rec)))
(defun view (lens rec)
"Given a lens and a rec, return the focused value"
(unconstant
(funcall (funcall lens (lambda (x) (wrap-constant x)))
rec)))
(defun set (lens v rec)
"Given a lens, a value and a rec, immutably update the rec to
contain the new value at the location focused by the lens."
(unidentity
(funcall (funcall lens (lambda (_) _ (wrap-identity v)))
rec)))
#+fw.dev
(progn
;; "fake" functors that don't assume a functor result to their
;; callback
(defun over* (lens cb rec)
(funcall (funcall lens cb)
rec))
(defun set* (lens value rec)
(over lens
(lambda (_)
(declare (ignore _))
value)
rec))
(defun view* (lens rec)
(over lens
(lambda (value)
(return-from view*
value))
rec)))
(defun make-alist-history-lens (key)
"A lens for updating a alist, preserving previous values"
(lambda (cb)
(lambda (alist)
(fmap (lambda (new)
(cons (cons key new)
alist))
(funcall cb (serapeum:assocdr key alist))))))
(defun make-alist-lens (key)
"A lens for updating a alist, discarding previous values"
(lambda (cb)
(lambda (alist)
(fmap (lambda (new)
(remove-duplicates (cons (cons key new)
alist)
:key #'car
:from-end t))
(funcall cb (serapeum:assocdr key alist))))))
(defun make-list-lens (index)
"A lens for updating a sequence"
(lambda (cb)
(lambda (seq)
(fmap (lambda (new)
(let ((result (copy-seq seq)))
(prog1 result
(setf (elt result index) new))))
(funcall cb (elt seq index))))))
(defun make-plist-lens (key)
"A lens for updating a plist, preserving previous values"
(lambda (cb)
(lambda (plist)
(fmap (lambda (new)
(list* key new
plist))
(funcall cb (getf plist key))))))
(defun make-hash-table-lens (key)
"A lens for updating a hash-table, discarding previous values"
(lambda (cb)
(lambda (old-hash)
(fmap (lambda (new)
(let ((new-hash (alexandria:copy-hash-table old-hash)))
(prog1 new-hash
(setf (gethash key new-hash)
new))))
(funcall cb (gethash key old-hash))))))
;; imagine a lens here that uses the MOP to immutably update a class...
(defgeneric clone (obj &rest new-initargs &key)
(:method :around (obj &rest new-initargs &key)
(apply #'reinitialize-instance (call-next-method) new-initargs)))
#+fw.demo
(progn
(defclass foo ()
((a :initarg :a :accessor a)))
(defmethod clone ((obj foo) &key)
(make-instance 'foo :a (a obj)))
;;; needs to be updated for functor-based lens
(defun a-lens (cb)
(lambda (foo)
(fw.lu:prog1-bind (new (clone foo))
(setf (a new)
(funcall cb (a foo))))))
(view 'a-lens
(over 'a-lens '1+
(set 'a-lens 2
(make-instance 'foo :a 1)))) #|
==> 3 |#)
#+fw.dev
(progn
;; maybe functor implementation
(defclass maybe ()
())
(defclass just (maybe)
((%v :initarg :value :reader value)))
(defclass nothing (maybe)
())
(defun just (value)
(make-instance 'just :value value))
(defun nothing (&optional value)
(declare (ignore value))
(make-instance 'nothing))
(defgeneric maybe (default value)
(:method (default (value just))
(value value))
(:method (default (value nothing))
default))
(defgeneric maybe-apply (function value)
(:method (function (value just))
(just (funcall function (value value))))
(:method (function (value nothing))
value))
(defmethod print-object ((o just) s)
(format s "#.(~s ~s)"
'just
(value o)))
(defmethod print-object ((o nothing) s)
(format s "#.(~s)"
'nothing)))

22
package.lisp Normal file
View File

@ -0,0 +1,22 @@
(defpackage :data-lens.package
(:use :cl )
(:export ))
(in-package :data-lens.package)
(defpackage :data-lens.lenses
(:shadow :set)
(:use :cl)
(:export :over :set :view :make-alist-lens :make-plist-lens :make-hash-table-lens
:make-list-lens))
(defpackage :data-lens
(:use :cl)
(:import-from #:serapeum #:op #:defalias)
(:export #:regex-match #:include #:exclude #:pick #:key-transform
#:combine #:derive #:cumsum #:over #:on #:shortcut #:defun-ct #:key
#:extract-key #:element #:let-fn #:juxt #:transform-tail #:slice
#:compress-runs #:combine-matching-lists #:sorted #:applicable-when
#:of-length #:of-min-length #:of-max-length #:transform-head
#:maximizing #:zipping #:applying #:splice-elt #:transform-elt #:denest
#:op #:defalias #:<> #:<>1 #:== #:•
))