lenses.el

;;; lenses.el ---                                    -*- lexical-binding: t; -*-

;; Copyright (C) 2019  Eduardo V.

;; Author: Eduardo V. <[email protected]>
;; Keywords:

;; This program 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.

;; This program 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 this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;;

;;; Code:

;; (defun view (&rest lenses)
;;   (let ((lens (make-instance 'view :value `,@lenses)))
;;     (lambda (&optional x)
;;       (if (not x)
;;           lens
;;         (zoom lens x)))))

(defun over (lenses fun record)
  (let ((l (first lenses))
         (r (rest lenses))
         (record record))
    (message "(over '%s %s %s)" lenses fun record)
    (message "lens: %s" l)
    (pcase record
      ((guard (not l))                          ;; out of lenses
        (funcall fun record))                   ;; aply transformer
      ((assoc l v)
        (setf v (over r fun v))
        record
        )
      ((cons l v)
        (setcdr record (over r fun v))
        record)
      (_ record)
      )
    ))

(cl-defgeneric $ (f x))

(cl-defmethod $ (f x)
  (funcall f x))

(defun alistp (sequence)
  (and (listp sequence)
    (every #'consp sequence)))

(pcase-defmacro assoc (ref item)
  `(and (pred alistp)
     (app ref ref)
     (guard ref ,ref)
     (app (-partial 'assq ,ref) item)
     (app item ,item)
     ;; (`(,ref ,item))
     ))

(pcase-defmacro assoc (ref &optional item)
  `(cons ,ref ,item))

(pcase-defmacro assoc (ref &optional item)
  `(and (pred alistp)
     (app ref ___ref)
     (guard (eq ___ref ,ref))
     ,(if ___ref
        `(app ref ,___item)
        t)))

(macroexpand
  (assoc--pcase-macroexpander 'test k))

(over '(test nested one) #'1+
  '((test . 1)
     (nice . ":D")
     (nested . (one . 1))))

(pcase--expand '((test . (fuck . "im gonna get fired")))
  ((assoc 'test v) (message "l:, v:%s" v))
  (t (message "no")))

(pcase '((test . (fuck . "im gonna get fired")))
  (`(,test . ,v) (message "l:, v:%s" v))
  (t (message "no")))

(macroexpand
 (⨇ #'alistp
    'alist
    (let it (assq ,item alist))
    (let value (cdr it))
    (guard it)
    ))

(defun ⨇ (c p v &rest body)
  ""
  (let ((temp (make-symbol "--var--")) (n -1))
    `(let* ((,temp ,form)
            ,@(mapcar (lambda (v)
                        (list v `(nth ,(setq n (1+ n)) ,temp)))
                      vars) )
       `(,c (pred ,p) )
       )
    ))

(pcase-defmacro cons (___car &optional ___cdr)
  `(and (pred consp)
     (app car ___car)
     (guard (eq ___car ,___car))
     ,(if ___car
        `(app cdr ,___cdr)
        t)))

(over '(test) '1+ '((test . 1)))

(pcase (type-of 0)
  ('symbol (message "Got a symbol"))
  ('nil (message "nil"))
  (type (message "unknown type %s :(" type))
  )

(funcall (-partial 'alist-get 'test) '((test . yes)))

(funcall (view '(test nested)) '((test . ((nested . yes)))))

(funcall (view '(test nested)) '((test . ((nested . yes)))))

(<> 'test '((test . ((nested . yes)))))

(funcall
 (<> 'test)
 '((test . 1)))

(funcall
 (view 'test)
 '((test . 1)))

(over
 (<> 'test)
 '1+
 '((test . 1)))

(over
 (view '(test nested))
 '1+
 '((test . ((nested . 1)))))

(funcall (view '(nested test)) '(()))

(funcall (view '(nested test)) '())

(alist-get 'test '((test . yes)))


((let* ((p (if (and nil (not (eq nil 'eq)))
               (assoc 'test var nil)
             (assq 'test var))))
   (if p
       (setcdr p 3)
     (setq var (cons (setq p (cons 'test 3)) var)))))

(defun over (lens cb rec)
  (funcall (funcall lens cb) rec))

(over
 (lambda (cb)
   (lambda (r)
     (cons (funcall cb (car r))
           (cdr r))))
 #'1+
 '(0 2)
 )

(over
 (list 'lambda '(cb)
       (list 'lambda '(r)
             (list 'cons (list 'funcall 'cb
                               (list 'car 'r))
                   (list 'cdr 'r))))
 #'1+
 '(0 2))

(provide 'lenses)
;;; lenses.el ends here