@@ -9,5 +9,6 @@

                :alexandria

                :serapeum)

   :serial t

-  :components ((:file "lens")))

-

+  :components ((:file "package")

+               (:file "optics")

+               (:file "lens")))

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

-

 (declaim

  (inline data-lens:over data-lens:transform-tail

          data-lens:applicable-when data-lens:of-min-length

new file mode 100644

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

new file mode 100644

@@ -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 #:== #:•

+           ))