[elpa] scratch/mheerdegen-preview 220f349 04/35: WIP: Add package "sscell"

[Michael Heerdegen]

branch: scratch/mheerdegen-preview
commit 220f3494732e1a8cfe2d363dafa414c35fa1034f
Author: Michael Heerdegen <address@hidden>
Commit: Michael Heerdegen <address@hidden>

    WIP: Add package "sscell"
---
 packages/sscell/sscell-tests.el | 120 +++++++++++++++++++++++
 packages/sscell/sscell.el       | 208 ++++++++++++++++++++++++++++++++++++++++
 2 files changed, 328 insertions(+)

diff --git a/packages/sscell/sscell-tests.el b/packages/sscell/sscell-tests.el
new file mode 100644
index 0000000..7837e33
--- /dev/null
+++ b/packages/sscell/sscell-tests.el
@@ -0,0 +1,120 @@
+;;; sscell-tests --- Regression tests for sscell.el   -*- lexical-binding: t 
-*-
+
+;; Copyright (C) 2018 Free Software Foundation, Inc.
+
+;; Author: Michael Heerdegen <address@hidden>
+;; Maintainer: Michael Heerdegen <address@hidden>
+
+;; This file is not part of GNU Emacs.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+
+(require 'ert)
+(require 'cl-lib)
+(require 'sscell)
+(eval-when-compile (require 'subr-x))
+
+
+;; Tests analogue to thunk-tests.el
+
+(ert-deftest sscell-is-lazy-and-can-be-evaluated ()
+  (let* (x  (sscell (sscell-make () (ignore (setq x t)))))
+    (should (null x))
+    (ignore (sscell-get sscell))
+    (should x)))
+
+(ert-deftest sscell-evaluation-is-cached ()
+  (let* ((x 0)
+         (sscell (sscell-make () (setq x (1+ x)))))
+    (ignore (sscell-get sscell))
+    (should (= x 1))
+    (ignore (sscell-get sscell))
+    (should (= x 1))))
+
+(ert-deftest sscell-let-basic-test ()
+  "Test whether bindings are established."
+  (should (equal (sscell-let ((x () 1) (y () 2)) (+ x y)) 3)))
+
+(ert-deftest sscell-let*-basic-test ()
+  "Test whether bindings are established."
+  (should (equal (sscell-let* ((x () 1) (y () (+ 1 x))) (+ x y)) 3)))
+
+(ert-deftest sscell-let-bound-vars-can-be-set-test ()
+  ;; Contrary to thunks this works...
+  "Test whether setting a `sscell-let' bound variable works."
+  (should
+   (eq 80 (sscell-let ((x () 1))
+            (let ((y 7))
+              (setq x (+ x y))
+              (* 10 x))))))
+
+(ert-deftest sscell-let-laziness-test ()
+  "Test laziness of `sscell-let'."
+  (should
+   (equal (let ((x-evalled nil)
+                (y-evalled nil))
+            (sscell-let ((x () (progn (setq x-evalled t) (+ 1 2)))
+                         (y () (progn (setq y-evalled t) (+ 3 4))))
+              (let ((evalled-y y))
+                (list x-evalled y-evalled evalled-y))))
+          (list nil t 7))))
+
+(ert-deftest sscell-let*-laziness-test ()
+  "Test laziness of `sscell-let*'."
+  (should
+   (equal (let ((x-evalled nil)
+                (y-evalled nil)
+                (z-evalled nil)
+                (a-evalled nil))
+            (sscell-let* ((x () (progn (setq x-evalled t) (+ 1 1)))
+                          (y () (progn (setq y-evalled t) (+ x 1)))
+                          (z () (progn (setq z-evalled t) (+ y 1)))
+                          (a () (progn (setq a-evalled t) (+ z 1))))
+              (let ((evalled-z z))
+                (list x-evalled y-evalled z-evalled a-evalled evalled-z))))
+          (list t t t nil 4))))
+
+(ert-deftest sscell-let-bad-binding-test ()
+  "Test whether a bad binding causes an error when expanding."
+  (should-error (macroexpand '(sscell-let ((x () 1 1)) x)))
+  (should-error (macroexpand '(sscell-let (27) x)))
+  (should-error (macroexpand '(sscell-let x x))))
+
+
+;; Tests for implicit dependencies
+
+(ert-deftest sscell-implicit-dep-test-1 ()
+  (let ((a (sscell-make () 10))
+        (b (sscell-make () 20))
+        (c (sscell-make () 40)))
+    (let* ((cell1 (sscell-make () (+ (sscell-get a) (sscell-get b))))
+           (cell2 (sscell-make ()
+                    (let ((counter 0))
+                      (while (< (sscell-get cell1) (sscell-get c))
+                        (cl-incf counter)
+                        (cl-incf (sscell-get a)))
+                      counter))))
+      (should (eq (sscell-get cell2) 10)))))
+
+(ert-deftest sscell-implicit-dep-test-2 ()
+  (let ((cells (cl-loop for i from 1 to 10 collect (sscell-make () nil))))
+    (sscell-set-value (nth 0 cells) 1)
+    (cl-maplist (lambda (rest) (when (cdr rest) (sscell-set (cadr rest) () (1+ 
(sscell-get (car rest))))))
+                cells)
+    (should (eq (sscell-get (car (last cells))) 10))))
+
+
+(provide 'sscell-tests)
+;;; sscell-tests.el ends here
diff --git a/packages/sscell/sscell.el b/packages/sscell/sscell.el
new file mode 100644
index 0000000..0b5164d
--- /dev/null
+++ b/packages/sscell/sscell.el
@@ -0,0 +1,208 @@
+;;; sscell.el --- An implementation of abstract spreadsheet cell objects    
-*- lexical-binding: t -*-
+
+;; Copyright (C) 2018 Free Software Foundation, Inc
+
+;; Author: Michael Heerdegen <address@hidden>
+;; Maintainer: Michael Heerdegen <address@hidden>
+;; Created: 2017_12_11
+;; Keywords: lisp
+;; Version: 0.1
+;; Package-Requires: ((emacs "25"))
+
+
+;; This file is not part of GNU Emacs.
+
+;; GNU Emacs 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.
+
+;; GNU Emacs 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 GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
+
+
+;;; Commentary:
+
+;; This package implements objects that are an abstract version of
+;; spreadsheet cells.  Note that this has nothing to do with a
+;; spreadsheet application (though you could use sscells to implement
+;; one, but this is not the goal of this package) - these sscells are
+;; a data type useful for general Elisp programming.
+;;
+;; An sscell is an object containing a value field, a calculation rule
+;; to update that cell's value, and a set of dependencies.  There are
+;; two types of dependencies: implicit and static dependecies.  Static
+;; dependencies are specified when creating an sscell:
+;;
+;;   (sscell-make static-deps rule)
+;;
+;; where RULE is the calculation rule for the returned cell.  You ask
+;; an sscell for its value with (sscell-get S).  The value is
+;; calculated when it has not been calculated yet, or when one of the
+;; dependencies changed.
+;;
+;; Static dependencies are expressions that are evaluated to check
+;; whether the saved value is still valid.  Whenever one of these
+;; expressions evaluates to a value different from the last time, the
+;; sscell counts as invalid, and any call to `sscell-get' will trigger
+;; a recomputation of the cell value.  "Different value" means not
+;; `eq' by default, but you can also specify a different test
+;; predicate.
+;;
+;; Whenever the calculation of the value of an sscell refers to a
+;; value of another sscell, the value of that other sscell is
+;; remembered as an implicit dependency.  Whenever the cell value of
+;; that second cell changes, the first cell counts as invalid.
+;;
+;; You can change the computation expression of an sscell with
+;; `sscell-set', and also set the value directly with
+;; `sscell-set-value' (which nullifies all dependencies and gives you
+;; something like an "input cell").
+;;
+;; This package also implements let-like binding constructs
+;; `sscell-let' and `sscell-let*'.  These constructs create lazy
+;; bindings using sscells implicitly.  The created bindings are
+;; silently recomputed when referenced and any declared dependencies
+;; changed.
+;;
+;; Examples: ...
+
+
+;;; Code:
+
+(require 'cl-lib)
+(eval-when-compile (require 'subr-x))
+
+
+(defvar sscell--tag (make-symbol "sscell"))
+(defvar sscell--new-dynamic-deps nil)
+(defvar sscell--asking-sscell nil)
+
+(defun sscellp (object)
+  "Return non-nil when the OBJECT is an sscell."
+  (eq (car-safe object) sscell--tag))
+
+(defmacro sscell-make--1 (static-deps rule &optional reuse-cons)
+  ;; Like `sscell-make', but with an additional optional arg REUSE-CONS:
+  ;; When specified, it must be a cons cell C with car sscell--tag, and
+  ;; the return value is the manipulated cons C.
+  (declare (indent 1))
+  (cl-callf or static-deps '(t))
+  (let ((last-result      (make-symbol "last-result"))
+        (last-static-dep-results (make-symbol "last-dep-results"))
+        (new-dep-results  (make-symbol "new-dep-results"))
+        (instruction      (make-symbol "instruction"))
+        (static-tests (cl-maplist
+                       (lambda (more-deps) (let ((dep (car more-deps)))
+                                        (if (not (eq (car-safe dep) :test))
+                                            '#'eq
+                                          (prog1 (nth 1 dep)
+                                            (setcar more-deps (nth 2 dep))))))
+                       static-deps))
+        (dynamic-deps              (make-symbol "dynamic-deps"))
+        (last-dynamic-dep-results  (make-symbol "last-dynamic-dep-results"))
+        (self                      (make-symbol "self"))
+        (cell-invalid-p            (make-symbol "cell-invalid-p"))
+        (get-value                 (make-symbol "get-value"))
+        (arg                       (make-symbol "arg")))
+    `(let ((,get-value (lambda () ,rule))
+           ,last-result
+           (,last-static-dep-results nil)
+           (,dynamic-deps nil)
+           (,last-dynamic-dep-results nil))
+       (let ((,cell-invalid-p
+              (lambda ()
+                (let ((,new-dep-results (list ,@static-deps)))
+                  (unless (and ,last-static-dep-results
+                               (cl-every #'identity
+                                         (cl-mapcar #'funcall (list 
,@static-tests)
+                                                    ,last-static-dep-results 
,new-dep-results))
+                               (cl-every #'identity
+                                         (cl-mapcar #'eq
+                                                    ,last-dynamic-dep-results
+                                                    (mapcar #'sscell-get 
,dynamic-deps))))
+                    ,new-dep-results)))))
+         (let ((,self (or ,reuse-cons (cons sscell--tag nil))))
+           (setcdr ,self
+                   (lambda (,instruction &optional ,arg)
+                     (pcase-exhaustive ,instruction
+                       (:valid?
+                        (if (not (funcall ,cell-invalid-p))
+                            t
+                          (setq ,last-static-dep-results nil)
+                          nil))
+                       (:get
+                        (when sscell--asking-sscell
+                          (add-to-list 'sscell--new-dynamic-deps ,self))
+                        (let ((sscell--asking-sscell ,self)
+                              (sscell--new-dynamic-deps nil))
+                          (when-let ((,new-dep-results (funcall 
,cell-invalid-p)))
+                            (setq ,last-static-dep-results  ,new-dep-results
+                                  ,last-result              (funcall 
,get-value)
+                                  ,dynamic-deps             
sscell--new-dynamic-deps
+                                  ,last-dynamic-dep-results (mapcar 
#'sscell-get ,dynamic-deps))))
+                        ,last-result))))
+           ,self)))))
+
+(defmacro sscell-make (static-deps rule)
+  "Make an sscell.
+STATIC-DEPS is a list of the static dependencies of the sscell.
+A static dependency is either:
+   EXPR
+or
+  (:test TESTFUN EXPR)
+
+RULE is an expression to (re-)calculate the cell value."
+  (declare (indent 1))
+  `(sscell-make--1 ,static-deps ,rule nil))
+
+(defun sscell-get (sscell)
+  (cl-assert (sscellp sscell))
+  (funcall (cdr sscell) :get))
+
+(defun sscell-valid-p (sscell)
+  (cl-assert (sscellp sscell))
+  (funcall (cdr sscell) :valid?))
+
+(defmacro sscell-set (sscell new-static-deps new-rule)
+  `(sscell-make--1 ,new-static-deps ,new-rule ,sscell))
+
+(defun sscell-set-value (sscell value)
+  (sscell-set sscell () value)
+  value)
+
+(gv-define-simple-setter sscell-get sscell-set-value)
+
+(defmacro sscell-let (bindings &rest body)
+  (declare (indent 1) (debug fixme))
+  (cl-callf2 mapcar
+      (pcase-lambda (`(,var ,deps ,binding))
+        (list (make-symbol (concat (symbol-name var) "-sscell"))
+              var deps binding))
+      bindings)
+  `(let ,(mapcar
+          (pcase-lambda (`(,helper-var ,_var ,deps ,binding))
+            `(,helper-var (sscell-make ,deps ,binding)))
+          bindings)
+     (cl-symbol-macrolet
+         ,(mapcar (pcase-lambda (`(,helper-var ,var ,_deps ,_binding))
+                    `(,var (sscell-get ,helper-var)))
+                  bindings)
+       ,@body)))
+
+(defmacro sscell-let* (bindings &rest body)
+  (declare (indent 1) (debug fixme))
+  (cl-reduce
+   (lambda (expr binding) `(sscell-let (,binding) ,expr))
+   (nreverse bindings)
+   :initial-value (macroexp-progn body)))
+
+
+(provide 'sscell)
+
+;;; sscell.el ends here