From 38133d6f0a42c31518dd8b0791caecbf270864a1 Mon Sep 17 00:00:00 2001
From: Ed L <el-github@elangley.org>
Date: Mon, 5 Oct 2020 19:44:35 -0700
Subject: [PATCH] chore: split into files

---
 data-lens.asd |   5 +-
 lens.lisp     | 240 --------------------------------------------------
 optics.lisp   | 219 +++++++++++++++++++++++++++++++++++++++++++++
 package.lisp  |  22 +++++
 4 files changed, 244 insertions(+), 242 deletions(-)
 create mode 100644 optics.lisp
 create mode 100644 package.lisp

diff --git a/data-lens.asd b/data-lens.asd
index 41212b3..e863b77 100644
--- a/data-lens.asd
+++ b/data-lens.asd
@@ -9,5 +9,6 @@
                :alexandria
                :serapeum)
   :serial t
-  :components ((:file "lens")))
-
+  :components ((:file "package")
+               (:file "optics")
+               (:file "lens")))
diff --git a/lens.lisp b/lens.lisp
index a79b31b..d898688 100644
--- a/lens.lisp
+++ b/lens.lisp
@@ -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
diff --git a/optics.lisp b/optics.lisp
new file mode 100644
index 0000000..28cee01
--- /dev/null
+++ b/optics.lisp
@@ -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)))
diff --git a/package.lisp b/package.lisp
new file mode 100644
index 0000000..10dbde9
--- /dev/null
+++ b/package.lisp
@@ -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 #:== #:•
+           ))