From 5d3b5870b7f4d3a9b9be9ea840b21398fa77241d Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Sat, 4 May 2024 10:19:17 -0700
Subject: renamed

---
 flatbind.asd  |  13 +++++
 flatbind.lisp | 168 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 obwyn.asd     |  13 -----
 obwyn.lisp    | 168 ----------------------------------------------------------
 4 files changed, 181 insertions(+), 181 deletions(-)
 create mode 100644 flatbind.asd
 create mode 100644 flatbind.lisp
 delete mode 100644 obwyn.asd
 delete mode 100644 obwyn.lisp

diff --git a/flatbind.asd b/flatbind.asd
new file mode 100644
index 0000000..fb6d905
--- /dev/null
+++ b/flatbind.asd
@@ -0,0 +1,13 @@
+;;;; flatbind.asd
+
+(asdf:defsystem #:flatbind
+  :description "Syntactic sugar cribbing style from haskell's do syntax."
+  :author "Colin <colin@cicadas.surf>"
+  :license  "Unlicense"
+  :version "0.0.1"
+  :serial t
+  :depends-on (#:argot #:alexandria #:testiere)
+  :components ((:file "flatbind")))
+
+
+
diff --git a/flatbind.lisp b/flatbind.lisp
new file mode 100644
index 0000000..9a76ff3
--- /dev/null
+++ b/flatbind.lisp
@@ -0,0 +1,168 @@
+(defpackage #:flatbind
+  (:use #:cl)
+  (:local-nicknames
+   (#:a #:alexandria-2))
+  (:export #:do>))
+
+(in-package :flatbind)
+
+(defun variablep (thing)
+  (and (symbolp thing) (not (keywordp thing))))
+
+(defun values-binding-p (form)
+  #+testiere
+  (:tests
+   (:is (values-binding-p 'a))
+   (:is (values-binding-p '(a b)))
+   (:is (values-binding-p '()))
+   (:is (not (values-binding-p :x)))
+   (:is (not (values-binding-p '(a b 4))))
+   (:is (not (values-binding-p '(a :b 4)))))
+  (or (variablep form)
+      (and (listp form)
+           (every #'variablep form))))
+
+(defun destructuring-bind-list-p (form)
+  #+testiere
+  (:tests
+   (:is (destructuring-bind-list-p '()))
+   (:is (destructuring-bind-list-p '(a b)))
+   (:is (destructuring-bind-list-p '(a &rest b)))
+   (:is (destructuring-bind-list-p '(a &rest b &key (x 10) y)))
+   (:is (destructuring-bind-list-p '(&optional a b)))
+   (:is (not (destructuring-bind-list-p 'x)))
+   (:is (not (destructuring-bind-list-p '(&rest x &optional y))))
+   (:is (not (destructuring-bind-list-p '(&rest 10 &optional y)))))
+  (and (listp form)
+       (ignore-errors
+        (multiple-value-bind (required optional rest kwargs allow-other aux keyp)
+            (a:parse-ordinary-lambda-list form)
+          (declare (ignorable required optional rest kwargs keyp))
+          (not (or allow-other aux))))))
+
+(defun slot-value-list-p (form)
+  #+testiere
+  (:tests
+   (:is (slot-value-list-p '(a b c)))
+   (:is (slot-value-list-p '((a slot-a))))
+   (:is (slot-value-list-p '()))
+   (:is (not (slot-value-list-p '(1 2))))
+   (:is (not (slot-value-list-p '(:x)))))
+  (and (listp form)
+       (loop :for thing :in form
+             :always (or (variablep thing)
+                         (and (listp thing)
+                              (= 2 (length thing))
+                              (variablep (first thing))
+                              (variablep (second thing)))))))
+
+(defun expand-clauses (clauses)
+  (flet ((collapse-progn (expanded)
+           (if (and (listp expanded) (eq 'cl:progn (first expanded)))
+               (rest expanded)
+               (list expanded)))) 
+    (loop :with expanded := nil
+          :for (tag bindings form) :in (nreverse clauses)
+          :do
+             (setf expanded 
+                   (ecase tag
+                     (:simple
+                      (cond ((null expanded) form)
+                            ((eq 'cl:progn (first expanded))
+                             `(progn ,form ,@(rest expanded)))
+                            (t
+                             `(progn ,form ,expanded))))
+
+                     (:when
+                         (cond ((null expanded) form)
+                               ((eq 'cl:progn (first expanded))
+                                `(when ,form ,@(rest expanded)))
+                               (t
+                                `(when ,form ,expanded))))
+
+                     (:=
+                      `(multiple-value-bind
+                             ,(if (listp bindings) bindings (list bindings))
+                           ,form
+                         ,@(collapse-progn expanded)))
+                     (:when=
+                      `(a:when-let (,bindings ,form) 
+                         ,@(collapse-progn expanded)))
+
+                     (:slots=
+                      `(with-slots ,bindings ,form
+                         ,@(collapse-progn expanded)))
+                     
+                     (:match=
+                      `(destructuring-bind ,bindings ,form
+                         ,@(collapse-progn expanded)))))
+          :finally (return
+                     (if (and (listp expanded) (eq 'cl:progn (first expanded)))
+                         `(block nil ,@(rest expanded))
+                         `(block nil ,expanded))))))
+
+
+(defun literals-equal (a b)
+  (and (symbolp a) (symbolp b) (string-equal a b)))
+
+(argot:deflanguage do> (:literals= #'literals-equal)
+  (<start>
+   :match (:seq (:* <clause>) (:eof))
+   :then (expand-clauses (first <start>)))
+  
+  (<clause>
+   :match (:or <binding-clause>
+               <destructuring-clause>
+               <with-slots-clause>
+               <predicate-binding-clause>
+               <predicate-clause>
+               <simple-clause>)) 
+  
+  (<binding-clause>
+   :match (:seq <values-bind> (:= :=) (:item))
+   :then (destructuring-bind (bindings _ form) <binding-clause>
+           (declare (ignore _))
+           (list := bindings form)))
+
+  (<values-bind>
+   :match (:item)
+   :if values-binding-p
+   :note "Either a symbol or a list suitable for passing to MULTIPLE-VALUE-BIND")
+  
+  (<destructuring-clause>
+   :match (:seq <destructuring-list> (:= :match=) (:item))
+   :then (destructuring-bind (bindings _ form) <destructuring-clause>
+           (declare (ignore _))
+           (list :match= bindings form)))
+  
+  (<destructuring-list>
+   :match (:item)
+   :if destructuring-bind-list-p
+   :note "An list that might be passed as the first argument to DESTRUCTURING-BIND.")
+  
+  (<with-slots-clause>
+   :match (:seq <slot-value-list> (:= :slots=) (:item))
+   :then (destructuring-bind (bindings _ form) <with-slots-clause>
+           (declare (ignore _))
+           (list :slots= bindings form)))
+  
+  (<slot-value-list>
+   :match (:item)
+   :if slot-value-list-p
+   :note "A list that is suitable for passing to with-slots.")
+  
+  (<predicate-binding-clause>
+   :match (:seq (:@ var (:item)) (:= :when=) (:@ form (:item)))
+   :if (variablep var)
+   :then (list :when= var form)
+   :note "Bind variable to form, exit early if form evaluated to nil.")
+  
+  (<predicate-clause>
+   :match (:seq (:= :when) (:item))
+   :then (list :when nil (second <predicate-clause>)))
+  
+  (<simple-clause>
+   :match (:@ simple (:item))
+   :if (not (member simple '(:when= :match= :when := :slots=) :test #'literals-equal))
+   :then (list :simple nil simple)))
+
diff --git a/obwyn.asd b/obwyn.asd
deleted file mode 100644
index 1aa0693..0000000
--- a/obwyn.asd
+++ /dev/null
@@ -1,13 +0,0 @@
-;;;; obwyn.asd
-
-(asdf:defsystem #:obwyn
-  :description "Only Bind When You Need"
-  :author "Colin <colin@cicadas.surf>"
-  :license  "Unlicense"
-  :version "0.0.1"
-  :serial t
-  :depends-on (#:argot #:alexandria #:testiere)
-  :components ((:file "obwyn")))
-
-
-
diff --git a/obwyn.lisp b/obwyn.lisp
deleted file mode 100644
index 70a1772..0000000
--- a/obwyn.lisp
+++ /dev/null
@@ -1,168 +0,0 @@
-(defpackage #:obwyn
-  (:use #:cl)
-  (:local-nicknames
-   (#:a #:alexandria-2))
-  (:export #:do>))
-
-(in-package :obwyn)
-
-(defun variablep (thing)
-  (and (symbolp thing) (not (keywordp thing))))
-
-(defun values-binding-p (form)
-  #+testiere
-  (:tests
-   (:is (values-binding-p 'a))
-   (:is (values-binding-p '(a b)))
-   (:is (values-binding-p '()))
-   (:is (not (values-binding-p :x)))
-   (:is (not (values-binding-p '(a b 4))))
-   (:is (not (values-binding-p '(a :b 4)))))
-  (or (variablep form)
-      (and (listp form)
-           (every #'variablep form))))
-
-(defun destructuring-bind-list-p (form)
-  #+testiere
-  (:tests
-   (:is (destructuring-bind-list-p '()))
-   (:is (destructuring-bind-list-p '(a b)))
-   (:is (destructuring-bind-list-p '(a &rest b)))
-   (:is (destructuring-bind-list-p '(a &rest b &key (x 10) y)))
-   (:is (destructuring-bind-list-p '(&optional a b)))
-   (:is (not (destructuring-bind-list-p 'x)))
-   (:is (not (destructuring-bind-list-p '(&rest x &optional y))))
-   (:is (not (destructuring-bind-list-p '(&rest 10 &optional y)))))
-  (and (listp form)
-       (ignore-errors
-        (multiple-value-bind (required optional rest kwargs allow-other aux keyp)
-            (alexandria:parse-ordinary-lambda-list form)
-          (declare (ignorable required optional rest kwargs keyp))
-          (not (or allow-other aux))))))
-
-(defun slot-value-list-p (form)
-  #+testiere
-  (:tests
-   (:is (slot-value-list-p '(a b c)))
-   (:is (slot-value-list-p '((a slot-a))))
-   (:is (slot-value-list-p '()))
-   (:is (not (slot-value-list-p '(1 2))))
-   (:is (not (slot-value-list-p '(:x)))))
-  (and (listp form)
-       (loop :for thing :in form
-             :always (or (variablep thing)
-                         (and (listp thing)
-                              (= 2 (length thing))
-                              (variablep (first thing))
-                              (variablep (second thing)))))))
-
-(defun expand-clauses (clauses)
-  (flet ((collapse-progn (expanded)
-           (if (and (listp expanded) (eq 'cl:progn (first expanded)))
-               (rest expanded)
-               (list expanded)))) 
-    (loop :with expanded := nil
-          :for (tag bindings form) :in (nreverse clauses)
-          :do
-             (setf expanded 
-                   (ecase tag
-                     (:simple
-                      (cond ((null expanded) form)
-                            ((eq 'cl:progn (first expanded))
-                             `(progn ,form ,@(rest expanded)))
-                            (t
-                             `(progn ,form ,expanded))))
-
-                     (:when
-                         (cond ((null expanded) form)
-                               ((eq 'cl:progn (first expanded))
-                                `(when ,form ,@(rest expanded)))
-                               (t
-                                `(when ,form ,expanded))))
-
-                     (:=
-                      `(multiple-value-bind
-                             ,(if (listp bindings) bindings (list bindings))
-                           ,form
-                         ,@(collapse-progn expanded)))
-                     (:when=
-                      `(a:when-let (,bindings ,form) 
-                         ,@(collapse-progn expanded)))
-
-                     (:slots=
-                      `(with-slots ,bindings ,form
-                         ,@(collapse-progn expanded)))
-                     
-                     (:match=
-                      `(destructuring-bind ,bindings ,form
-                         ,@(collapse-progn expanded)))))
-          :finally (return
-                     (if (and (listp expanded) (eq 'cl:progn (first expanded)))
-                         `(block nil ,@(rest expanded))
-                         `(block nil ,expanded))))))
-
-
-(defun literals-equal (a b)
-  (and (symbolp a) (symbolp b) (string-equal a b)))
-
-(argot:deflanguage do> (:literals= #'literals-equal)
-  (<start>
-   :match (:seq (:* <clause>) (:eof))
-   :then (expand-clauses (first <start>)))
-  
-  (<clause>
-   :match (:or <binding-clause>
-               <destructuring-clause>
-               <with-slots-clause>
-               <predicate-binding-clause>
-               <predicate-clause>
-               <simple-clause>)) 
-  
-  (<binding-clause>
-   :match (:seq <values-bind> (:= :=) (:item))
-   :then (destructuring-bind (bindings _ form) <binding-clause>
-           (declare (ignore _))
-           (list := bindings form)))
-
-  (<values-bind>
-   :match (:item)
-   :if values-binding-p
-   :note "Either a symbol or a list suitable for passing to MULTIPLE-VALUE-BIND")
-  
-  (<destructuring-clause>
-   :match (:seq <destructuring-list> (:= :match=) (:item))
-   :then (destructuring-bind (bindings _ form) <destructuring-clause>
-           (declare (ignore _))
-           (list :match= bindings form)))
-  
-  (<destructuring-list>
-   :match (:item)
-   :if destructuring-bind-list-p
-   :note "An list that might be passed as the first argument to DESTRUCTURING-BIND.")
-  
-  (<with-slots-clause>
-   :match (:seq <slot-value-list> (:= :slots=) (:item))
-   :then (destructuring-bind (bindings _ form) <with-slots-clause>
-           (declare (ignore _))
-           (list :slots= bindings form)))
-  
-  (<slot-value-list>
-   :match (:item)
-   :if slot-value-list-p
-   :note "A list that is suitable for passing to with-slots.")
-  
-  (<predicate-binding-clause>
-   :match (:seq (:@ var (:item)) (:= :when=) (:@ form (:item)))
-   :if (variablep var)
-   :then (list :when= var form)
-   :note "Bind variable to form, exit early if form evaluated to nil.")
-  
-  (<predicate-clause>
-   :match (:seq (:= :when) (:item))
-   :then (list :when nil (second <predicate-clause>)))
-  
-  (<simple-clause>
-   :match (:@ simple (:item))
-   :if (not (member simple '(:when= :match= :when := :slots=) :test #'literals-equal))
-   :then (list :simple nil simple)))
-
-- 
cgit v1.2.3