nydp 0.4.1 → 0.5.0

data/lib/lisp/core-030-syntax.nydp

@@ -21,16 +21,26 @@ scoping, assignment, anonymous functions and more...")
               (apply orf
                      (cdr args)))))
 
+; returns true if 'things is a list and the first item of the
+; list is the given object
 (def caris (obj things)
-  ; returns true if 'things is a list and the first item of the
-  ; list is the given object
   (and (pair? things)
-       (eq? (car things)  obj)))
+       (eq? (car things) obj)))
 
+; evaluate 'body if 'arg is nil
 (mac unless (arg . body)
-  ; evaluate 'body if 'arg is nil
   `(if (no ,arg) (do ,@body)))
 
+; looks up a key in @
+; assumes local lexical context has defined a hash called '@
+(mac prefix-at-syntax (name . names)
+  `(hash-get @ ',name))
+
+(mac at-syntax names
+  (if (eq? (car names) '||)
+      `(prefix-at-syntax ,@(cdr names))
+      (error "unknown at-syntax: expected prefix-syntax (eg @name), got ~(join-str (car names) "@" (cdr names))")))
+
 (def expand-colon-syntax (names)
   (if (no (cdr names))
           `(apply ,(car names) args)
@@ -84,13 +94,17 @@ scoping, assignment, anonymous functions and more...")
       (cons (list (car things) (cadr things))
             (pairs (cddr things)))))
 
+;; like 'let, but creates and assigns multiple local variables.
+;; for example, "(with (a 1 b 2) (+ a b))" returns 3
 (mac with (parms . body)
-     `((fun ,(map car (pairs parms))
-            ,@body)
-       ,@(map cadr (pairs parms))))
+  `((fun ,(map car (pairs parms))
+         ,@body)
+    ,@(map cadr (pairs parms))))
 
+;; create a lexical scope
+;; where val is assigned to var, execute 'body in that scope
 (mac let (var val . body)
-     `(with (,var ,val) ,@body))
+  `((fun (,var) ,@body) ,val))
 
 (mac rfn (name parms . body)
   ; creates a named, locally-scoped function
@@ -105,17 +119,28 @@ scoping, assignment, anonymous functions and more...")
   ; same as 'rfn, but using the name 'self
   `(rfn self ,parms ,@body))
 
+;; a mix of rfn and with; creates a locally-scoped named function with
+;; the given parameter names, and invokes it with the given parameter
+;; values. It is possible to reference the function by its name from
+;; within the function (to pass as an argument or for recursive
+;; invocation)
 (mac rfnwith (name params . body)
-  ; a mix of rfn and with; creates a locally-scoped named function with
-  ; the given parameter names, and invokes it with the given parameter
-  ; values. It is possible to reference the function by its name from
-  ; within the function (to pass as an argument or for recursive
-  ; invocation)
   (let ppairs (pairs params)
     `(let ,name nil
        (assign ,name (fun ,(map car ppairs) ,@body))
        (,name ,@(map cadr ppairs)))))
 
+;; (andify a b c) is equivalent to
+;; (fn args (and (apply a args) (apply b args) (apply c args)))
+;; or more simply
+;; (fn (x) (and (a x) (b x) (c x)))
+;; note: alias as 'andf ??
+(def andify args
+  (fn args2 (rfnwith self (ands args)
+                     (if ands (if (apply (car ands) args2)
+                                  (self (cdr ands)))
+                         t))))
+
 (let uniq-counter 0
   (def uniq (prefix)
     (assign uniq-counter (+ uniq-counter 1))
@@ -123,11 +148,11 @@ scoping, assignment, anonymous functions and more...")
   (def reset-uniq-counter ()
     (assign uniq-counter 0)))
 
+;; creates a lexical scope with a unique symbol assigned to
+;; each variable in 'vars ; executes the 'body.
 (mac w/uniq (vars . body)
-  ; creates a lexical scope with a unique symbol assigned to
-  ; each variable in 'vars ; executes the 'body.
   (if (pair? vars)
-      `(with ,(apply + (map (fn (n) (list n '(uniq ',n))) vars))
+      `(with ,(apply + (map (fn (n) `(,n (uniq ',n))) vars))
              ,@body)
       `(let ,vars (uniq ',vars) ,@body)))
 
@@ -194,45 +219,88 @@ scoping, assignment, anonymous functions and more...")
   (and (pair? name)
        (caris 'ampersand-syntax (car name))))
 
+;; (= (&key (expr)) (val))
+;; (= ((ampersand-syntax key) (expr)) (val))
+;; 'place is ((ampersand-syntax || key) (expr))
+;; we need (hash-set (expr) 'key (val))
+;; however,
+;; (= (&key.subkey (expr)) (val))
+;; 'place is ((ampersand-syntax || (dot-syntax key subkey)) (expr))
+;; we need (hash-set (hash-get (expr) 'key) 'subkey (val))
 (def ampersand-expression-assignment (place value)
-  ; (= (&key (expr)) (val))
-  ; (= ((ampersand-syntax key) (expr)) (val))
-  ; 'place is ((ampersand-syntax || key) (expr))
-  ; we need (hash-set (expr) 'key (val))
-  ; however,
-  ; (= (&key.subkey (expr)) (val))
-  ; 'place is ((ampersand-syntax || (dot-syntax key subkey)) (expr))
-  ; we need (hash-set (hash-get (expr) 'key) 'subkey (val))
-  (with (k   (cadr:cdar place)
-         hsh (cadr place))
-    (if (caris 'dot-syntax k)
-        (dot-syntax-assignment (cons hsh (cdr k)) value)
-        `(hash-set ,hsh ',k ,value))))
-
-(mac = (name value)
-  ; generic assignment which unlike builtin 'assign, knows how to assign
-  ; to hash keys
-  ; (= (hash-get (expr) 'key) (val) => (hash-set (expr) 'key (val))
-  ; (= h.k (val))                   => (hash-set h 'k (val))
-  ; (= h.j.k (val))                 => (hash-set (hash-get h 'j) 'k (val))
-  ; (= (&key (expr)) (val))         => (hash-set (expr) 'key (val))
-  ; (= (&j.k (expr)) (val))         => (hash-set (hash-get (expr) 'j) 'k (val))
-  (if (isa 'symbol name)
-      `(assign ,name ,value)
-      (caris 'dot-syntax name)
-      (dot-syntax-assignment (cdr name) value)
-      (caris 'hash-get name)
-      (hash-get-assignment (cdr name) value)
-      (ampersand-expression? name)
-      (ampersand-expression-assignment name value)))
-
-(mac def-assign args
-  ; override previous definition to allow expressions like (def hsh.foo (arg arg2) ...)
-  `(= ,@args))
-
-(mac or= (place val)
-  ; evaluate ,val and assign result to ,place only if ,place is already nil
-  `(or ,place (= ,place ,val)))
+  (let k (cadr:cdar place)
+    (let hsh (cadr place)
+      (if (caris 'dot-syntax k)
+          (dot-syntax-assignment (cons hsh (cdr k)) value)
+          `(hash-set ,hsh ',k ,value)))))
+
+;; used internally by 'destructuring-assign
+(def destructuring-assigns (names values acc)
+  (if names
+      (if (pair? names)
+          (destructuring-assigns
+            (cdr names)
+            `(cdr ,values)
+            (cons `(= ,(car names) (car ,values)) acc))
+          (cons `(= ,names ,values) acc))
+      (rev acc)))
+
+;; used internally by 'assign-expr
+(def destructuring-assign (name value)
+  (w/uniq destructuring-assign
+          `(let ,destructuring-assign ,value
+             ,@(destructuring-assigns name destructuring-assign))))
+
+;; used internally by '= macro
+(def assign-expr (nv)
+  (let name  (car nv)
+    (let value (cadr nv)
+      (if (isa 'symbol name)
+          `(assign ,name ,value)
+          (caris 'dot-syntax name)
+          (dot-syntax-assignment (cdr name) value)
+          (caris 'hash-get name)
+          (hash-get-assignment (cdr name) value)
+          (ampersand-expression? name)
+          (ampersand-expression-assignment name value)
+          (caris 'at-syntax name)
+          `(hash-set @ ',(caddr name) ,value)
+          (pair? name)
+          (destructuring-assign name value)
+          (error "unknown assignment to place: " (inspect name))))))
+
+;; generic assignment which unlike builtin 'assign, knows how to assign
+;; to hash keys
+;; (= (hash-get (expr) 'key) (val) => (hash-set (expr) 'key (val))
+;; (= h.k (val))                   => (hash-set h 'k (val))
+;; (= h.j.k (val))                 => (hash-set (hash-get h 'j) 'k (val))
+;; (= (&key (expr)) (val))         => (hash-set (expr) 'key (val))
+;; (= (&j.k (expr)) (val))         => (hash-set (hash-get (expr) 'j) 'k (val))
+(mac = assignments
+  `(do ,@(map assign-expr (pairs assignments))))
+
+;; like 'let, but creates and assigns multiple local variables.
+;; for example, "(with (a 1 b 2) (+ a b))" returns 3
+;;
+;; later variables can references earlier ones:
+;; (with (a 1 b 2 c (+ a b)) (list a b c)) ;; returns (1 2 3)
+(mac with (assignments . body)
+  `((fun ,(map car (pairs assignments))
+     (= ,@assignments)
+     ,@body) nil))
+
+;; quiet assignment ; like =, but expression returns nil
+(mac #= (name value)
+  `(do (= ,name ,value) nil))
+
+; increment the value at 'place by 'inc (default 1)
+(mac ++ (place inc) `(= ,place (+ ,place ,(or inc 1))))
+
+; override previous definition to allow expressions like (def hsh.foo (arg arg2) ...)
+(mac def-assign args `(= ,@args))
+
+; evaluate ,val and assign result to ,place only if ,place is already nil
+(mac or= (place val) `(or ,place (= ,place ,val)))
 
 (def brace-list-hash-key (k)
   (if (isa 'symbol k)      `(quote ,k)
@@ -259,43 +327,48 @@ scoping, assignment, anonymous functions and more...")
       (error "Irregular '& syntax: got suffix ~(inspect (cdr rest)) in ~(join-str pfx "&" rest)")
       (build-ampersand-syntax (car rest))))
 
-(mac brace-list-mono (arg)
-  ; override 'brace-list-mono in order to provide a useful interpretation for "{ x }" syntax
-  arg)
+; override 'brace-list-mono in order to provide a useful interpretation for "{ x }" syntax
+(mac brace-list-mono (arg) arg)
 
-(mac brace-list-empty ()
-  ; interprets "{ }" as new hash
-  '(hash))
+; interprets "{ }" as new hash
+(mac brace-list-empty () '(hash))
 
+; parser expands { foo bar } to (brace-list foo bar)
 (mac brace-list args
-  ; parser expands { foo bar } to (brace-list foo bar)
   (if (no args)
       `(brace-list-empty)
       (no (cdr args))
       `(brace-list-mono ,(car args))
       (brace-list-build-hash args)))
 
-(mac returnlet (var val . body)
-  ; stores ,val in ,var, executes ,@body, returns ,var. Saves a line of code at the end of
-  ; 'let. Assumes 'body is going to do something destructive with 'val, but you want 'val before
-  ; it gets changed. See also 'returning
-  `(let ,var ,val ,@body ,var))
+; stores ,val in ,var, executes ,@body, returns ,var. Saves a line of code at the end of
+; 'let. If 'body assigns to 'var, the assigned value of 'var will be returned. See also 'returning
+(mac returnlet (var val . body) `(let ,var ,val ,@body ,var))
 
-(mac returning (val . body)
-  ; stores ,val, executes ,@body, and returns ,val. Assumes 'body is going to do something
-  ; destructive with 'val, but you want 'val before it gets changed. See also 'returnlet
-  (w/uniq retval `(returnlet ,retval ,val ,@body)))
+; stores ,val, executes ,@body, and returns ,val. Assumes 'body is going to do something
+; destructive with 'val, but you want 'val before it gets changed. Note that if 'val is mutated
+; (eg hash), the mutated value will be returned. See also 'returnlet
+(mac returning (val . body) (w/uniq retval `(returnlet ,retval ,val ,@body)))
 
-(mac aif (expr . body)
-  ; like if, except the value of each condition is locally bound to the variable 'it
-  ; eg (aif (find thing) (show it))
-  ; source: arc.arc
-  `(let it ,expr
-     (if it
+(mac ifv (var expr . body)
+  `(let ,var ,expr
+     (if ,var
          ,@(if (cddr body)
-               `(,(car body) (aif ,@(cdr body)))
+               `(,(car body) (ifv ,var ,@(cdr body)))
                body))))
 
+; like if, except the value of each condition is locally bound to the variable 'it
+; eg (aif (find thing) (show it))
+; source: arc.arc
+(mac aif (expr . body)
+  `(ifv it ,expr ,@body))
+
+;; returns the n-th item in the list 'things
+(def nth (n things)
+  (if (eq? n 0)
+      (car things)
+      (nth (- n 1) (cdr things))))
+
 (def destructure/with (var args n)
   ; provides the argument expression to 'with when
   ; destructuring arguments are present in a 'fun definition
@@ -304,30 +377,52 @@ scoping, assignment, anonymous functions and more...")
       args
       `(,args (nthcdr ,n ,var))))
 
-(def destructure/build (given-args new-args body)
-  ; used internally by 'fun
+;; issue a warning if any arg name is the name of a macro
+(def fun/approve-arg-names (orig args body)
+  (if (pair? args)
+      (do (fun/approve-arg-names orig (car args) body)
+          (fun/approve-arg-names orig (cdr args) body))
+      args
+      (if (hash-get macs args)
+          (warnings/new 'arg-shadows-macro "arg " args " shadows macro " args " in arg list " orig " and body " body))))
+
+;; used internally by 'fun
+(def destructure/build (given-args new-args body next)
   (if (pair? given-args)
       (if (sym? (car given-args))
           (destructure/build (cdr given-args)
                              (cons (car given-args) new-args)
-                             body)
+                             body
+                             next)
           (w/uniq destructure
                   (destructure/build (cdr given-args)
                                      (cons destructure new-args)
-                                     `((with ,(destructure/with destructure (car given-args) 0) ,@body)))))
-      `(fn ,(rev new-args given-args) ,@body)))
-
-
-(def fun/approve-arg-names (orig args)
-  (if (pair? args)
-      (do (fun/approve-arg-names orig (car args))
-          (fun/approve-arg-names orig (cdr args)))
-      args
-      (if (hash-get macs args)
-          (warnings/new 'arg-shadows-macro "arg " args " shadows macro " args " in arg list " orig))))
-
+                                     `((with ,(destructure/with destructure (car given-args) 0) ,@body))
+                                     next)))
+      (next (rev new-args given-args) body)))
+
+(def fun/destructuring-args (args body next)
+  (fun/approve-arg-names args args body)
+  (destructure/build args nil body next))
+
+(assign fun/expanders
+        (list
+         (cons 'destructuring-args fun/destructuring-args)
+         (cons 'core-builder       (fn (args body next) `(fn ,args ,@body)))))
+
+(def fun/expand (args body expanders)
+  (if expanders
+      ((cdar expanders)
+       args
+       body
+       (fn (a b)
+           (fun/expand a b (cdr expanders))))))
+
+;; build a 'fn form, changing 'args and 'body to
+;; properly handle any destructuring args if present
 (mac fun (args . body)
-  ; build a 'fn form, changing 'args and 'body to
-  ; properly handle any destructuring args if present
-  (fun/approve-arg-names args args)
-  (destructure/build args nil body))
+  (fun/expand args body fun/expanders))
+
+;; assign (f place) to place
+(mac zap (f place . args)
+  `(= ,place (,f ,place ,@args)))

data/lib/lisp/core-035-flow-control.nydp

@@ -13,9 +13,9 @@
   `(ensuring (fn () ,protection)
              (fn ()    ,@body)))
 
+;; tests 'test, as long as 'test is non-nil,
+;; repeatedly executes 'body
 (mac while (test . body)
-  ; tests 'test, as long as 'test is non-nil,
-  ; repeatedly executes 'body
   (w/uniq (rfname pred)
     `(rfnwith ,rfname (,pred ,test)
         (when ,pred
@@ -40,29 +40,56 @@
        (loop (assign ,v ,gi) (< ,v ,gm) (assign ,v (+ ,v 1))
          ,@body))))
 
-(mac curry (func . args1)
-  ; return a new function which is the original function with
-  ; the given args1 already applied
-  ; arguments to the new function are whatever arguments remain
-  ; for the old function
-  `(fn args (apply ,func ,@args1 args)))
+;; return a new function which is the original function with
+;; the given args1 already applied
+;; arguments to the new function are whatever arguments remain
+;; for the old function
+;; Could be (mac curry things `(fn args (apply ,@things args))) but less readable
+(mac curry (f . args0)
+  `(fn args
+       (apply ,f ,@args0 args)))
+
+;; like curry, but the returned function takes only a single arg (assumes all
+;; args but one are provided here)
+;; Could be (mac curry1 things `(fn (arg) (,@things arg))) but less readable
+(mac curry1 (f . args)
+  `(fn (arg)
+       (,f ,@args arg)))
 
 (mac cache-get (hsh key val)
   ; if ,key is already in ,hsh - return the associated value.
   ; if ,key is not already in ,hsh - evaluate ,val, store the result
   ; under ,key in ,hsh, and return it
   (w/uniq (h k v)
-    `(with (,h ,hsh ,k ,key)
-           (let ,v (hash-get ,h ,k)
-             (or ,v (returnlet ,v ,val (hash-set ,h ,k ,v)))))))
+          `(with (,h ,hsh ,k ,key)
+                 (let ,v (hash-get ,h ,k)
+                   (or ,v (returnlet ,v ,val (hash-set ,h ,k ,v)))))))
 
+;; same as 'def, but caches the result, keyed on args, so for a given set of args the result
+;; is only ever calculated once
+;;
+;; WARNING: in current incarnation, won't work with destructuring args
 (mac defmemo (name args . body)
-  ; same as 'def, but caches the result, keyed on args, so for a given set of args the result
-  ; is only ever calculated once
-  (let forms (filter-forms (build-def-hash (hash)) body)
+  (let forms (filter-forms (build-def-hash) body)
     (w/uniq h
             `(let ,h (hash)
                (def ,name ,args
                  ,@(map (fn (c) (cons 'comment c)) forms.comment)
                  ,@(map (fn (c) (cons 'chapter c)) forms.chapter)
                  (cache-get ,h (list ,@args) (do ,@(hash-get forms nil))))))))
+
+;; memoises a function expression
+;; args: the function arguments
+;; body: a list of function body expressions
+;; next: a function to assemble a function expression from 'args and 'body
+;; returns whatever 'next returns, where 'body is memoised based on the value of 'args
+(def memoise (args body next)
+  (let (memo newbody) (filter-remove '#memoise body)
+    (if memo
+        (w/uniq h
+                `(let ,h (hash) ,(next args `((cache-get ,h (list ,@args) (do ,@newbody))))))
+        (next args body))))
+
+(assign fun/expanders
+        (cons
+         (cons 'memoise memoise) fun/expanders))

data/lib/lisp/core-037-list-utils.nydp

@@ -6,35 +6,57 @@
       (cons (map car args)
             (apply zip (map cdr args)))))
 
+; invokes 'f for each element of 'things, first element processed first
+; ( "l" in "eachl" = "leftmost first" )
+(def eachl (f things)
+     (when things
+       (f (car things))
+       (eachl f (cdr things))))
+
+;; if things is a pair,
+;;   if (cdr things) is nil, return (car things)
+;;   else recurse on (cdr things)
+;; else return things
+(def list/last (things)
+  (if (pair? things)
+      (aif (cdr things)
+           (list/last it)
+           (car things))
+      things))
+
+; invokes 'f for each element of 'things, last element processed first
+; ( "r" in "eachr" = "rightmost first" )
 (def eachr (f things)
      (when things
        (eachr f (cdr things))
        (f (car things))))
 
-(mac push (x things)
-  ; assign (cons x things) to things
-  `(= ,things (cons ,x ,things)))
+; assign (cons x things) to things
+(mac push (x things) `(= ,things (cons ,x ,things)))
 
-(def flatten (things)
-  ; flatten the given list, recursively
+; flatten the given list, transforming each leaf-item, recursively
+(def flatmap (f things)
      (let acc nil
           (rfnwith flattenize (x things)
                    (if (pair? x)
                        (eachr flattenize x)
-                       (push x acc)))
+                       x
+                       (push (f x) acc)))
           acc))
 
+; flatten the given list, recursively
+(def flatten (things) (flatmap x1 things))
+
+; given a list 'al of form '( (k0 v0) (k1 v1) (k2 v2) ... (kn vn) ) and
+; a 'key, returns the list (kx vx) from 'al where kx is equal to 'key
+; #attribution: inspiration from arc.arc
 (def assoc (key al)
-  ; given a list 'al of form '( (k0 v0) (k1 v1) (k2 v2) ... (kn vn) ) and
-  ; a 'key, returns the list (kx vx) from 'al where kx is equal to 'key
-  ; #attribution: inspiration from arc.arc
   (if (pair? al)
       (if (caris key (car al))
           (car al)
           (assoc key (cdr al)))))
 
-(def alref (key al)
-  ; given a list 'al of form '( (k0 v0) (k1 v1) (k2 v2) ... (kn vn) ) and
-  ; a 'key, returns vx from 'al where kx is equal to 'key
-  ; #attribution: lifted almost directly from arc.arc
-  (cadr (assoc key al)))
+; given a list 'al of form '( (k0 v0) (k1 v1) (k2 v2) ... (kn vn) ) and
+; a 'key, returns vx from 'al where kx is equal to 'key
+; #attribution: lifted almost directly from arc.arc
+(def alref (key al) (cadr (assoc key al)))