Permalink
Browse files

microstack first

  • Loading branch information...
1 parent 389253b commit 9dabfe0fa0a28641f8c7af0f8884261938232ed8 @VincentToups committed Feb 2, 2011
View
@@ -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)
View
@@ -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"))
View
Binary file not shown.
Oops, something went wrong.

0 comments on commit 9dabfe0

Please sign in to comment.