From 409eb8e52adc8cdf0e961998661f81be66b11052 Mon Sep 17 00:00:00 2001 From: Vincent Toups Date: Wed, 11 May 2011 20:59:45 -0400 Subject: [PATCH] defn-readme, docs --- binders | 4 + defn-readme.md | 135 ++++++++++++ defn.el | 299 +++++++++++++++++-------- defn.elc | Bin 17837 -> 23423 bytes loel.el | 112 +++++++++- monad-parse.el | 210 +++++++++++------- parse-seq-binder.el | 182 ++++++++------- parse-table-binder.el | 25 +++ parser-pres/just-elisp.el | 449 ++++++++++++++++++++++++++++++++++++-- parser-pres/page-10.el | 17 +- parser-pres/page-12.el | 23 +- parser-pres/page-13.el | 9 +- parser-pres/page-14.el | 86 +++++++- parser-pres/page-15.el | 34 +++ streams.el | 13 +- streams.elc | Bin 26122 -> 27065 bytes utils.el | 10 +- utils.elc | Bin 76158 -> 76619 bytes 18 files changed, 1289 insertions(+), 319 deletions(-) create mode 100644 binders create mode 100644 defn-readme.md create mode 100644 parser-pres/page-15.el diff --git a/binders b/binders new file mode 100644 index 0000000..a95d799 --- /dev/null +++ b/binders @@ -0,0 +1,4 @@ +defn.el:(defun forms->binders (fs) +defn.el:(defun forms->expressions (fs) +utils.el:(defmacro let-repeatedly (name &rest forms-to-apply) +utils.el: forms-to-apply) diff --git a/defn-readme.md b/defn-readme.md new file mode 100644 index 0000000..8657eeb --- /dev/null +++ b/defn-readme.md @@ -0,0 +1,135 @@ +A Guided Tour of an Implementation +================================== +of Clojure Destructuring Bind +============================= +in Emacs Lisp +------------- + +### Introduction ### + +Clojure is a new (relatively) Lisp variant which has attracted a lot +of attention due to its modern features and close relationship with +the JVM. Emacs Lisp is a lisp so antiquated that it attracts more +ridicule than plaudits. This document describes an attempt to bring +some of the nicer syntactical (and one semantic) features from Clojure +into Elisp. + +### Destructuring Bind ### + +Clojure owes a certain debt to the statically typed functional +languages. It's emphasis on Lazy values references languages like +Haskell, and is destructuring bind forms refer to the pattern matching +(efficiently) afforded by static type systems like those in Standard +ML and its variants. Destructuring bind has, of course, appeared in +places like Lua and Python, where simple tuples can be destructured, +but Clojure's support is somewhat more extensive in that it supports +generic destructuring of sequences and tables. In Scheme (for +instance) we might wish to swap two numbers held in the first and +second slot of a list. + + (define swap (lst) + (list (cadr lst) (car lst))) + +In Clojure we could specify how to extract values from the arguments +of a function right in the function definition: + + (defn swap [[a b]] (list a b)) + +(Clojure's binding forms are by convention represented by vectors.) +Here SWAP takes only one argument, but it binds two names. The inner +`[a b]` expression indicates that the single argument is expected to +be a list, and that its first and second values should be bound to the +symbols `a` and `b` respectively. Clojure's destructuring bind +supports recursive binding forms. If, for instance, we wanted to +write a function which accepts a single list, whose second element is +a list, whose first value we wish to extract, we could write: + + (defn extract [[_ [a]]] a) + +Where we have nested the destructuring deep into the sequence to pull +out `a`. Error checking aside, this is a pretty nice feature, +particularly because Clojure _also_ allows destructuring on tables, +which have their own source-level representation. To write a function +which pulls out the values in a table located at keys `:x` and `:y` +and returns them in a flat list, we can write: + + (defn extract [{a :x b :y}] (list a b)) + +Suppose the value at `x` were a list and we wished to get its second +element: + + (defn extract [{[_ part] :x}] part) + +Would do the trick. We can combine, recursively, table and sequence +destructuring syntax. This project is an implementation of this +feature in Emacs Lisp. + +### Bonus Material: Recur ### + +Tail call optimization is a controversial subject in some arenas. The +feature was somewhat famously kept out of Python by its "dictator for +life." Scheme implementations, on the other hand, are required to +suppor this feature. Clojure takes a middle path (more for reasons +related to the JVM than any political sensitivity): tail calls to +"oneself" can be made by virtue of an explicit form, `recur`, which +resembles a function call but can only be invoked from tail position, +and which reuses the current stack frame instead of creating a new +one. This allows many basic algorithms which depend on tail calls for +elegant expression to be written naturallly in Clojure. + +This library also allows the use of a `recur` special form, statically +checked to be only from tail position. + +### Syntactic Notes & Front Matter ### + +Clojure supports tables at the level of source code via a curly braces +notation: + + {:x 10 :y 11} + +Would be the table with keys `:x`, `:y` pointing to 10 and 11 +respectively. Unfortunately, Emacs Lisp does not provide facilities +to extend the reader, which would could use to create a syntax for +tables if we were using (say) Common Lisp. We'll be using a mildly +ad-hoc solution. My standard library provides functions to create +tables succinctly: + + (tbl! :x 10 :y 11) + +Is equivalent to the above Clojure. For destructuring we will use a +vector to represenent sequences (`[a b c]`) and a vector with a +special head token to represent tables (`[:: a :x b :y]`). That is, +`::` indicates an expression represents a table, rather than sequence +destructuring. + +Additionally, we'll allow the table syntax to destructure +association-lists, since these are common table surrogates in other +lisp dialects and because they can be made persistant (as data +structures) more easily than Emacs Lisp's tables. + +Finally, this implementation uses a few non-standard special forms +from my standard library which bear remarking upon. The form +`let-seq`, defined in `utils.el` is a simple form for destructuring +lists. It creates a context where a series of symbols are bound to +the values in a list: + + (let-seq (a b c) (list 3 2 1) + (list a b c)) + +Evaluates to '(1 2 3). + +The form `let-tbl` allows a very simple form of table destructuring. + + (let-tbl + ((x :a) + (y :b)) + (tbl! :a 10 :b 11) + (+ x y)) + +Evaluates to 21. The implementation makes use of other functions in +the `utils.el` library, but these are the most conspicuous departures +from recognizeable lisp. + + + + diff --git a/defn.el b/defn.el index 5faf1db..1525620 100644 --- a/defn.el +++ b/defn.el @@ -3,9 +3,15 @@ (require 'parse-table-binder) (require 'parse-seq-binder) -(setq currently-defining-defn 'lambda) +(defvar currently-defining-defn 'lambda + "The function we are currently defining. Useful for + informative error messages.") (defun binder->type (f) + "Inspect a binding form to determine its binder type. +Empty vectors, and vectors whose first element is not :: indicate a sequence. +Vectors whose first element is :: indicate a table (either a hash or an alist). +Other forms produce an error." (cond ((and (vectorp f) @@ -20,19 +26,21 @@ :tbl) (t (error "Unrecognized form type")))) -(defun forms->binders (fs) - (loop for i from 0 below (length fs) - when (evenp i) - collect (elt fs i))) -(defun forms->expressions (fs) - (loop for i from 0 below (length fs) - when (oddp i) - collect (elt fs i))) - (defun wrap-or-form (form) + "Or expressions are evaluated at call-time, +and are hence delayed with a lambda expression." `(lambda () ,form)) (defun handle-seq-binder (binder expr previous-lets) + "This function takes a binding expression (BINDER) and a series +of value-producing expressions (EXPR) and produces a list of +name-expression pairs which represents that destructuring. These +will be further expanded if necessary, but finally inserted into +a `let*` form. The body of that let form will be a scope where +the indicated bindings are made. + +PREVIOUS-LETS allows this function to be called in situations +where binding forms need to be accumulated." (let-seq (sub-binders rest-form as-sym or-form) (parse-and-check-seq-binder binder) (if (not as-sym) (setf as-sym (gensym (format "%s-seq-as-sym" currently-defining-defn)))) @@ -69,24 +77,36 @@ ; (handle-seq-binder [a b c d :or [1 2 3 4]] '(list 1 2 3 4) '()) ; (handle-seq-binder [] '() '()) -;; (defun table-like-get (tbl-like kw) -;; (cond ((hash-table-p tbl-like) (tbl tbl-like kw)) -;; ((listp tbl-like) (cadr (assq kw tbl-like))))) -;; (defun* table-like-get-or (tbl-like kw &optional (or-val nil)) -;; (cond ((hash-table-p tbl-like) (tbl-or tbl-like kw or-val)) -;; ((listp tbl-like) -;; (let ((v (assoc-default kw tbl-like #'eq nil))) -;; (if v (car v) or-val))))) - (dont-do - (table-like-get (tbl! :x 10 :y 10) :x) - (table-like-get-or (tbl! :x 10 :y 10) :z 'z) - (table-like-get (alist>> :x 20 :y 30) :x) - (table-like-get-or (alist>> :x 20 :y 50) :x 'z) - (cadr (assoc-default :x '((:x 10) (:y 20))))) + ;;; These `dont-d` expressions are not evaluated when the file is loaded, + ;;; but usually contain the equivalent of unit tests. + (handle-seq-binder [x] '(1) '()) + + (handle-seq-binder [x [a b]] '(list 1 (list 1 2)) '()) + ;; ([lambda-seq-as-sym99989 (list 1 (list 1 2))] + ;; [x (elt lambda-seq-as-sym99989 0)] + ;; [lambda-seq-as-sym99995 (elt lambda-seq-as-sym99989 1)] + ;; [a (elt lambda-seq-as-sym99995 0)] + ;; [b (elt lambda-seq-as-sym99995 1)]) + +;;; Example above: [x [a b]] indicates we wish to destructure a list +;;; containing at least two elements, the second of which should be +;;; further destructured into the variables `a` and `b`. + +;;; The output should be read as binding expressions in a let: first +;;; we bind the whole input expression to a hidden variable then we +;;; bind x to the first element of that value then we bind the inner +;;; list to another hidden variable then bind a and b to the car and +;;; cadr of that value. We use the generic function from cl.el, elt, +;;; so that sequences (lists, strings, vectors) can be destructured by +;;; the same syntax. + ) (defun handle-tbl-binding (binder expr previous-lets) + "Handle destructuring a table expression (BINDER) on the +expression EXPR. PREVIOUS-LETS allow this function to take an +accumulation variable." (let-seq (sub-binders keys as-sym @@ -116,19 +136,38 @@ (handle-binding sym `(table-like-get ,as-sym ,kw)) (handle-binding sym `(table-like-get-or ,as-sym ,kw (table-like-get ,or-form-name ,kw))))))))) - ; (handle-tbl-binding [:: [a b] :x y :y :as table :or (tbl! :x [1 2])] '(tbl 'x 10 'y 11) '()) - ; (handle-tbl-binding [:: [a b :as q] :x :keys [y z]] '(tbl :x 10 :y 11 :z 14) '()) +(dont-do + (handle-tbl-binding [:: [a b] :x y :y] '(tbl 'x 10 'y 11) '()) + ;; ( + ;; [lambda-as-symbol38977 (tbl (quote x) 10 (quote y) 11)] + ;; [lambda-seq-as-sym38983 (table-like-get lambda-as-symbol38977 :x)] + ;; [a (elt lambda-seq-as-sym38983 0)] + ;; [b (elt lambda-seq-as-sym38983 1)] + ;; [y (table-like-get lambda-as-symbol38977 :y)]) + +;;; Table binding is somewhat more complex. [:: [a b] :x ] means: +;;; "destructure a table by binding a and b to the sequence stored in +;;; the :x slot of of the table, and then bind y to the value stored +;;; in the :y slot. + ) (defun* handle-binding (binder expr &optional (previous-lets '())) - (case (binder->type binder) + "Handle binding orchestrates symbol, table and sequence binding +operations. BINDER is the binding expression, and previous-lets +allows this function to take an accumulation of let bindings. +This is not used here, but is used when called recursively." + (case (binder->type binder) (:symbol (append previous-lets (list (vector binder expr)))) + ;symbol binding is trivial. (:seq (handle-seq-binder binder expr previous-lets)) (:tbl (handle-tbl-binding binder expr previous-lets)))) ; (handle-binding [a [:: [a b :as lst] :s :as table] & rest] 10) (defun package-dlet-binders (pairs) + "Converts a set of [bindexpr expr] pairs into a pair + [bind-expressions expressions] so that it can be used by handle-binding." (let ((n (length pairs)) (binders '()) (exprs '())) @@ -140,26 +179,26 @@ return (list (coerce (reverse binders) 'vector) (cons 'list (reverse exprs)))))) + (defun pairs->dlet-binding-forms (pairs) + "Convert the output of `handle-binding` to forms appropriate +for a regular `let*` expression." (mapcar (lambda (x) (coerce x 'list)) (apply #'handle-binding (package-dlet-binders pairs)))) - ; (package-dlet-binders [x 10 y 11 [a b] '(1 2)]) - ; (cl-prettyprint (pairs->dlet-binding-forms [x 10 y 11 [a b] '(1 2)])) - - - ; (apply #'append (mapcar #'handle-binding (package-dlet-binders [x 10 y 11]))) - - (defun split-after-two (lst) + "Split LST after two elements." (list (elts lst (range 2)) (elts lst (range 2 (length lst))))) - ; (split-after-two '(1 2)) - ; (split-after-two '(1 2 3 4 5 6 7 8)) - ; (split-after-two [1 2 3 4 5 6]) - (defmacro* dlet (pairs &body body) + "Clojure-style destructuring let expression. + (DLET [bind-form bind-val ...] body) destructures the values + BIND-VAL via BIND-FORMS and executes BODY in a context where the + symbols in BIND-FORMs are defined. + +This macro provides a lexical-scope for the bound variables. Use +dlet_ for a dynamic scope." (declare (indent 1)) (cond ((= 0 (length pairs)) @@ -172,6 +211,7 @@ ,@body)))))) (defmacro* dlet_ (pairs &body body) + "Identical to DLET except variables in BIND-FORMS are bound dynamically." (declare (indent 1)) (cond ((= 0 (length pairs)) @@ -183,20 +223,8 @@ (dlet ,(list->vector rest) ,@body)))))) -(defun* build-dsetq* (pairs &optional (output (list 'progn))) - (if (= (length pairs) 0) (reverse output) - (let-seq (first-pair rest) (split-after-two pairs) - (let ((forms - (mapcar - (lambda (x) (cons 'setq x)) - (pairs->dlet-binding-forms (list->vector first-pair))))) - (build-dsetq* rest (append (reverse forms) output)))))) - -(defmacro* dsetq* (&rest pairs) - (if (oddp (length pairs)) (error "dsetq needs an even number of elements.") - (build-dsetq* pairs))) - (defun build-dsetq (pairs) + "Build a dsetq expansion form." (let* ((val-forms (loop for form in pairs and i from 0 when (oddp i) collect form)) (binders (loop for form in pairs and i from 0 when (evenp i) collect form)) (names (loop for i from 0 below (length val-forms) collect @@ -218,16 +246,25 @@ (defmacro* dsetq (&rest pairs) + "PAIRS is a series of BIND-EXPR VALUE doublets, in a flat list. +Set the symbols indicated in BIND-EXPRs to the values indicated +in VALUEs with Clojure-style destructuring." (if (oddp (length pairs)) (error "dsetq needs an even number of elements.") (build-dsetq pairs))) ; (dlet [[a b] (list 10 10) y 11] (+ a b y)) ; (dlet [[x y :as z] (list 1 2) b (+ x y)] (list x y b z)) (defun generate-defn-exprs (arg-nam n) + "Generate forms extracting the NTH element of ARG-NAME. +Because top-level destructuring of `defn` forms is always +sequential, we can get away with this." (loop for i from 0 below n collect `(elt ,arg-nam ,i))) (defun binder-arity (binder) + "Given a BINDER expression, calculate the arity of the function +as either (N exactly) or (N +MORE). Used to dispatch FN and DEFN +expressions to the appropriate body based on function arity." (let-seq (sub-binders rest-form @@ -240,6 +277,10 @@ ; (binder-arity [a b c]) (defun arity-match (n arity) + "Given N and an ARITY, determine if N matches that ARITY. If +ARITY is exact and numericall equal to N, match. If ARITY is ++MORE and n is greater than or equal to ARITY's value, match. +-LESS is unused as yet (Clojure does not suppor this)." (let ((magnitude (car arity)) (modifier (cadr arity))) (cond @@ -251,6 +292,7 @@ (<= n magnitude))))) (defun arity-comparitor (arity1 arity2) + "Compare two arities. Handles EXACTLY, +MORE and -LESS correctly." (let-seq (mag1 mod1) arity1 (let-seq (mag2 mod2) arity2 (cond @@ -285,9 +327,11 @@ ; (arity-comparitor '(3 exactly) '(1 +more)) (defun sort-arities (lst) + "Sort arities." (sort* lst #'arity-comparitor)) (defun random-arity () + "Produce a random ARITY value (for testing)." (let ((mods '(exactly +more -less))) (list (random 20) (elt mods (random 3))))) @@ -305,20 +349,43 @@ ; (arity-match 2 '(3 +more)) -(setq currently-defining-defn 'lambda) - - - (defun gen-fn-rec-binding (binders args-sym) + "Generates binding forms for DSETQ expressions in a recur." (vector (coerce binders 'vector) args-sym)) (defmacro* fnc (&rest rest) + "Version of FN which compiles itself before returning. Useful +sometimes." `(byte-compile (fn ,@rest))) (defmacro* fnc_ (&rest rest) + "Version of FN_ which compiles itself before returning. _ +indicates that this macro creates dynamic variable bindings." `(byte-compile (fn_ ,@rest))) (defmacro* fn (&rest rest) - "Clojure-style destructuring lambda (funcall (fn [[x y & r]] (list x y r)) '(1 2 3 4 5 6)) -> (1 2 (3 4 5 6))." + "Clojure-style destructuring lambda. + Example: (funcall (fn [[x y & r]] (list x y r)) '(1 2 3 4 5 6)) + -> (1 2 (3 4 5 6)). Supports dispatch to bodies based on input + arity and full, recursive destructuring. Lists are destructured + using [a b c] style expressions, while tables are destructured + using [:: symbol key ... ] expressions. + +Both lists and tables support the :or keyword, which specifies a +table or a list respectively to destructure if a desired element +is not in the passed in structure. + +The keyword :as indicates that a structure itself should be given +a name. + +The expression (RECUR ...) inside the body, in tail position +only, will simulate a tail self-recursion. If the RECUR is not +in tail position, an error is generated at parse time. Recur +otherwise has function call semantics (although APPLY #'recur is +not supported). + +See DEFN for more extensive examples. + +" (cond ((vectorp (car rest)) `(fn (,(car rest) ,@(cdr rest)))) @@ -364,7 +431,7 @@ currently-defining-defn)))) (defmacro* fn_ (&rest rest) - "Clojure-style destructuring lambda (funcall (fn [[x y & r]] (list x y r)) '(1 2 3 4 5 6)) -> (1 2 (3 4 5 6)). Non-lexical binding version." + "See FN. This macro is identical except it binds its variables with a dynamic scope." (cond ((vectorp (car rest)) `(fn_ (,(car rest) ,@(cdr rest)))) @@ -410,6 +477,9 @@ currently-defining-defn)))) (defun extract-interactive-and-return (forms) + "Determines if a DEFN form declares itself INTERACTIVE and +strips that declaration out, returning it and the new DEFN +expression. Needed to support INTERACTIVE defns." (loop with interactives = nil and @@ -423,13 +493,59 @@ (return (list (reverse interactives) (reverse outforms))))) (defmacro defunc (&rest rest) + "DEFUNC defines, then compiles, a function. Syntactically +identical to a regular DEFUN." (let ((retsym (gensym "defunc-val"))) `(let ((,retsym (defun ,@rest))) (byte-compile ',(car rest)) ,retsym))) (defmacro* defn (name &rest rest) - "Clojure-style function definition. Supports recur and destructuring bind." + "Clojure-style function definition. Supports recur and destructuring bind. +The argument list is a VECTOR of Symbols, +Table-binding-expressions ([:: ...]) or sequence binding +expressions [...]. + +For example: + + (defn example [a b c] (list a b c)) + +takes three arguments and returns a list of each. + + (defn example [[a b] c] (list a b c)) + +Takes two arguments, the first of which is a list, whose first +and second values are bound to a and b respectively. The second +is bound to c, and these values are returned. + + (defn example [[:: a :x b :y :as c]] (list a b c)) + +Takes ONE argument, a table, and binds a to the value at :x, b to +the value at :y, and c to the able itself, returning a list of +the three. The :as keyword works on lists also. + + (defn example [& rest] rest) + +Takes an unlimited number of arguments and returns them as a list. + +DEFN can dispatch on arity at call time. For instance + + (defn prod ([[head & tail :as lst] acc] + (if lst (recur tail (* acc head)) + acc)) + ([lst] + (prod lst 1))) + + (prod '(1 2 3 4 5)) ;-> 120 + +Takes either two arguments (first clause) or one +argument (second). The second calls PROD with an additional +argument. Within the body of PROD, RECUR is used to repeatedly +call PROD without growing the stack, finally returning the result +of multiplying the items of LST. This example also uses nested +destructuring and the :as keyword. + +" (declare (indent defun)) (let-seq (interactives clean-rest) (extract-interactive-and-return rest) (if ($ (length interactives) > 1) (error "Too many interactive forms in %s." name)) @@ -441,7 +557,7 @@ (apply ,undername ,args))))))) (defmacro* defn_ (name &rest rest) - "Clojure-style function definition. Supports recur and destructuring bind. Non-lexical binding version." + "See DEFN. This is identical except variables specified in NAME are bound dynamically." (declare (indent defun)) (let-seq (interactives clean-rest) (extract-interactive-and-return rest) (if ($ (length interactives) > 1) (error "Too many interactive forms in %s." name)) @@ -456,36 +572,50 @@ ;(binder->type []) ;(defn defn-test ([x] (+ x 1))) +;;; We need a set of functions for controlling the codewalker which expands RECUR. + (defun ifp (form) + "True of FORM is an IF expression." (and (listp form) (eq (car form) 'if))) (defun condp (form) + "True if a form is a COND expression." (and (listp form) (eq (car form) 'cond))) (defun casep (form) + "True if a form is a CASE expression." (and (listp form) (eq (car form) 'case))) (defun recurp (form) + "True if the head of a form is RECUR." (and (listp form) (eq (car form) 'recur))) (defun prognp (form) + "True if a form is a PROGN form." (and (listp form) (eq (car form) 'progn))) -(defun expand-recur-cond-pair (cond-pair parent-is-tale loop-sentinal binding-forms) +(defun expand-recur-cond-pair (cond-pair parent-is-tail loop-sentinal binding-forms) + "Expand a pair in a COND expression." `(,(car cond-pair) - ,@(cdr (expand-recur `(progn ,@(cdr cond-pair)) parent-is-tale loop-sentinal binding-forms)))) -;; (defun expand-recur-recur (form parent-is-tale loop-sentinal binding-forms) + ,@(cdr (expand-recur `(progn ,@(cdr cond-pair)) parent-is-tail loop-sentinal binding-forms)))) +;; (defun expand-recur-recur (form parent-is-tail loop-sentinal binding-forms) ;; `(progn ;; (setq ,loop-sentinal t) ;; (dsetq ,@(loop for b in (coerce binding-forms 'list) and v in (cdr form) ;; collect b and collect v)))) -(defun expand-recur-recur (form parent-is-tale loop-sentinal binding-forms) +(defun expand-recur-recur (form parent-is-tail loop-sentinal binding-forms) + "Actuall expand a RECUR expression into a set expression. PARENT-IS-TAIL must be true. +LOOP-SENTINAL is the symbol which determines if the recursion +continues. BINDING-FORMS are expeanded into a set statement." + (if parent-is-tail `(progn (setq ,loop-sentinal t) - (dsetq ,@binding-forms (list ,@(cdr form))))) - + (dsetq ,@binding-forms (list ,@(cdr form)))) + (error "Recur expression \"%S\" not in tail position in %s." form currently-defining-defn))) (defun let-likep (form) + "Detect let-like forms (let, flet, labels, lexical-let, +lexical-let*.)" (and (listp form) form (let ((f (car form))) @@ -497,14 +627,15 @@ (eq f 'lexical-let*) (eq f 'let*))))) -(defun* expand-recur (form parent-is-tale loop-sentinal binding-forms &optional (single-arg-recur nil)) +(defun* expand-recur (form parent-is-tail loop-sentinal binding-forms &optional (single-arg-recur nil)) + "Recursively search for and expand RECUR forms in FORM, appropriately setting the LOOP-SENTINAL." (let ((mxform (macroexpand form))) (cond ((symbolp mxform) mxform) ((numberp mxform) mxform) ((stringp mxform) mxform) ((arrayp mxform) mxform) ((listp mxform) - (case parent-is-tale + (case parent-is-tail (nil mxform) (t (cond @@ -518,7 +649,7 @@ (lambda (cond-pair) (expand-recur-cond-pair cond-pair - parent-is-tale + parent-is-tail loop-sentinal binding-forms)) (cdr mxform)))) @@ -528,7 +659,7 @@ (lambda (cond-pair) (expand-recur-cond-pair cond-pair - parent-is-tale + parent-is-tail loop-sentinal binding-forms)) (cddr mxform)))) @@ -549,14 +680,16 @@ ((recurp mxform) (if single-arg-recur (expand-recur-recur `(recur (list ,@(cdr mxform))) - parent-is-tale loop-sentinal binding-forms) - (expand-recur-recur mxform parent-is-tale loop-sentinal binding-forms))) + parent-is-tail loop-sentinal binding-forms) + (expand-recur-recur mxform parent-is-tail loop-sentinal binding-forms))) (t (progn (if (> (length (filter (lambda (x) (and (symbolp x) (eq 'recur x))) (flatten mxform))) 0) (error (format "Can't recur from a non-tail position in %s" mxform))) mxform))))))))) (defmacro* dloop-single-arg (bindings &body body) + "Suppport form for recursive looping. Similar to dlet or dloop +but takes only a single binding expression." (let ((loop-sentinal (gensym "loop-sentinal")) (return-value (gensym "return-value")) (binding-parts (loop for el in (coerce bindings 'list) and i from 0 @@ -571,6 +704,7 @@ ,return-value)))) (defmacro* dloop-single-arg_ (bindings &body body) + "See dloop-single-arg_. This version creates a dynamic scope instead." (let ((loop-sentinal (gensym "loop-sentinal")) (return-value (gensym "return-value")) (binding-parts (loop for el in (coerce bindings 'list) and i from 0 @@ -586,6 +720,9 @@ (defmacro* dloop (bindings &body body) + "Equivalent of a clojure LOOP form. Syntactically identical to +a LET expression, but RECUR calls the loop form as if it were a function. +Bindings support full destructuring." (let ((loop-sentinal (gensym "loop-sentinal")) (return-value (gensym "return-value")) (binding-parts (loop for el in (coerce bindings 'list) and i from 0 @@ -600,6 +737,7 @@ ,return-value)))) (defmacro* dloop_ (bindings &body body) + "See DLOOP. Dynamic version." (let ((loop-sentinal (gensym "loop-sentinal")) (return-value (gensym "return-value")) (binding-parts (loop for el in (coerce bindings 'list) and i from 0 @@ -616,22 +754,5 @@ (provide 'defn) - - ; (defn f (x x) ([a b] (+ a b) )) - - ; (defn a-test-f [x y [:: z :z :as a-tble :as eh]] (list (+ x y z) a-tble)) - ; (defn a-test-f [x y [:: z :z :as a-tble]] (list (+ x y z) a-tble)) - ; (a-test-f 1 2 (tbl! :z 10)) - ; (f 1 2 3) - ; (defn f ([z a] (* z a)) (x x) ) - - ; (defn f [z [:: a :a :as a-table :or (tbl! :a 100)]] (list z a)) - ; (f 10 (tbl!)) - - ; (defn f [z [:: :keys [a b c]]] (list z (+ a b c))) - ; (f 10 (tbl! :a 1 :b 2 :c 3)) - - ; (defn f [a b [x y z :or [1 2 3]]] (+ a b x y z)) - ; (f 1 2 [4]) - ; (defn f [a b c :or [1 2 3]] (+ a b c)) +; provide defn and friends to the world. diff --git a/defn.elc b/defn.elc index 509b682e4dd5aae4cf1454d26012d5d8de041233..433ba4a5a721363bd3f3a1ae1d68ac7326ab6db5 100644 GIT binary patch delta 8145 zcma)B+m9sYRcDrUY?p0p2V%+Ijpyv_Cev+Cx4NqDvtWBJy_+H9p3QXc#@6g;x2F2* znPRJ}+Evv%(*n^FLIM&L0Tl^>@&qptQb5s2c|b7{5|<|fQltp@4?ym1Ux8M1lOMUN~OaJqOr9W6+87OaZtSIp5>uNyn+fy=4vMTG9#(KSm zf0*X?H~)L7R=HoTnAh%GCjW!~Sc@O3iyvzEP-(8vLGs6!YJ)?vipKT#T2<lID6)@L zR9-d;IQ7^LlUJU5eYWb^qoaXMh3hw{OpR8v$a1ZkMLT{pR!&Sd9l8DhGWhBd#Q}uI zDjd1KA~%lYR~1q`9jmg@8I9v9J;u2pjMm8Z2iXTYJqaS1;)YR7%2Oj4K<+FeKZt34 z9U2c@$BtnjMe3u8@*P}vPha%(v(aac#rBb>sG!{V1p3%?Vn-(g%Wa=*&yC_@+1Qhx z*p7(CVKA7y20pUm)r>^JG z5ra9DDBv>q3chiN~Ok9N0XRl05x1X1t_3AJK6Q)z_96|r{cFB3J`&K+)GEn zU<&=TVEn2?hhFl$x%ik!UYaezXn!a}%mNPtA(24mqTjys&0 zn!afH1;cOPV1SDsal#n6Da=aX5|?wYynO!K&pm%h6gSWR$oNLCwAC^zTIp(~nJJyo zN)S2#NF2g15k=F{QQ)nm7H~3UY>@fYKtS;6bpRLRD!n=?8rw@jtecwU@tZrOaEe)KVR)CiTW1Y}oDf z$sVHWP<$F>)dQt0`N_-9OWCn%wOKq&{^QlXmEk=Ci}q?oY{ zC9oou%jHAilHx)x0genRVa>=8sFm(*?9yY`)*o)|?Y|F}07%stg3S2c+}r*TBm>)> zVCKi_EY{@1HyJ6qBYuE^TjC2e0ZAbTFAy0TU?bZJ11?gJUGORH^VAs%q*v06#{Lz= z2NSNbX$Epepbsz*;P?Ukk`BUP3i5UxO@-y;<5&J#GSo_b8xG^rp zp-g6k7~SpAAeexYVss%Ajv;uLxSExX9&o|F(_F*R(5(lTnfWycen8jf0GK~!;4zVb z0*Jbv{Kd7aOXcLpU$~L{*XzlwS#L0W*+#QorQ6D9x?NWE+{Z84~RE~|5g$`qI7Pw;pmwcEL5t#9HF@z0phIeXDqk^FcGj?szC>lo2 z|6^Ee<5%5>a6Lor{NWpambtgtuBQBKwoSSXu3`kI+&WL8HRd!&Dwt>w)S=shDr`#D zq#EdC(jKhPMO0y}H!X4_hL3N*zqj8hYLucZ_R&nb(b$gBMcnF2CT(|abr;H$M1ikg zAQxTqk8I{%hD+8Ri#jl@e&ySOyBdn;L1tphYB2N=6|0t+s3pQb8~Z!`57*%0ys;fp zm(V|RWrB5pjywXzcZP=ilRYlRiPrvPgf0u-@d(YU&YtcX-!OAddANByehtLBp<)|a3z)3Mj~k6n|101A;6dlT27XizxH1CSj$X%?pmGh z=pGa>3_-BLDD|I^F%^XV&@>h+sY!3by0jW~P}}tv$_91L?9td$>&YkAnoCAvuf8_x3B1s@zI0X73nYFsC93o5I0(r8PywL*030MDbD znw|#XK;(kFcvNh#ov?NiB_S*Q41uz~F;CFaqDh_cC!st{!h-lRU(^P)dW1 zo{z~>uF?XunOsce;p{?g*wdW_vtwF5WzGgqaY;n_ls_Qa=S(#aE)|}-_#X5AycP%* zM`~nqH-qWc_F|ZSd_o&{?(BX@*H=X?rsFwRVlFFkTGDxI(!ko4S9>b$H}sizc* z6s(W|K<5=Sgn!bGDeaWduX0~0WU$aSr7M6e1Er1A(#}_ZczI@8ts1kRut1|l+gUBb zJq!}Ai^5)ji-VqePBuH;erF#ny>qX_kTno^cbrmyepaR>LJQBSmr@ds1_E#d-&dy) zc(L%p&Mrn*APlrklv zoCgb{dQ(5v zS7!opJ3L06#@(%YT*Bn0L%tu-O(0J7?G1d1!0 z`+_HKX0kkFw&c5K2sU#k;0615bEM0?_J;)+^IYmNohq^IQJ7qvvyA0~xF*ExAvdiGk=Th9L+xt)D^2`c$~j zIn-7@VdP#HDZxRXA?ge{;btvT=P177Q8|^(%e?h7%<}kF)MZr@n{W5zoK9s*16*_XD$BFN`BbOIr zXgrV5JR)dMhY3s@ksZxayg-N$2@eH%;f5NzlZTzco5HX}3|$m}*v2L^4+C!xsc>*` zqU-^ESyMM#=CPt!3mqDy|5pHQ;Y%to)6US}a@i=n#m``4Vh;et^hy2?zMX$jIN;mz zp9>H)Y-6Hc!|Oy0qLDv3ylnF(>JQ%3jJ!sY&NpRX|<)#N?k>xK9bY4wb$Lg zc>Eu#@63-kt#k(XS;seeor}jmS6evVsy%s}LnwK~>8p!7?2zsV%HOKJSI?DiH?re+ zCB%k*MtR`pw(bvb@^@?RwX>70N~;Z@vCEq1<9X)}S-eH$mePKT)!(YWp8V#`=aWxs zZ(MS{pz;0zG#&_B-8vX{T4}Z|v*>)W~`CtLS9Wr|$0U-6{3(`)sF+EgU>0`5|RHEm`>h zFHMuq5Lv#WPesMTxQKcMIlS4}>E4$8TTkEzH56PUjdrdZat~>Q(s8lrNdC0GntG;R zq?PCJ;;#DI&*AM}9e*0n_lMWh zcYZv8`*F#QO3adQ`4=xUF7bx$N@6zNoTdHninP27E~EP^U+Udo$;Snz*sPD{@O~*O zuN+b{4^yq44%kgo8ce+2!-}lrx!CHnKoBH8gKgw*&puKfdIRrDx_abqjcgBz4{w!= z%SpfSgS`K1S1PFhvsKd#x?X&PN^Pw9S%}aJ+|5ALz|fMRE@v{z?0k)kS3tl>zAeiU zzyLrgE1;9&Gs)Y{moDw>ChJWvh3WaUnQ}|GApnlCz6HPVJZZjLkcOg&~>U zojiDV?ffq{K3RI(vdl*2p?X7C9@ZJ^Zl~s_j?styZtI_y-mt7zx|8M3ffwqu%58Yj F_+P@Pb<+R< delta 1997 zcmb_dOKclO7|yy0wUg#WQu1h=jO~!vZno^qzPy$wvHM6v(#A~_71XupCc7>xIlHdC z39UG^To6!|R-LMd8$w(wsH_I56ahyNs8Tt=fh(XMDk5>-e)odym{z%hV#nfzN&-b8l++uV=m#qA2F4vEX9VQfMP#j5PAQMXO)Iia zmC9D7V!O`&Usa$`p&!jh+G}OFrdg|kUTE4M$S11Tx8CBKh$>1VeJ?Uuy&dY}nEH*D zP{3D9)hn%UaZf?nv2m5a6g_0Ri_1%v<5^~PSI4*96Ie(kz~%gtoy?WCcds(?TlXTD zr_c4y(ADk39ohy@x~=DiA77?7`*`|$&v>ImR7@XaX6U)z(M|x!qp9e<-cNi71strL zq+$V*vZ|ES2Gi!|c)>xr%;fA5G~$*#xK^Wx;xqGex%oL1FWMCk#ZNA~o`p(f_k@#x z51sDsZB8;slnlFEp%*&_&xm@V0p^ZzremB9yv>Kio<7hCVwef4E;7_&KrJT030>c- zM|~hW6QB|2nPCzPu@quJB2$c)b%((i?_efAtbkD%GY|$2ViJf+@NqauYb2sa2fIO! z^#UkF;H0+hNC*-|#}W{fVK0Vb$X)hI%O3K}M==68WR3D{v?>C0d8h!5c|0?y^-X_1 z6iqHH+eMQ%E0%XMi3k$FbOn~fLX}d{_IRVsGzJ=h=LQUlp$o*xGl zSyPxHy)^VbL)X^GWgiVGK#AwMlfss+Rz0>5;JCOzY z)6>UUq?bnyGxEoXGsJdt;k0M*i>_(;?*guGd;OhxaN!;ZtV88cyS;lO42$; z#Z3$%^m5{0TS`jRfs9Ftt|el0FsXJSem9C^c26Rbkc<>){cJo^eTn~~u`Q)wZ9OoS z|M9__`0PSZn8O#XQ}!b40DJjt=LBLChOO`;en4(E1~pA1{`K~x?y%cf(%!w4JxtB? zXh2KR3+ZXvIewpAxQyv{dp@JLGl@o=(j?f|R|8P?h4fVTzf-l3$LXKh@BJ7AV%!N5 zIpudj*Y>7aPIKRGMt-P~x&7lz`m#pu9_XWOxezrc`U6Fao}I`sa(pICf0@|M?Cu^A zYd;K)!Cu0a2vQIZIh%!3fv*~Z%@K4blij07v-{Q;hZ-{j^ux&}`t>Ag$|Dsbz5e`a zj}KuCe*zocplee-f$4qptEu98`s)1j+X2S^cX!fxrYj5Vte(S+yJ*j5;WE` zEQs{jTe@?$F%ZVGqSQh2mi_C6#g}xMDyRG5=0^Z diff --git a/loel.el b/loel.el index d857e8d..271103f 100644 --- a/loel.el +++ b/loel.el @@ -60,18 +60,16 @@ `(lex-defun ,name (,(car arg)) ,@body)) - - (defgoal s (v) (stream v)) (defgoal fail (u) choice-zero) (lex-defun =%= (v w) (goal (s) (let ((ucation - (unify v w s))) + (loel-unify v w s))) (cond - (ucation (funcall s ucation)) - (t (funcall fail s)))))) + (ucation (s ucation)) + (t (fail s)))))) (defmacro fresh (vars &rest body) (with-gensyms @@ -81,18 +79,77 @@ ,(loop for var in vars collect `(,var (var ,var))) (funcall (loel-all ,@body) ,u))))) -(defmacro loel-run (n varlst &body body) +(defvar nil-sub nil) + +(recur-defun* walk-sub (v sub) + (let-if asc (alist sub v) + (if (var? asc) + (recur asc sub) + asc) + v)) + +(defun* walk-sub* (v sub) + (let ((v (walk-sub v sub))) + (cond + ((var? v) v) + ((listp v) + (cons + (walk-sub* (car v) sub) + (walk-sub* (cdr v) sub))) + (t + v)))) + +(defun ext-sub (x v s) + (alist>> s x v)) + +(defun loel-unify (v w s) + (let ((v (walk-sub v s)) + (w (walk-sub w s))) + (cond + ((eq v w) s) + ((var? v) (ext-sub v w s)) + ((var? w) (ext-sub w v s)) + ((and + (listp v) + (listp w)) + (let-if unified + (loel-unify (car v) (car w) s) + (loel-unify (cdr v) (cdr w) unified) + nil)) + ((equal v w) s) + (t nil)))) + +(defun reify-name (n) + (internf "_%d" n)) + +(defun reify-s (v &optional s) + (let ((v (walk-sub v s))) + (cond + ((var? v) (ext-sub v (reify-name (length s)) s)) + ((listp v) + (cons (reify-s (car v)) + (reify-s (cdr v)))) + (t + s)))) + +(defun reify (v s) + (walk-sub* v (reify-s v))) + + + +(defmacro* loel-run (n varlst &body body) (with-gensyms (nhat varhat shat) + (db-print (list n varlst)) `(lexical-let ((,nhat ,n) - (,varhat (var ',(car varlst)))) + (,(car varlst) (var ,(car varlst)))) (if (and (not (nil? ,nhat)) - (> n 0)) + (> ,n 0)) (map-inf ,nhat - (lex-lambda (,shat) - (reify (walk* ,varhat ,shat))) - (funcall (all ,@body) empty-s)) + (lambda (,shat) + (reify (walk-sub* ,(car varlst) ,shat) ,shat)) + (funcall (loel-all ,@body) nil-sub)) nil)))) (defmacro cond-aux (ifer &rest other-args) @@ -130,6 +187,15 @@ (defmacro loel-all (&rest gs) `(all-aux stream-bind ,@gs)) +;; (defmacro loel-all (&rest gs) +;; (with-gensyms (u) +;; `(goal (,u) +;; (lexical-mlet< monad-stream +;; ,(loop for g in gs collect +;; `(,u (funcall ,g ,u))) +;; ,u)))) + + (defmacro loel-all^i (&rest gs) `(all-aux stream-bind^i ,@gs)) @@ -185,3 +251,27 @@ (defmacro cond^u (&rest cs) `(cond^u if^u ,@cs)) + +(dont-do + (loel-run 1 (x) + (fresh (y) + (=%= #'s y) + y)) + + (loel-unify (var x) (var y) nil) + + (funcall (loel-all + (=%= (var x) #'s)) nil) + + (funcall (=%= (var v) (var u)) nil) + + (cl-prettyexpand '(fresh (x) + (=%= x #'s))) + + + + + + + +) \ No newline at end of file diff --git a/monad-parse.el b/monad-parse.el index 348e768..0ae1f8f 100644 --- a/monad-parse.el +++ b/monad-parse.el @@ -160,7 +160,7 @@ (setq i (+ i 1)) (push (input-first input) ac ) (setq input (input-rest input))) - ;(db-print (list n (length ac) (coerce (reverse ac) 'string))) + ;(db-print (list n (length ac) (coerce (reverse ac) 'string))) (if (= (length ac) n) (list (cons (coerce (reverse ac) 'string) input) nil))))) (defun =string (str) @@ -188,6 +188,12 @@ (parser-return x) (parser-fail)))))) +(defun* =is (object &optional (pred #'eq)) + (lexical-let ((object object) + (pred pred)) + (=satisfies + (lambda (x) (funcall pred object x))))) + (lexical-let ((digits (coerce "1234567890" 'list))) (defun digit-char? (x) (in x digits))) @@ -250,13 +256,32 @@ (=let* [_ (=char char)] (coerce (list _) 'string))) +(defun =point () + (=satisfies (par #'eq ?.))) + +(defun =decimal-part () + (=simple-let* + ((dot (=point)) + (rest (=one-or-more (=digit-char)))) + (coerce (cons dot rest) 'string))) + +(defun =integer-part () + (=simple-let* + ((digits (=zero-or-more (=digit-char)))) + (coerce digits 'string))) + +(defun =number->number () + (=simple-let* + ((int (=integer-part)) + (dec (=maybe (=decimal-part)))) + (string-to-number (concat int dec)))) (lex-defun =or2 (p1 p2) - (lambda (input) - (or (funcall p1 input) - (funcall p2 input)))) + (lambda (input) + (or (funcall p1 input) + (funcall p2 input)))) (lex-defun =or (&rest ps) - (reduce #'=or2 ps)) + (reduce #'=or2 ps)) ;; (lex-defun =or (parser &rest parsers) ;; (lambda (input) @@ -274,11 +299,12 @@ ;; parsers))) (lex-defun =not (parser) - (lambda (input) - (let ((result (funcall parser input))) - (if result - nil - (list (cons t input)))))) + b + (lambda (input) + (let ((result (funcall parser input))) + (if result + nil + (list (cons t input)))))) (defmacro* =let* (forms &body body) `(lexical-domonad< monad-parse ,forms ,@body)) @@ -289,16 +315,16 @@ `(parser-bind ,@(cdr (car bindings)) (lex-lambda (,symbol) (=simple-let* ,(cdr bindings) - ,@body)))) + ,@body)))) `(parser-return (progn ,@body)))) (lex-defun =and2 (p1 p2) - (lex-lambda (input) - (and (funcall p1 input) - (funcall p2 input)))) + (lex-lambda (input) + (and (funcall p1 input) + (funcall p2 input)))) (lex-defun =and (&rest ps) - (reduce #'=and2 ps)) + (reduce #'=and2 ps)) ;; (lex-defun =and (p1 &rest ps) ;; (=let* [result p1] @@ -307,17 +333,17 @@ ;; result))) (lex-defun =and-concat2 (p1 p2) - (=let* [r1 p1 - r2 p2] - (concat r1 r2))) + (=let* [r1 p1 + r2 p2] + (concat r1 r2))) (lex-defun =and-concat (&rest ps) - (reduce #'=and-concat2 ps)) + (reduce #'=and-concat2 ps)) (lex-defun parser-maybe (parser) - (=or parser (parser-return nil))) + (=or parser (parser-return nil))) (lex-defun =maybe (parser) - (=or parser (parser-return nil))) + (=or parser (parser-return nil))) (defun letters () @@ -335,73 +361,102 @@ ;; (cons x xs)) ;; (parser-return nil))) -(lex-defun zero-or-one (parser) - (=or (=let* [_ parser] - _) - (parser-return nil))) +(lex-defun =zero-or-one (parser) + (=or (=let* [_ parser] + _) + (parser-return nil))) (lex-defun zero-or-one-list (parser) - (=or (=let* [_ parser] - (list _)) - (parser-return nil))) + (=or (=let* [_ parser] + (list _)) + (parser-return nil))) (lex-defun zero-or-plus-more (parser) - (lambda (input) - (let ((terminals nil) - (continuers (funcall (zero-or-one-list parser) input)) - (done nil) - (res nil)) - (loop while (not done) do - (let ((old-continuers continuers)) - (setq continuers nil) - (loop while old-continuers - do - (let* ((sub-parser-state (pop old-continuers)) - (state (car sub-parser-state)) - (sub-input (cdr sub-parser-state)) - (res (funcall parser sub-input))) - (if res - (setq continuers - (append continuers (mapcar - (lambda (sub-res) - (cons - (suffix state (car sub-res)) - (cdr sub-res))) - res))) - (push sub-parser-state terminals))))) - (if (empty? continuers) - (setq done t))) - terminals))) + (lambda (input) + (let ((terminals nil) + (continuers (funcall (zero-or-one-list parser) input)) + (done nil) + (res nil)) + (loop while (not done) do + (let ((old-continuers continuers)) + (setq continuers nil) + (loop while old-continuers + do + (let* ((sub-parser-state (pop old-continuers)) + (state (car sub-parser-state)) + (sub-input (cdr sub-parser-state)) + (res (funcall parser sub-input))) + (if res + (setq continuers + (append continuers (mapcar + (lambda (sub-res) + (cons + (suffix state (car sub-res)) + (cdr sub-res))) + res))) + (push sub-parser-state terminals))))) + (if (empty? continuers) + (setq done t))) + terminals))) (lex-defun zero-or-more - (parser) - (lexical-let ((zero-or-one-parser (zero-or-one parser))) - (lex-lambda (input) - (let* ((sub-state (car (funcall (zero-or-one-list parser) input))) - (acc (car sub-state)) - (done (not (car sub-state)))) + (parser) + (lexical-let ((zero-or-one-parser (zero-or-one parser))) + (lex-lambda (input) + (let* ((sub-state (car (funcall (zero-or-one-list parser) input))) + (acc (car sub-state)) + (done (not (car sub-state)))) + + (if done (list sub-state) + (progn + + (loop while (not done) do + (let* ((next-input (cdr sub-state)) + (next-sub-state + (car (funcall zero-or-one-parser next-input))) + (res (car next-sub-state))) + (if res (progn + (push res acc) + (setq sub-state next-sub-state)) + (setq done t)))) + (list (cons (reverse acc) (cdr sub-state))))))))) + +(lex-defun =zero-or-more + (parser) + (lexical-let ((zero-or-one-parser (zero-or-one parser))) + (lex-lambda (input) + (let* ((sub-state (car (funcall (zero-or-one-list parser) input))) + (acc (car sub-state)) + (done (not (car sub-state)))) + + (if done (list sub-state) + (progn + + (loop while (not done) do + (let* ((next-input (cdr sub-state)) + (next-sub-state + (car (funcall zero-or-one-parser next-input))) + (res (car next-sub-state))) + (if res (progn + (push res acc) + (setq sub-state next-sub-state)) + (setq done t)))) + (list (cons (reverse acc) (cdr sub-state))))))))) - (if done (list sub-state) - (progn - (loop while (not done) do - (let* ((next-input (cdr sub-state)) - (next-sub-state - (car (funcall zero-or-one-parser next-input))) - (res (car next-sub-state))) - (if res (progn - (push res acc) - (setq sub-state next-sub-state)) - (setq done t)))) - (list (cons (reverse acc) (cdr sub-state))))))))) +(lex-defun one-or-more + (parser) + (=let* [x parser + y (zero-or-more parser)] + (cons x y))) +(lex-defun =one-or-more + (parser) + (=let* [x parser + y (zero-or-more parser)] + (cons x y))) -(lex-defun one-or-more - (parser) - (=let* [x parser - y (zero-or-more parser)] - (cons x y))) (defun parse-string (parser string) (car (car (funcall parser (string->parser-input string))))) @@ -422,6 +477,5 @@ #'symbolp (par #'eq sym)))) - (provide 'monad-parse) diff --git a/parse-seq-binder.el b/parse-seq-binder.el index 72c1204..fa18c9a 100644 --- a/parse-seq-binder.el +++ b/parse-seq-binder.el @@ -1,51 +1,116 @@ ;; parse-seq-binder ;; parses a sequence binder for clojure-like binding +;; See defn.el (require 'cl) (require 'utils) -(setq currently-defining-defn 'lambda) +(defvar currently-defining-defn 'lambda) +; defvar this so that we can satisfy the elisp compiler. + +(defun parse-and-check-seq-binder (binder) + "Given a BINDER expression describing a SEQUENCE, check and parse the expression into a useful form. +Returns a list of the form: + ( BINDERS + REST-EXPRESSION + AS-SYM + OR-FORM ) + + Binders constitutes the 'ordinary' variable binding expressions. + REST-FORM is the symbol to associate with anything after an '&' + token. AS-SYM is the symbol to bind the entire expression to. + NIL signifies NONE. OR-FORM is the expression (if any) to + destructuring if destructuring the input fails. + " + (let-tbl + ((binders :binders) + (as-sym :as-sym) + (rest-form :rest-form) + (or-form :or-form)) + (foldl + (lambda (it ac) + (let-tbl + ((i :i) + (prev :prev) + (state :state) + (n-as :n-as) + (n-or :n-or) + (n-rest :n-rest) + (as-sym :as-sym) + (or-form :or-form) + (rest-form :rest-form) + (binders :binders)) ac + (case state + (:parsing-binders + (parse-seq-binders it ac)) + (:parsing-rest + (tbl! ac + :state :parsing-special-forms + :rest-form it + :prev it + :i 1)) + (:parsing-special-forms + (parse-seq-special-forms it ac))))) + (tbl! + :i 0 + :state :parsing-binders + :n-as 0 + :n-or 0 + :n-rest 0 + :rest-form nil + :as-sym nil + :or-form nil + :binders '()) + (vector->list binder)) + (list binders rest-form as-sym or-form))) (defun parse-seq-special-forms (it ac) + "Parsing function for the special forms part of a SEQ binding +expression. Takes a table in AC representing the parser state, +and returns an appropriately modified table. +IT is the current token." (let-tbl - ((i :i) - (state :state) - (n-as :n-as) - (n-or :n-or) - (as-sym :as-sym) - (or-form :or-form) - (binders :binders) - (prev :prev)) ac - (cond - ((oddp i) - (if (or - (eq :as it) - (eq :or it)) - (let* ((count-key (case it (:as :n-as) (:or :n-or))) - (n-special-form (+ 1 (tbl ac count-key)))) - (if (> n-special-form 1) (error "More than one %s clause in table binder in %s." it currently-defining-defn)) - (tbl! ac - :prev it - :i (+ i 1) - count-key n-special-form)) - (error "Unrecognized special form keyword %s in %s" it currently-defining-defn))) - ((evenp i) - (let ((spec-key (case prev (:as :as-sym) (:or :or-form)))) - (case prev - (:as - (if (symbolp it) - (tbl! ac - :i (+ i 1) - :prev it - spec-key it) - (error "As forms must be symbols. Got %s instead in %s" it currently-defining-defn))) - (:or - (tbl! ac - :i (+ i 1) - :prev it - spec-key it)))))))) + ((i :i) + (state :state) + (n-as :n-as) + (n-or :n-or) + (as-sym :as-sym) + (or-form :or-form) + (binders :binders) + (prev :prev)) ac + (cond + ((oddp i) + (if (or + (eq :as it) + (eq :or it)) + (let* ((count-key (case it (:as :n-as) (:or :n-or))) + (n-special-form (+ 1 (tbl ac count-key)))) + (if (> n-special-form 1) (error "More than one %s clause in table binder in %s." it currently-defining-defn)) + (tbl! ac + :prev it + :i (+ i 1) + count-key n-special-form)) + (error "Unrecognized special form keyword %s in %s" it currently-defining-defn))) + ((evenp i) + (let ((spec-key (case prev (:as :as-sym) (:or :or-form)))) + (case prev + (:as + (if (symbolp it) + (tbl! ac + :i (+ i 1) + :prev it + spec-key it) + (error "As forms must be symbols. Got %s instead in %s" it currently-defining-defn))) + (:or + (tbl! ac + :i (+ i 1) + :prev it + spec-key it)))))))) (defun parse-seq-binders (it ac) + "Parser for the sequential part of a SEQ binder. Takes a table +representing the parser state in AC, and the current token IT, +and returns an appropriately modified table." (let-tbl ((i :i) (prev :prev) @@ -84,48 +149,7 @@ :i (+ i 1) :prev it))))) -(defun parse-and-check-seq-binder (binder) - (let-tbl - ((binders :binders) - (as-sym :as-sym) - (rest-form :rest-form) - (or-form :or-form)) - (foldl - (lambda (it ac) - (let-tbl - ((i :i) - (prev :prev) - (state :state) - (n-as :n-as) - (n-or :n-or) - (n-rest :n-rest) - (as-sym :as-sym) - (or-form :or-form) - (rest-form :rest-form) - (binders :binders)) ac - (case state - (:parsing-binders - (parse-seq-binders it ac)) - (:parsing-rest - (tbl! ac - :state :parsing-special-forms - :rest-form it - :prev it - :i 1)) - (:parsing-special-forms - (parse-seq-special-forms it ac))))) - (tbl! - :i 0 - :state :parsing-binders - :n-as 0 - :n-or 0 - :n-rest 0 - :rest-form nil - :as-sym nil - :or-form nil - :binders '()) - (vector->list binder)) - (list binders rest-form as-sym or-form))) + (comment (parse-and-check-seq-binder [a b c & rest :as x :or (list 1 2 3)])) diff --git a/parse-table-binder.el b/parse-table-binder.el index 31836c0..7b83b62 100644 --- a/parse-table-binder.el +++ b/parse-table-binder.el @@ -7,12 +7,14 @@ (setq currently-defining-defn 'lambda) (defun key->count-key (it) + "Convert a token to the appropriate key to access its count in a table." (case it (:as :n-as) (:or :n-or) (:keys :n-keys))) (defun check-keys-form (form) + "Check the :keys form in a TBL expressions." (and (vectorp form) (foldl (lambda (it ac) @@ -23,6 +25,9 @@ (vector->list form)))) (defun parse-tbl-special-forms (it ac) + "Ad-hoc parser function which handles special form parsing for +TBL binders. Takes a state in AC and the current token (IT) and +returns the appropriate modified state." (let-tbl ((i :i) (state :state) @@ -71,6 +76,9 @@ spec-key it)))))))) (defun parse-tbl-binders (it ac) + "Parse the simple binders in a table binder. Takes a table +representing parser state and a token, returning the +appropriately modified state." (let-tbl ((i :i) (state :state) @@ -102,6 +110,23 @@ (defun parse-and-check-tbl-binder (binder) + "Parse and check a BINDER expression which represents table +destructuring. Works by conditionally folding over the tokens in +BINDER. + +Return a list of the form + + (BINDERS KEYS AS-SYM OR-FORM KEYS-SEQ) + + BINDERS the symbols to bind + KEYS the keys to bind them to, same order as BINDERS + AS-SYM is the symbol to bind the entire table to, if provided. + Otherwise it is NIL. + OR-FORM is an expression which produces a table to destructuring when + the input form fails to destructure properly. + KEYS-SEQ the :keys portion of the binding form. + +" (let-tbl ((binders :binders) (keys :keys) diff --git a/parser-pres/just-elisp.el b/parser-pres/just-elisp.el index 77364de..3625472 100644 --- a/parser-pres/just-elisp.el +++ b/parser-pres/just-elisp.el @@ -1,3 +1,38 @@ +(require 'el-pres) +(loop for page in (sort-by-page-ascending (safe-get-pages)) do + (insert-file page) + (goto-char (point-max))) +;;; Monadic Parser Combinators +;;; A Ground up Introduction + +;; The best way, I think, to understand how these things works is to +;; consider the question of what a monadic parser combinator is in +;; the following order: + +;; 1) What is our representation of a parse? +;; 2) How do we combine them? +;; 3) How does this combination strategy form a monad? + +;; Depending on your temperament, you might not even care about 3, +;; which is fine. The parser monad is useful without worrying too +;; hard about how monads work in general, but we will try to make +;; that clear in the course of the presentation. + +(require 'el-pres) + +;;;Controls Home . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 +;;; Index +;;; Parsers + +;;; The whole point here is to enable us to build complex parsers out +;;; of simple ones. +;;; +;;; A simple parser is a function which takes an input and returns either: +;;; * nil, if the parser doesn't see what it wants +;;; * or a pair ( produced-value . left-over-input ) + +;;; eg: + (defun str-head (str) (substring str 0 1)) (defun str-tail (str) @@ -19,6 +54,12 @@ (parse-a "abracadabra") (parse-a "dogs of war") + +;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 +;;; Index;;; Atomic Parsers! + +;;; You could imagine a ton of "parse-_" style parsers, but turns out +;;; there are even simpler parsers: (defun anything (input) ; aka "item" (unless (empty? input) @@ -34,6 +75,21 @@ (defun nil-parser (input) nil) + +;;; This takes a value and returns a parser which "returns" that +;;; value, without changing the input. If you wanted to insert a +;;; value into your parsers for some reason, this is the function +;;; you'd use. +;;; +;;; It, too, will be of importance later. + +;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 +;;; Index;;; Combining Parsers + +;;; Our goal is to make writing parsers as easy as writing programs. +;;; We program by combining simple functions. How do we combine +;;; simple parsers? + (defun parse-b (input) (unless (empty? input) (if (string= (str-head input) "b") @@ -52,9 +108,14 @@ (parsed-leftover b-result))))))))) (parse-ab "abracadabra") -(parse-ab "atropy") +(parse-ab "atrophy") (parse-ab "oboe") +;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 +;;; Index;;; Meditation Upon Combination + +;;; parse-ab was a mess. Can we factor out this complexity? + (defun* combine-parsers (p1 p2 &optional (with #'list)) (lexical-let ((p1 p1) (p2 p2) @@ -77,7 +138,15 @@ ;;; functional-programming sense. It is a function which operates on ;;; functions and returns a new function. -(funcall (combine-parsers #'parse-a #'parse-b) "abraham a") +(funcall (combine-parsers #'parse-a #'parse-b) "abraham a)") + +;;; pretty sweet! + +;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 +;;; Index;;; Limitations of combine-parsers + +;;; Combine-parsers works ok when we want to combine two parsers. We +;;; can even use the with argument to shoehorn more parsers together. (defun parse-c (input) (unless (empty? input) @@ -94,6 +163,28 @@ (parse-a-b-c "abcdef") +;;; But that is really pretty inconvenient. And if we want to combine +;;; parsers which depend on the results of previous parsings, +;;; "combine-parsers" won't cut it. + +;;; The crux of the issue is that we are really interested in the +;;; VALUE our parsers return, when combining parsers. We need an +;;; interface to expose these values selectively. + +;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 +;;; Index;;; Parser Bind + +;;; So, we'd like a function which extracts the parser _value_ and +;;; binds it to a variable inside an expression which generates +;;; another parser. That way we could use this function to construct +;;; nested, value-dependent parsers conveniently (or sort of +;;; conveniently). + +;;; If this doesn't seem obvious, don't worry too much. Once we do +;;; some examples, the utility will be clear. + +;;; Consider: + (defun simple-parser-bind (parser parser-producer) (lexical-let ((parser parser) (parser-producer parser-producer)) @@ -105,6 +196,53 @@ (funcall new-parser (parsed-leftover res))) nil)))))) +;;; In words: parser-bind takes 1 - a parser 2 - a function which +;;; takes a value and returns a NEW parser, which may *depend* on +;;; that value. +;;; It returns a parser itself. +;;; This returned parser: +;;; 1 - applies PARSER to its input, generating a value/leftover pair. +;;; 2 - extracts the VALUE part of that pair, and creates yet another +;;; parser by calling PARSER-PRODUCER on that value. +;;; 3 - finally, it applies this new parser to the leftovers from PARSER + +;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 +;;; Index;;; A bit more about bind. + +(find-file-other-frame "~/work/art/monadic-types-of-interest.png") +(find-file-other-frame "~/work/art/bind.png") + +;;; * Bind is kind of unintuitive. +;;; * However, it is more useful than "combine" because +;;; it facilitates sequencing. +;;; * bind's second argument is a lambda +;;; * a lambda is a delayed computation which depends on +;;; _unbound_ values. +;;; * bind _binds_ these values in an ordered way, facilitating +;;; the sequencing of computations which result in monadic +;;; values. + +;;; In the parser monad: +;;; * each lambda is a "delayed computation" which results in a +;;; _new parser_ when it is called with the value produced +;;; by a previous parser. +;;; * bind combines the new parser with the old parser, +;;; handling the plumbing needed to connect them together. +;;; * this plumbing is +;;; - check for nil +;;; - wrap up everything in a containing parser. + + +;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 +;;; Index;;; Oh Dang it is the Lisp Slide + +;;; All this junk about bind will melt into the background once we +;;; have one nice piece of syntax. + +;;; We are about to roll a parser-specific equivalent of Haskell's do +;;; notation. If you don't care about lisp, feel free to tune this +;;; out. + (defmacro parser-let* (binding-forms &rest body) (if (empty? binding-forms) `(progn ,@body) (let* ((binding-form (car binding-forms)) @@ -131,6 +269,81 @@ (simple-parser-return (list a-res b-res c-res))) "abcdef") +;;; ZING! + +;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 +;;; Index;;; Demystifying the Macro Magic + +;;; consider that : + +(let* ((x 10) + (y 11)) + (+ x y)) + +;;; expands to +(comment + (funcall + (lambda (x) + (funcall (lambda (y) (+ x y)) 11)) + 10) +) + +;;; or, provacatively: +(comment +(defun id-bind (v f) + (funcall f v)) + +(id-bind + 10 + (lambda (x) + (id-bind + 11 + (lambda (y) + (+ x y)))))) + +;;; or the semantic equivalent. +;;; +;;; parser-let*, then: + +(parser-let* + ((a #'parse-a) + (b #'parse-b)) + (simple-parser-return + (list a b))) + +;;; expands to: + +(comment + +(parser-bind + #'parse-a + (lambda (a) + (parser-bind + #'parse-b + (lambda (b) + (simple-parser-return + (list a b)))))) +) + +;;; parser-let* is a generalization of let* which knows about how we +;;; want to combine parsers. Monads in general support extension of +;;; the idea of let*. That is, sequencing dependent computations. + + +;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 +;;; Index;;; Non-trivial Things + +;;; Ok, what kinds of fun things can we do with this parser monad +;;; business? + +;;; Well, imagine you wish to match either: +;;; ab +;;; bc or +;;; ca + +;;; We can do this with a single expression using our monadic parser +;;; combinators. Observe: + (defun parse-a|b|c (input) (unless (empty? input) @@ -146,9 +359,9 @@ (:found-c #'parse-a))) (setq triangle-parser - (parser-let* ((first-char #'parse-a|b|c) - (second-char (make-dependent-parser first-char))) - (simple-parser-return (cons first-char second-char)))) + (parser-let* ((first-char #'parse-a|b|c) + (second-char (make-dependent-parser first-char))) + (simple-parser-return (cons first-char second-char)))) (funcall triangle-parser "ab") (funcall triangle-parser "bc") @@ -158,7 +371,8 @@ (find-file-other-frame "~/work/art/haskell-curry-says.png") -;;; Useful Combinators +;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 +;;; Index;;; Useful Combinators (defun -satisfies (pred) (lexical-let ((pred pred)) @@ -166,7 +380,7 @@ ((item #'anything)) (if (funcall pred item) (simple-parser-return item) - nil)))) + #'nil-parser)))) (defun -manythings (n) (lexical-let ((n n)) @@ -178,13 +392,13 @@ (defun -matches (str) (lexical-let ((str str)) ; parser-let* implicitely - ; constructs a function - ; which requires str - (parser-let* - ((sub (-manythings (length str)))) - (if (string= sub str) - (simple-parser-return sub) - #'nil-parser)))) + ; constructs a function + ; which requires str + (parser-let* + ((sub (-manythings (length str)))) + (if (string= sub str) + (simple-parser-return sub) + #'nil-parser)))) ;;; because of the behavior of bind, we can't write the following ;;; function with parser-let*: @@ -193,14 +407,15 @@ (defun -or (&rest parsers) (lexical-let ((parsers parsers)) (lambda (input) - (recur-let - ((rem-parsers parsers)) - (cond - ((empty? rem-parsers) nil) - (t - (let ((r (funcall (car rem-parsers) input))) - (if r r - (recur (cdr rem-parsers)))))))))) + (unless (empty? input) + (recur-let + ((rem-parsers parsers)) + (cond + ((empty? rem-parsers) nil) + (t + (let ((r (funcall (car rem-parsers) input))) + (if r r + (recur (cdr rem-parsers))))))))))) ;;; example: @@ -211,6 +426,9 @@ (funcall (-cat-or-dog) "ewe") +;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 +;;; Index;;; More Combinators + (defun -zero-or-more (parser) (lexical-let ((parser parser)) (lambda (input) @@ -238,7 +456,7 @@ (funcall (-one-or-more (-matches "dog ")) - "cat dog dog dog cat") + "dog dog dog dog cat") (funcall (-zero-or-more (-matches "dog ")) @@ -251,3 +469,188 @@ (let ((r (funcall parser input))) (if r r (pair nil input))))))) + +(defun pempty? (input) + "Check to see if you have hit the end of the input." + (if (empty? input) (pair t input) + (pair nil input))) + +(defun -list (parser) + (lexical-let ((parser parser)) + (parser-let* ((r parser)) + (simple-parser-return + (list r))))) + +(defun -not (parser) + (lexical-let ((parser parser)) + (lambda (input) + (unless (empty? input) + (let ((r (funcall parser input))) + (if r nil + (pair t input))))))) + +(defun -and2 (p1 p2) + (lexical-let ((p1 p1) + (p2 p2)) + (parser-let* ((v1 p1) + (v2 p2)) + (simple-parser-return v2)))) + +(defun -and (&rest ps) + (reduce #'-and2 ps)) + +(defun -and-list (&rest ps) + (lexical-let ((ps ps)) + (if (empty? ps) + (lambda (input) + (pair nil input)) + (parser-let* + ((v (car ps)) + (rest (apply #'-and-list (cdr ps)))) + (simple-parser-return (cons v rest)))))) + +(defun -n-of (n parser) + (if (= n 1) (-list parser) + (lexical-let ((n n) + (parser parser)) + (parser-let* + ((head parser) + (rest (-n-of (- n 1) parser))) + (simple-parser-return (cons head rest)))))) + +(funcall (-n-of 3 (-matches "a")) "aaab") + +;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 +;;; Index;;; Example + +;;; From RFC 1459, the IRC Chat Protocol Standards Docoument a Pseudo +;;; BNF description of an IRC Message. Lets write a parser for this. + +;;; IRC MESSAGE: +;; ::= [':' ] +;; ::= | [ '!' ] [ '@' ] +;; ::= { } | +;; ::= ' ' { ' ' } +;; ::= [ ':' | ] +;; ::= +;; +;; ::= +;; +;; ::= CR LF + + + +;;; We'll just assume that the line feed has been removed by a +;;; pre-parser that feeds us lines. + +(defun -trailing () + (parser-let* ((trailing (-zero-or-more #'anything))) + (simple-parser-return + (list :trailing (reduce #'concat trailing))))) + +(defun -colon-then-trailing () + (parser-let* ((colon (-colon)) + (trailing (-trailing))) + (simple-parser-return trailing))) + +(defun -colon () + (-matches ":")) + +(setq tab (format "\t")) +(defun -whitespaces () + (-one-or-more (-or (-matches " ") + (-matches tab)))) + +(defun -middle () + (parser-let* + ((colon (-not (-colon))) + (contents (-zero-or-more (-not-whitespace)))) + (simple-parser-return (list :middle (reduce #'concat contents))))) + +(defun -space-middle () + (parser-let* + ((_ (-whitespaces)) + (middle (-middle))) + (simple-parser-return middle))) + +(setq tab (format "\t")) +(defun -whitespaces () + (-one-or-more (-or (-matches " ") + (-matches tab)))) + +(defun -params () + (parser-let* + ((params (-zero-or-more (-space-middle))) + (_ (-whitespaces)) + (trailing (-maybe (-colon-then-trailing)))) + (simple-parser-return + (cons (list :params + (mapcar #'cadr params)) + (if trailing (list trailing) + nil))))) + +(defun -not-whitespace () + (-satisfies + (lambda (x) + (and (not (string= x " ")) + (not (string= x tab)))))) + +(defun -not-whitespaces () + (-zero-or-more (-not-whitespace))) + +(lexical-let ((letters + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") + (numbers "1234567890") + (punctuation + "~`!@#$%^&*()_+-={}[]|\\/<>,.:;'\"?")) + (defun -letter () + (-satisfies + (lambda (x) + (in (regexp-quote x) letters)))) + (defun -number () + (-satisfies + (lambda (x) + (in (regexp-quote x) numbers)))) + (defun -punctuation () + (-satisfies + (lambda (x) + (in (regexp-quote x) punctuation))))) + +(defun -command () + (parser-let* + ((command (-or + (-one-or-more (-letter)) + (-n-of 3 (-number))))) + (simple-parser-return + (list :command (reduce #'concat command))))) + +;;; We are going to cheat for the sake of brevity, and define prefix as: + +(defun -prefix () + (parser-let* ((contents (-zero-or-more (-not-whitespace)))) + (simple-parser-return (list :prefix (reduce #'concat contents))))) + +;;; Putting it all together: + +(defun -irc-message () + (parser-let* + ((_ (-colon)) + (prefix (-prefix)) + (_ (-whitespaces)) + (command (-command)) + (params&tail (-params))) + (simple-parser-return + (append (list prefix command) params&tail)))) + + +(parsed-value (funcall (-irc-message) ":tod.com SEND a b c :rest")) + +;;; WEEEEE + + + + +;;;Controls Home \ No newline at end of file diff --git a/parser-pres/page-10.el b/parser-pres/page-10.el index 64b8f96..af11f75 100644 --- a/parser-pres/page-10.el +++ b/parser-pres/page-10.el @@ -7,23 +7,25 @@ (+ x y)) ;;; expands to - -(funcall - (lambda (x) +(comment + (funcall + (lambda (x) (funcall (lambda (y) (+ x y)) 11)) - 10) + 10) +) ;;; or, provacatively: - +(comment (defun id-bind (v f) (funcall f v)) + (id-bind 10 (lambda (x) (id-bind 11 (lambda (y) - (+ x y))))) + (+ x y)))))) ;;; or the semantic equivalent. ;;; @@ -37,6 +39,8 @@ ;;; expands to: +(comment + (parser-bind #'parse-a (lambda (a) @@ -45,6 +49,7 @@ (lambda (b) (simple-parser-return (list a b)))))) +) ;;; parser-let* is a generalization of let* which knows about how we ;;; want to combine parsers. Monads in general support extension of diff --git a/parser-pres/page-12.el b/parser-pres/page-12.el index 9411c67..190a378 100644 --- a/parser-pres/page-12.el +++ b/parser-pres/page-12.el @@ -6,7 +6,7 @@ ((item #'anything)) (if (funcall pred item) (simple-parser-return item) - nil)))) + #'nil-parser)))) (defun -manythings (n) (lexical-let ((n n)) @@ -33,15 +33,16 @@ (defun -or (&rest parsers) (lexical-let ((parsers parsers)) (lambda (input) - (recur-let - ((rem-parsers parsers)) - (cond - ((empty? rem-parsers) nil) - (t - (let ((r (funcall (car rem-parsers) input))) - (if r r - (recur (cdr rem-parsers)))))))))) - + (unless (empty? input) + (recur-let + ((rem-parsers parsers)) + (cond + ((empty? rem-parsers) nil) + (t + (let ((r (funcall (car rem-parsers) input))) + (if r r + (recur (cdr rem-parsers))))))))))) + ;;; example: (defun -cat-or-dog () @@ -51,5 +52,5 @@ (funcall (-cat-or-dog) "ewe") -;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 +;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 ;;; Index \ No newline at end of file diff --git a/parser-pres/page-13.el b/parser-pres/page-13.el index 9d0d716..fda1cc8 100644 --- a/parser-pres/page-13.el +++ b/parser-pres/page-13.el @@ -27,7 +27,7 @@ (funcall (-one-or-more (-matches "dog ")) - "cat dog dog dog cat") + "dog dog dog dog cat") (funcall (-zero-or-more (-matches "dog ")) @@ -55,9 +55,10 @@ (defun -not (parser) (lexical-let ((parser parser)) (lambda (input) - (let ((r (funcall parser input))) - (if r nil - (pair t input)))))) + (unless (empty? input) + (let ((r (funcall parser input))) + (if r nil + (pair t input))))))) (defun -and2 (p1 p2) (lexical-let ((p1 p1) diff --git a/parser-pres/page-14.el b/parser-pres/page-14.el index 218b11d..c5b207d 100644 --- a/parser-pres/page-14.el +++ b/parser-pres/page-14.el @@ -36,33 +36,97 @@ (defun -colon () (-matches ":")) +(setq tab (format "\t")) +(defun -whitespaces () + (-one-or-more (-or (-matches " ") + (-matches tab)))) + (defun -middle () (parser-let* ((colon (-not (-colon))) - (contents (-zero-or-more #'anything))) + (contents (-zero-or-more (-not-whitespace)))) (simple-parser-return (list :middle (reduce #'concat contents))))) +(defun -space-middle () + (parser-let* + ((_ (-whitespaces)) + (middle (-middle))) + (simple-parser-return middle))) (setq tab (format "\t")) (defun -whitespaces () (-one-or-more (-or (-matches " ") (-matches tab)))) -(defun -middle-and-params () - (parser-let* ((middle (-middle)) - (params (-params))) - (list :continued (list middle params)))) - (defun -params () (parser-let* - ((_ (-whitespaces)) - (trailing? (-maybe (-colon-then-trailing))) - (rest (-maybe (-and-list + ((params (-zero-or-more (-space-middle))) + (_ (-whitespaces)) + (trailing (-maybe (-colon-then-trailing)))) + (simple-parser-return + (cons (list :params + (mapcar #'cadr params)) + (if trailing (list trailing) + nil))))) + +(defun -not-whitespace () + (-satisfies + (lambda (x) + (and (not (string= x " ")) + (not (string= x tab)))))) + +(defun -not-whitespaces () + (-zero-or-more (-not-whitespace))) + +(lexical-let ((letters + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ") + (numbers "1234567890") + (punctuation + "~`!@#$%^&*()_+-={}[]|\\/<>,.:;'\"?")) + (defun -letter () + (-satisfies + (lambda (x) + (in (regexp-quote x) letters)))) + (defun -number () + (-satisfies + (lambda (x) + (in (regexp-quote x) numbers)))) + (defun -punctuation () + (-satisfies + (lambda (x) + (in (regexp-quote x) punctuation))))) + +(defun -command () + (parser-let* + ((command (-or + (-one-or-more (-letter)) + (-n-of 3 (-number))))) + (simple-parser-return + (list :command (reduce #'concat command))))) + +;;; We are going to cheat for the sake of brevity, and define prefix as: + +(defun -prefix () + (parser-let* ((contents (-zero-or-more (-not-whitespace)))) + (simple-parser-return (list :prefix (reduce #'concat contents))))) + +;;; Putting it all together: + +(defun -irc-message () + (parser-let* + ((_ (-colon)) + (prefix (-prefix)) + (_ (-whitespaces)) + (command (-command)) + (params&tail (-params))) + (simple-parser-return + (append (list prefix command) params&tail)))) -(funcall (-params) " a b c:a") +(parsed-value (funcall (-irc-message) ":tod.com SEND a b c :rest")) +;;; WEEEEE -;;;Controls Home <<< . 1 2 3 4 5 6 7 8 9 10 11 12 13 14 +;;;Controls Home <<< . >>> 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 ;;; Index \ No newline at end of file diff --git a/parser-pres/page-15.el b/parser-pres/page-15.el new file mode 100644 index 0000000..78324ed --- /dev/null +++ b/parser-pres/page-15.el @@ -0,0 +1,34 @@ +;;; Conclusions/Observations + +;;; * Monadic Parser Combinators are about combining simple parsers +;;; * Like most monads, you need special syntax to make best use of +;;; them. + +;;; * Since parsers are functions, they live in your language, can be +;;; tested individually, and can use the full power of the +;;; underlying language. Incremental development and testing makes +;;; writing parsers the same as writing any other program. + +;;; Future Thoughts: + +;;; * The parser monad isn't really anything special. It is actually +;;; the monad you get by transforming the maybe monad with the state +;;; monad transformer. + +;;; * Ergo, (state-t sequence-m) is the non-deterministic parser monad +;;; in which individual parsers may return multiple results. + +;;; * And (state-t stream-m) is the lazy, non-deterministic parser +;;; monad. Parsers in this monad return a stream (possibly +;;; infinite) of results. + +;;; * What about _additional_ state? Consider the monad of functions: +;;; (lambda (&rest states) +;;; ;;; does things +;;; (pair a-result states)) +;;; +;;; By packing a stack or two into states one could parse with precedence. + + +;;;Controls Home <<< . 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 +;;; Index \ No newline at end of file diff --git a/streams.el b/streams.el index 2f0855f..94b5ca9 100644 --- a/streams.el +++ b/streams.el @@ -46,6 +46,7 @@ (error "Tried to take the scar of a non-stream %S." stream)) (stream-head stream))))) + (defun scdr (stream) (cond ((not stream) nil) (t @@ -369,12 +370,12 @@ (setq normal-numbers - (mlet**_ monad-stream ((u (random-numbers 1.0)) - (v (random-numbers 1.0 (make-random-state t)))) - (lexical-let ((r (sqrt (* -2 (log u)))) - (s (* 2 pi v))) - (stream (* r (cos s)) - (later (stream (* r (sin s)) nil)))))) + (lexical-mlet monad-stream ((u (random-numbers 1.0)) + (v (random-numbers 1.0 (make-random-state t)))) + (lexical-let ((r (sqrt (* -2 (log u)))) + (s (* 2 pi v))) + (stream (* r (cos s)) + (later (stream (* r (sin s)) nil)))))) (defun list->stream (list) (stream (car list) diff --git a/streams.elc b/streams.elc index a1e8d734bec4108cbc7d9931e76cdd1cfa8993f3..4ecfd19a1291456fcfe5da629473b5ba25e3872c 100644 GIT binary patch delta 3094 zcmb7GO>9(E6n4r_S`tQD+9I?a@5~d^R$lw=-+S{05K1YK4xlwcYdb?T(@w+a{4_Ju zDiR!7kr)@kU6>fz=$?eU6-)OdhG@{3xG==H(F8WSA<=X0d#|0=#?-}q_uO;O&v(wf z@1FC?!^ng0BA*TIpDrwt3%P5AQeq`jRHT@7|JZM2KyXeaG1zeRmsyyv3_e5UYTqG#F=8i&9_SKRih{HvV?vK>-y)C##WgHUwj{_-&HB}raY<3)8h zIj+6A>eu9_XiQk^SOry8-lINuZ|EIP3@3;}2=(Z6uj(J$tInmm^e%vK!(ChN-b}rV zwgvN^raCnw@gI=HCP-opl5Bw_eMq-XR?(?!fh2_n+dtM9!<`m55{`me0XFHVOJiRm zF3G$<$2^@(ne^_BcSW>Gcm14g%X@S>)`r41Rrkh!R1eRlP{?L2LL7p9#XEZL7j4QG zUVQRpZOR4=;gzxNucy+!C1+hA*&^V=oqEl?fAI%x#<5g<@>`Xennr(4%jI+M@(p^w zPkqtW?8tD-$s`VCIJG+B8D@#j7l5WP7%Zs;1cxDTLHj^J_Mw1C_rq5L)5aAH`$CJj zqs0eM{0NFW>DZAB{1Sn@12jeXW?-LbXEbJ_#tG11EFBwxiTfIi0WDfQFsVJnMp5A{ zRFLTy7-M#zAc1xQ1r8gW`UFsX<}Eu)C;e;$64U|?Xj$S0#?YD*t<2+r z6-bV64nX;Y9gp#th+%$c3^K$WZ8Hj}LK1Suou5rEb>K|KyydAKBC^9E}O>O;3`=fA_=&vyd6Fwljz7) zG6}e+PJ+xWtkh~ynM{pQ?VIaSPiM~T;s!kM>f$@pUG-HNs&Y`p`~5FHvPyz@eK1+V zv+C%~sfbkZ=^pj*%*gQn0|A*_F0ItniJ8|U4%%olk^rZ79=T+xoO^GjlCQ2*7PEv6 z4G{>kyh=%Vm2ERn5Y^%#Y&5Gu%jtMCVVeHInP!5(!Za63=4!5Hn)oo>W|rYgsKJzp z^?0tjs87#<(pkR;%u?Y%+vJfbRyt1HK61pQ?!wR9Y5G!@m z?TptgqkZUIM*DGs;v}8DYBD?8#w>L`d%m<0N*J4kP{P=(Am73Yj#gN~(F!Zbvao_I z3oFR7u!1ZLD>zAL#o|}uyOZz|Fh`xcGDsLjn&AiE2PW_%@naiVLX&qUy3az2fk9nl z$Sgb}utE_Vh64k4Q~H{3cz8@RWCu^^H&?o`339j!DX~ULqz(oDBB{VLnJbx-PD_pe&g1p3HZ)L2oRuH{PNX7fh7%Q6lP6G(-a~S+7!~n%x06~gl@9)vwwz2P4m+#PJtY%kYcyBQwsvN*Emi^ zg&-;i3X}tM4v3##;9jZP147~e630rY0`YU;fDqyWqP@Tcsk}GqwcQY*NSW;0H}8G( zeQ##o`m=Aex2|jNj6HBXsF3MujZhE%(!xn|dhPMw$dJvr=MsZW8R=3GRL%8brM_0l zm(cIX!}`EIXnEmjeKpYqrq4*8$akN5Nd98{-HQ%R3=Y{x(H3$k(;sT1FW-%6zAZ1L z_AAQ?ucV&Ta5di}hKS>RV%U)_EKBYluc}}-e0BVy2Bxs6>^^i$S?scTTNym;nD{oD zwdGHfNKjZJ{AY513jmH2@8ZZmJ*g12K?g=1KmDZuh)wCGD=a(qt{WGqZTR1 zKwpzrycq3>4U^(mRqi#Wt0x=UWA90hnTMERjhX@USCN49T>S zV%w6kz{@}|M}u2B>PL&}$&utJAkpMOcx9>vg>dGZ2iK(VO50pqF-6u9j>z{w6z^z=W1m5}c* z5BD2s(_Af?s~fc%v_i8SRPtv{Q+~NTmn`RBD4Of%%Y~psh9PQ8$Qw_WyG!|U;Vg6& zF(q$W$?mwh3FuTgqS^9xu3x^M>63q~OeeS@XHHJ;Y4#4`s32DbxhwOUCvPq9OBlX< zZH3<3x~jsJmE7Q_Wsq~EUMP`t*{l`o8?{P~@Ej6T0?y@YrU`e%woG&QKVIQ)>-ErE zSt}9anUrej!iIZ~yyd8gH_k8`7w}lp7quC}=!UloK0p+bMot6o>~B zb&a9K@zxsf8Bo&>T>Qv@RcYKK90o}z4gtCgpfs+ji@;6;*u`EJH(}S8FP$oMQaqwv z^3PMjqA*ClS}mPdx~LZ?;VN-&c0nJDyP*pj8I8lBtFc&tYs;@rhn)^$?~#|zOeUx& zKR>g0@{T1~lRE;%-yjEoB6)F@oVZF3h>4~^NMyuCab-QPcLKZtJ^sUdYKi)2!}bG3 z{Kt$Op-zsxxDnKgL~VYpxL!9+aKnKx90>AYU|Mvz?>HdBlhwjrZ05p8YXG+q4h^XU zwQ{~>RyN9oVr?D3nEbTx9R_+VcDQiTYfwUkIFBK3f1G`k42$%2-ot$ f-e-^CuK?kJ%x%-$W||+q`CLltvVqK4Zmj!X-{Czb diff --git a/utils.el b/utils.el index 1713ae0..2e85a91 100644 --- a/utils.el +++ b/utils.el @@ -1865,7 +1865,7 @@ which is the identity, by default." (defmacro db-print (form) "Print the form FORM and its VALUE." - `(print (format "%S - %s" ',form ,form))) + `(print (format "%S - %S" ',form ,form))) (defun second (s) "return the second element of SEQ." @@ -2018,6 +2018,14 @@ result. Only works if the difference would fit in 16 bits." "CONS with its arguments swapped." (cons el lst)) +(defun insert-recent-file-buttons-list (n) + (let ((files (sh "ls -t"))) + (loop for file in (ix: files (range 0 (min n (length files)))) do + (insert-button file 'action + (lexical-let ((file file)) + (lambda (b) + (find-file file))))))) + (provide 'utils) diff --git a/utils.elc b/utils.elc index 3fd15cb88b98bab00e74888bdbd770f072eeabcd..a1c844b2a0f6be82e98a5dfc94113b38c4d263c9 100644 GIT binary patch delta 861 zcmZ8e-Afcv6n9KX7k24`){jLy&5*imSLfc@?-Gp4-BKa&O~+_-XKQGjjhWF}2&Enh z63Lii2_K?AA@0LI_6LLy_F#pNK4%d|Pe%9NDTp4`dB@L~ZWAfSOP!=iD=L|%PyzGj1rkYV35 z>YjMXK;eiKrziL?z4i}1QR$78=o(f#nZwM8UhOE|&}Cgt^|4gzk4K9-QMGbQbSxfcm2`~z zjJ~R2#)d<-{;pVjk};~fMz}F1LYQgH(y^|~?2{S4l2kY(dXbMl#YjnCON!56VNQlw zzPJYpW+xZh+9oJzwx!ra b$c^Rzi;C%zawb=aEXR0k&#&YxYE-Pjb)68J=wcaAI0yD$SzWo!J z1VN%k3d*Lo%2w_mw(;h76Wf@;icL0GPFVZF?%~CUSAo3QQ zyJx?%1}m`KTz5SmENX7B`O{5Luv&A&%?`KqCAok$m>cQpDk+pq7Pzf8dHxqxX^@bK zf?82(afyPm5zrYRmM%!tc=G-)H6Sz1jW#=cJj2wK}ks=H!(X^x41Gl zDL+R+Nmn;9r#!K;7_1Yh2x5gc*m!f8@y5u;n{96TE+NfWynVJ1V*oqY9*gZCBpDMR zF1DNwWb15ilxA$_0!dmJZ0A*Dya<-GFx>uFow1uypr9zfEHfolLA|sjGpAUS3ji$B BiuC{h