microstack first

VincentToups · Feb 2, 2011 · 9dabfe0 · 9dabfe0
1 parent 389253b
commit 9dabfe0
Show file tree

Hide file tree

Showing 12 changed files with 522 additions and 140 deletions.
diff --git a/functional.el b/functional.el
@@ -2,106 +2,124 @@
 (require 'utils)
 
 (defmacro defcompose (name &rest fs)
+  "Defun a new function NAME as a composition of other functions FS.  If (car FS) is a string, use this as the doc string."
   (let ((args (gensym (format "%s-args" name))))
-	`(defun ,name (&rest ,args)
-	   (apply (comp ,@fs) ,args))))
-
-(defun /|-argpred (x)
-  (and (symbolp x)
-	   (let* ((strv (format "%s" x))
-			  (first-char (substring strv 0 1))
-			  (rest-chars (substring strv 1 (length strv)))
-			  (rest-count (string-to-number rest-chars)))
-		 (and (string= "%" first-char)
-			  (> rest-count 0)))))
-
-(defun arg-num (arg)
-  (let* ((strv (format "%s" arg))
-		 (first-char (substring strv 0 1))
-		 (rest-chars (substring strv 1 (length strv)))
-		 (rest-count (string-to-number rest-chars)))
-	rest-count))
-
-(defun arg< (arg1 arg2)
-  (< (arg-num arg1) (arg-num arg2)))
-
-(defmacro* /| (&body body)
-  (let* ((expanded (macroexpand-all `(progn ,@body)))
-		 (usage-info (collect-usage-info expanded))
-		 (args (filter #'/|-argpred (get-unbound-symbols-list usage-info)))
-		 (args (functional-sort args #'arg<)))
-	`(function (lambda ,args ,expanded))))
-
-(defmacro defcurryl (newname oldname &rest args)
+	(if (stringp (car fs))
+		`(defun ,name (&rest ,args) ,(car fs)
+		   (apply (comp ,@(cdr fs)) ,args))
+	  `(defun ,name (&rest ,args)
+		 (apply (comp ,@fs) ,args)))))
+
+  (defun /|-argpred (x)
+	(and (symbolp x)
+		 (let* ((strv (format "%s" x))
+				(first-char (substring strv 0 1))
+				(rest-chars (substring strv 1 (length strv)))
+				(rest-count (string-to-number rest-chars)))
+		   (and (string= "%" first-char)
+				(> rest-count 0)))))
+
+  (defun arg-num (arg)
+	(let* ((strv (format "%s" arg))
+		   (first-char (substring strv 0 1))
+		   (rest-chars (substring strv 1 (length strv)))
+		   (rest-count (string-to-number rest-chars)))
+	  rest-count))
+
+  (defun arg< (arg1 arg2)
+	(< (arg-num arg1) (arg-num arg2)))
+
+  (defmacro* /| (&body body)
+	(let* ((expanded (macroexpand-all `(progn ,@body)))
+		   (usage-info (collect-usage-info expanded))
+		   (args (filter #'/|-argpred (get-unbound-symbols-list usage-info)))
+		   (args (functional-sort args #'arg<)))
+	  `(function (lambda ,args ,expanded))))
+
+(defmacro defcurrly-doc (newname doc f &rest args)
+  "Define a function by left-most partial application with doc string."
   (let ((narglist (gensym (format "%s-arglist" newname))))
 	`(defun ,newname (&rest ,narglist)
-	   (apply #',oldname ,@args ,narglist))))
+	   ,doc
+	   (apply ,f ,@args ,narglist))))
 
-(defmacro defcurryr (newname oldname &rest args)
+(defmacro defcurryl-no-doc (newname f &rest args)
+  "Define a function by left-most partial application without doc string."
   (let ((narglist (gensym (format "%s-arglist" newname))))
 	`(defun ,newname (&rest ,narglist)
-	   (apply #',oldname (append ,narglist (list ,@args))))))
-
-(defmacro clambdal (oldf &rest args)
-  (let ((narglist (gensym "clambdal-arglist-")))
-	`(lambda (&rest ,narglist)
-	   (apply ,oldf ,@args ,narglist))))
-
-(defmacro cl (&rest stuff)
-  `(clambdal ,@stuff))
-
-
-(defmacro clambdar (oldf &rest args)
-  (let ((narglist (gensym "clambdal-arglist-")))
-	`(lambda (&rest ,narglist)
-	   (apply ,oldf (append ,narglist (list ,@args))))))
-
-(defmacro cr (&rest stuff)
-  `(clambdar ,@stuff))
-
-
-(defmacro defdecorated (newname oldname transformer)
-  (let ((args (gensym (format "%s-decorated-args" newname))))
-	`(defun ,newname (&rest ,args)
-	   (apply #',oldname 
-			  (funcall #',transformer ,args)))))
-
-(defmacro lambdecorate (oldf transformer)
-  (let ((args (gensym (format "decorated-args"))))
-	`(lambda (&rest ,args)
-	   (apply #',oldf
-			  (funcall #',transformer ,args)))))
-
-(lex-defun f-and-2 (f1 f2)
-		   (lambda (&rest args) 
-			 (and (apply f1 args)
-				  (apply f2 args))))
-
-(lex-defun f-and (&rest fs)
-		   (reduce #'f-and-2 fs))
-
-(lex-defun f-or-2 (f1 f2)
-		   (lambda (&rest args)
-			 (or (apply f1 args)
-				 (apply f2 args))))
-
-(lex-defun f-or (&rest fs)
-		   (reduce #'f-or-2 fs))
-
-(lex-defun f-not (f)
-		   (lambda (&rest args)
-			 (not (apply f args))))
-
-(lex-defun f-mapcar (f)
-		   (lambda (&rest args)
-			 (apply #'mapcar (cons f args))))
-
-(lex-defun decorate-n (f index trans)
-		   (lambda (&rest args)
-			 (let* ((el (elt args index))
-					(new (funcall trans el)))
-			   (setf (elt args index) new)
-			   (apply f args))))
+	   (apply ,f ,@args ,narglist))))
+
+(defmacro defcurryl (newname &rest args)
+  "Define a function with left-most partial application on another function."
+  (if (stringp (car args))
+	  `(defcurryl-doc ,newname ,(car args) ,@(cdr args))
+	`(defcurryl-no-doc ,newname ,@args)))
+
+  (defmacro defcurryr (newname oldname &rest args)
+	(let ((narglist (gensym (format "%s-arglist" newname))))
+	  `(defun ,newname (&rest ,narglist)
+		 (apply #',oldname (append ,narglist (list ,@args))))))
+
+  (defmacro clambdal (oldf &rest args)
+	(let ((narglist (gensym "clambdal-arglist-")))
+	  `(lambda (&rest ,narglist)
+		 (apply ,oldf ,@args ,narglist))))
+
+  (defmacro cl (&rest stuff)
+	`(clambdal ,@stuff))
+
+
+  (defmacro clambdar (oldf &rest args)
+	(let ((narglist (gensym "clambdal-arglist-")))
+	  `(lambda (&rest ,narglist)
+		 (apply ,oldf (append ,narglist (list ,@args))))))
+
+  (defmacro cr (&rest stuff)
+	`(clambdar ,@stuff))
+
+
+  (defmacro defdecorated (newname oldname transformer)
+	(let ((args (gensym (format "%s-decorated-args" newname))))
+	  `(defun ,newname (&rest ,args)
+		 (apply #',oldname 
+				(funcall #',transformer ,args)))))
+
+  (defmacro lambdecorate (oldf transformer)
+	(let ((args (gensym (format "decorated-args"))))
+	  `(lambda (&rest ,args)
+		 (apply #',oldf
+				(funcall #',transformer ,args)))))
+
+  (lex-defun f-and-2 (f1 f2)
+			 (lambda (&rest args) 
+			   (and (apply f1 args)
+					(apply f2 args))))
+
+  (lex-defun f-and (&rest fs)
+			 (reduce #'f-and-2 fs))
+
+  (lex-defun f-or-2 (f1 f2)
+			 (lambda (&rest args)
+			   (or (apply f1 args)
+				   (apply f2 args))))
+
+  (lex-defun f-or (&rest fs)
+			 (reduce #'f-or-2 fs))
+
+  (lex-defun f-not (f)
+			 (lambda (&rest args)
+			   (not (apply f args))))
+
+  (lex-defun f-mapcar (f)
+			 (lambda (&rest args)
+			   (apply #'mapcar (cons f args))))
+
+  (lex-defun decorate-n (f index trans)
+			 (lambda (&rest args)
+			   (let* ((el (elt args index))
+					  (new (funcall trans el)))
+				 (setf (elt args index) new)
+				 (apply f args))))
 
 
 (provide 'functional)
diff --git a/lisp-parser.el b/lisp-parser.el
@@ -1,4 +1,6 @@
 (require 'monad-parse)
+(require 'cl)
+(provide 'lisp-parser)
 
 (lexical-let 
 	((also-ok-in-ids 
@@ -17,32 +19,64 @@
 
 (defun =lisp-symbol ()
   (=let* [_ (one-or-more (=id-char))]
-		 (coerce _ 'string)))
+		 (read (coerce _ 'string))))
 
 
 (defun =numeric-sequence ()
   (=let* [_ (one-or-more (=digit-char))]
 		 (coerce _ 'string)))
 
+(defun =int ()
+  (=let* [sign (zero-or-one (=or (=char->string ?-)
+								 (=char->string ?+)))
+			   s (=numeric-sequence)]
+		 (string-to-number (concat sign s))))
+
+
 (defun =char->string (char)
   (=let* [_ (=char char)]
 		 (coerce (list _) 'string)))
 
 (defun =number ()
-  (=let* [p1 (=numeric-sequence)
-			 dot?  (zero-or-one (=char->string ?.))
-			 p2 (zero-or-one (=numeric-sequence))]
-		 (concat p1 dot? p2)))
+  (=or (=float) (=int)))
+
+(defun =float ()
+  (=let* [sign (zero-or-one (=or (=char->string ?+) (=char->string ?-)))
+			   p1 (zero-or-more (=digit-char))
+			   dot (=char ?.)
+			   p2 (one-or-more (=digit-char))]
+		 (string-to-number (concat sign p1 "." p2))))
+
+
+(defunc =escaped-quote ()
+  (=let* [_ (=string "\\\"")]
+		 (if _ ?\" nil)))
+
+?\"
+
+(setq space  ?\s)
 
-(defun =escaped-quote ()
-  (=string "\\\""))
+(defun =spaces ()
+  (zero-or-more (=char ?\s)))
+(defun =space ()
+  (=char ?\s))
 
-(funcall (=escaped-quote) (->in "testbuffer.txt"))
+(defun =lisp-atom ()
+  (=let* [_ (=spaces)
+			atom (=or (=number)
+					  (=lisp-string)
+					  (=lisp-symbol))
+			]
+		 atom))
 
-(funcall (lisp-symbol) (->in "an"))
+(defunc =lisp-string ()
+  (=let* [_ (=char ?\")
+			contents (zero-or-more (=or 
+									(=escaped-quote)
+									(=satisfies
+									 (lex-lambda (c) (!= c ?\")))))
+			_ (=char ?\")]
+		 (coerce (flatten contents) 'string)))
 
-(funcall (=numeric-sequence) (->in "testbuffer.txt"))
 
-(funcall (=char ?1) (->in "testbuffer.txt"))
 
-(input-rest (->in "testbuffer.txt"))
diff --git a/lisp-parser.elc b/lisp-parser.elc