nydp 0.4.0 → 0.4.6

data/lib/lisp/core-045-dox-utils.nydp

@@ -90,3 +90,8 @@ Examples for ~name
   (chapter nydp/documentation)
   (let ch (chapter-find chapter-name)
     (= ch.contents (collect (fn (item) (!eq? item.name item-name)) ch.contents))))
+
+; return the first dox item of the given type with the given name
+(def dox-item-by-type (type name)
+  (let n (sym name)
+    (detect (fn (i) (eq? n i.name)) (dox-items-by-type type))))

data/lib/lisp/core-080-pretty-print.nydp

@@ -1,13 +1,39 @@
+
+;;
+;; problem: work out where a starting column of a form on its starting line, need to add
+;; this amount to its indent if it is broken
+;;
+;; TODO:
+;;
+;; alternative approach: given a form <expr>, ask <expr> recursively
+;; to provide the following:
+;;
+;; { inline: (... <sub-expr> <sub-expr> ...)
+;;   broken: (... <newline "  "> <sub-expr> <newline "  "> <sub-expr> ...)  }
+;;
+;; printer returns <inline> if acceptable, otherwise produces <broken>, recursively deciding on <inline>
+;; for each <sub-expr>
+;;
+;; each <newline "  "> carries the amount of indent required for the containing form, needs to be added to
+;; the amount of indent required for outer forms
+;;
+;;
+;;
+;; also TODO:
+;;
+;; use (module pp ...) and remove all those prefixes...
+;;
+
 (assign pp/special-forms (hash))
 (assign pp/syntaxes      (hash))
 (assign pp/newline       (uniq 'newline))
 (assign pp/newline/noi   (uniq 'newline/noi))
 
+;; (eq? char "\n") "\\n"
 (def pp/esc-ch (char)
   (if (eq? char "\"") "\\\""
       (eq? char "\~") "\\\~"
       (eq? char "\\") "\\\\"
-      (eq? char "\n") "\\n"
       char))
 
 (def pp/esc-str-literal (txt)
@@ -35,11 +61,11 @@
       (isa 'hash thing)          "{ ~(joinstr " " (pp/kv thing)) }"
       (inspect thing)))
 
+;; define a pretty-printer function for forms beginning with the
+;; given name. 'args are usually (form indent), form being the
+;; complete form for pretty-printing, and indent being the current
+;; indent level.
 (mac pp/def (name args . body)
-  ; define a pretty-printer function for forms beginning with the
-  ; given name. 'args are usually (form indent), form being the
-  ; complete form for pretty-printing, and indent being the current
-  ; indent level.
   `(do (hash-set pp/special-forms ',name
                  (fun ,args ,@body))
        (dox-add-doc ',name
@@ -48,6 +74,7 @@
                     ',args
                     '(pp/def ,name ,args ,@body))))
 
+
 (pp/def string-pieces    (pp form indent) (pp/string-pieces pp (cdr form)))
 (pp/def quasiquote       (pp form indent) "`~(pp (cadr form) (cons "" indent))" )
 (pp/def quote            (pp form indent) "'~(pp (cadr form) (cons "" indent))" )
@@ -55,7 +82,12 @@
 (pp/def unquote-splicing (pp form indent) ",@~(pp (cadr form) (cons " " indent))")
 (pp/def comment          (pp form indent) "; ~(cadr form)\n")
 (pp/def prefix-list      (pp form indent) "~(cadr form)~(pp (caddr form))")
-(pp/def brace-list       (pp form indent) "{ ~(joinstr " " (map λe(pprint e (cons "  " indent)) (cdr form))) }")
+
+
+(def pp/brace-list-pair (pp (k v) indent) "~k ~(pp v indent)")
+
+(pp/def brace-list (pp form indent)
+  "{ ~(joinstr " " (map λe(pprint e (cons " " indent)) (intersperse-splicing pp/newline (pairs:cdr form)))) }")
 
 (def pp/unsyntax (form)
   (if (pair? form)
@@ -65,15 +97,16 @@
             (map pp/unsyntax form)))
       form))
 
-(hash-set pp/syntaxes 'percent-syntax "%")
-(hash-set pp/syntaxes 'colon-syntax ":")
-(hash-set pp/syntaxes 'dot-syntax   ".")
-(hash-set pp/syntaxes 'bang-syntax  "!")
-(hash-set pp/syntaxes 'ampersand-syntax "&")
-(hash-set pp/syntaxes 'dollar-syntax "$")
-(hash-set pp/syntaxes 'colon-colon-syntax "::")
-(hash-set pp/syntaxes 'arrow-syntax "->")
-(hash-set pp/syntaxes 'rocket-syntax "=>" )
+(hash-set pp/syntaxes 'percent-syntax     "%"  )
+(hash-set pp/syntaxes 'colon-syntax       ":"  )
+(hash-set pp/syntaxes 'dot-syntax         "."  )
+(hash-set pp/syntaxes 'bang-syntax        "!"  )
+(hash-set pp/syntaxes 'ampersand-syntax   "&"  )
+(hash-set pp/syntaxes 'dollar-syntax      "$"  )
+(hash-set pp/syntaxes 'colon-colon-syntax "::" )
+(hash-set pp/syntaxes 'arrow-syntax       "->" )
+(hash-set pp/syntaxes 'rocket-syntax      "=>" )
+(hash-set pp/syntaxes 'at-syntax          "@"  )
 
 (def pp/dotify (form)
   (if (pair? form)
@@ -160,9 +193,14 @@
       (pprint (pp/break-pair form) indent)
       (pp/literal form indent)))
 
+;; better than (def pp (form) (inspect form))
 (def pp (form) (pp/cleanup:pp/printer (pp/dotify:pp/unsyntax form) nil))
-;; (def pp (form) (inspect form))
 
+;; use the pretty-printer to elegantly display the given source code
 (def dox-show-src (src)
-  ; use the pretty-printer to elegantly display the given source code
   (pp src))
+
+;; use 'pp/unsyntax to convert 'def and 'mac names back to a symbol
+;; so (mac dsl.foo (a1 a2) ...) will be documented as "dsl.foo"
+(def dox-build-def-name (name)
+  (pp/unsyntax name))

data/lib/lisp/core-090-hook.nydp

@@ -35,7 +35,39 @@
     (each hook (hooks-for hook-name)
           (apply hook args))))
 
-(add-hook 'warnings/new λw(apply p w))
+;; install a hook for a particular kind of event
+;;
+;; example
+;; (on transaction (account amount) (update account total (+ account.total amount)))
+;;
+;; same as (add-hook 'transaction (fn (account amount) (update account total (+ account.total amount))))
+;;
+;; if 'body is nil and 'args is a symbol, for example
+;;
+;; (on transaction notify)
+;;
+;; 'notify must be a predefined function accepting any arguments to the 'transaction event ; the example is equivalent to
+;;
+;; (add-hook 'transaction (fn args (apply notify args)))
+;;
+;; or more simply
+;;
+;; (add-hook 'transaction (fn (account amount) (notify account amount)))
+;;
+(mac on (event args . body)
+  (let hookfn (if (isa 'symbol (car body))
+                  (car body)
+                  `(fn ,args ,@body))
+    (w/uniq dox-item
+      `(let ,dox-item (car:dox-lookup ',event)
+         (if (no ,dox-item) (error "unknown hook ~(just ',event)"))
+         (add-hook ',event ,hookfn)
+         (hash-cons ,dox-item 'hooks
+            { src      ',hookfn
+              args     ',args
+              chapter  (chapter-current)
+              file     this-script
+              plugin   this-plugin })))))
 
 (let super warnings/new
   (def warnings/new (kind . info)
@@ -43,3 +75,5 @@
     (chapter nydp/warnings)
     (apply super kind info)
     (run-hooks 'warnings/new (cons kind info))))
+
+(on warnings/new w (apply p w))

data/lib/lisp/core-100-utils.nydp

@@ -1,3 +1,5 @@
+(chapter-start 'list-manipulation)
+
 (def include? (thing things)
   ; alias for 'detect
   ; true if thing is in things, nil otherwise
@@ -15,13 +17,28 @@
            (map λx(hash-get tmp x)
                 (sort:hash-keys tmp)))))
 
-(def mapsum (f things)
-  ; map 'f over 'things and sum the resulting list
-  (apply + 0.0 (map f things)))
+; like 'sort-by, except when 'f returns nil, use 'instead as the sort key instead
+(def safe-sort-by (f instead things)
+  (sort-by λi(or (f i) instead) things))
+
+;; takes a function f, returns a new function that takes a list and sorts the list by 'f
+(def sort-by-f (f) (curry1 sort-by f))
+
+;; takes a function f, returns a new function that takes a list and sorts the list by 'f
+(def safe-sort-by-f (f instead) (curry1 safe-sort-by f instead))
+
+(def mapreduce (fmap freduce things)
+  ; same as (reduce freduce (map fmap things))
+  ; returns the resulting list
+  (if (pair? things)
+      (freduce (fmap (car things))
+               (mapreduce fmap freduce (cdr things)))
+      things
+      (freduce (map fmap things))
+      (freduce)))
 
-(def hash-values (h)
-  ; return values for each key in hash 'h
-  (map (fn (k) h.,k) (hash-keys h)))
+; map 'f over 'things and sum the resulting list
+(def mapsum (f things) (mapreduce f + things))
 
 (def seen? ()
   ; returns a new function f which takes a parameter x
@@ -33,13 +50,12 @@
   (let seen (hash)
     λx(returning seen.,x (= seen.,x t))))
 
-(def uniqify (things)
-  ; return a list containing all the elements of 'things, but with no duplicates
-  (reject (seen?) things))
+; return a list containing all the elements of 'things, but with no duplicates
+(def uniqify (things) (reject (seen?) things))
 
+;; return a hash of 'things keyed by (f thing) for
+;; each thing in 'things
 (def group-by (f things)
-  ; return a hash of 'things keyed by (f thing) for
-  ; each thing in 'things
   (returnlet hsh {}
     (each thing things
           (hash-cons hsh (f thing) thing))))
@@ -54,29 +70,51 @@
         (let mi (m2i anchor)
           (map λm(i2m (+ mi m)) mm))))
 
-(mac auto-hash names
-  ; (auto-hash a b c) same as { a a b b c c }
-  `(brace-list ,@(flatten:map λn(list n n) names)))
-
+;; each call to the name 'accfn-name with an arg will append the arg to the end of a list.
+;; This form returns the resulting list.
+;; Example (collect first names from a list of people)
+;;
+;;   (accum a (each person people (a person.firstname)))
+;;
+;; will return (Alice Bob Carol Declan Eliza Fionn)
+;;
 (mac accum (accfn-name . body)
-  (w/uniq acc
-    `(let ,acc nil
-       (let ,accfn-name λa(push a ,acc)
+  (w/uniq (things last-cons)
+    `(with (,last-cons (cons) ,things nil)
+       (= ,things ,last-cons)
+       (let ,accfn-name (fn (a) (= ,last-cons (cdr-set ,last-cons (cons a))) a)
          ,@body
-         (rev ,acc)))))
-
-(mac ++ (place inc)
-  `(= ,place (+ ,place ,(or inc 1))))
-
+         (cdr ,things)))))
+
+;; like 'accum, except 'accfn-name expects 2 args, a key and a value
+;; value is hash-consed onto key in an internally-maintained hash
+;; the form returns the resulting hash
+;; values are in reverse order
+(mac accum-hash (accfn-name . body)
+  (w/uniq (hsh)
+    `(with (,hsh (hash))
+           (let ,accfn-name (fn (k a) (hash-cons ,hsh k a))
+             ,@body
+             ,hsh))))
+
+; return a list containing the range of elements starting with 'start,
+; up to but not including 'stop
+(def range (start stop)
+  (accum acc
+         (rfnwith r (n start)
+           (if (< n stop)
+               (r (+ (acc n) 1))))))
+
+; return a function that returns 'start on first invocation,
+; and 'start + n * 'incr for each nth invocation
 (def seqf (start incr)
   (let i (or incr 1)
     (fn () (returning start (++ start i)))))
 
-(def mapply (f args)
-  ; like 'map, but assumes each item in 'args is a list
-  ; of parameters for 'f. Effectively, calls (apply f item)
-  ; for each item in 'args
-  (map λa(apply f a) args))
+; like 'map, but assumes each item in 'args is a list
+; of parameters for 'f. Effectively, calls (apply f item)
+; for each item in 'args
+(def mapply (f args) (map λa(apply f a) args))
 
 (mac def/cycler (name things)
   ; create a function called 'name ; each invocation of the function will
@@ -138,3 +176,67 @@
                   (fill-buckets others max buckets size-f key))))
           (fill-buckets items max (bucket/new buckets) size-f key))
       buckets))
+
+; return the list except for the last element
+(def all-but-last (things)
+  (accum acc
+         ((afn (xs)
+            (when (cdr xs)
+              (acc (car xs))
+              (self (cdr xs))))
+          things)))
+
+;; returns a list containing 'existing items, that has at least 'minimum items, building new items if necessary
+;;
+;; useful if you want to show, for example, two parent fields, but you don't know in advance whether there
+;; are zero, one, two, or more parents already present
+;;
+;; existing: the existing list
+;; buildf: a zero-argument function to build a new item
+;; minimum: the minimum number of items in the returned list.
+;;
+(def list/fill (existing buildf minimum)
+  (let missing (- minimum (len existing))
+    (if (> missing 0)
+        (+ existing (map buildf (range 0 missing)))
+        existing)))
+
+;; recursively search the given form for forms matching 'matcher
+;; matcher is a function which returns nil for non-match, anything else for match
+;; returns the list of non-nil objects returned by 'matcher
+;; 'matcher will be called with the entire form, and if the form is a list, with each element of the form, recursively
+(def list/grep (matcher form)
+  (accum matches
+    (let maybe λi(if (matcher i) (matches i))
+      (list/traverse maybe maybe form))))
+
+;; recursively seeks forms in 'form whose car is 'symbol
+(def list/seek-cars (symbol form)
+  (list/grep λf(caris symbol f) form))
+
+;; helper function for 'case macro
+(def case/make-conds (test varname conds acc)
+  (if conds
+      (let (cnd expr) (car conds)
+        (if (eq? cnd 'else)
+            (acc expr)
+            (do (acc `(,test ,varname ,cnd))
+                (acc expr)
+                (case/make-conds test
+                                 varname
+                                 (cdr conds)
+                                 acc))))))
+
+;; usage: (case eq? person.name
+;;              "conan" (greet person)
+;;              "egg"   (delete person)
+;;              "bach"  (play person)
+;;              else    (interrogate person))
+(mac case (test what . conditions)
+  (w/uniq caseval
+    `(let ,caseval ,what
+       (if ,@(accum a
+                    (case/make-conds test
+                                     caseval
+                                     (pairs conditions)
+                                     a))))))

data/lib/lisp/core-110-hash-utils.nydp

@@ -0,0 +1,61 @@
+(chapter-start 'hash-manipulation "utilities for manipulating, accessing and altering hash objects")
+
+; return values for each key in hash 'h
+(def hash-values (h)
+  (map λk(hash-get h k)
+       (hash-keys h)))
+
+; (auto-hash a b c) same as { a a b b c c }
+(mac auto-hash names
+  `(brace-list ,@(flatten:map λn(list n n) names)))
+
+;; like 'map, but for a hash instead of a list ; provided function 'f takes three arguments,
+;; a key, the corresponding value from the given hash, and the index of the item in the list
+(def map-hash (f h pre)
+  (map-with-index λki(f k (hash-get h k) i)
+                  ((or pre x1) (hash-keys h))))
+
+;; returns a new hash with the same keys as the given hash, with each value transformed by
+;; the given function 'f
+;; 'f takes three arguments:
+;; k, the key
+;; v, the value
+;; i, the index
+;;
+(def hash-transform-values (f h pre)
+  (returnlet newh {}
+    (map-hash λkvi(hash-set newh k (f k v i)))))
+
+
+;; Return a new hash where keys are (map f things) and values are the corresponding things.
+;; No attempt is made to avoid clobbering items. Use 'group-by if there are duplicate keys.
+(def hashify (f things)
+  (returnlet hsh {}
+             (each thing things
+                   (hash-set hsh (f thing) thing))))
+
+;; like 'group-by, except 'f returns multiple items, each of which
+;; is used to key the thing in question
+(def subgroup-by (f things)
+  (returnlet hsh {}
+    (each thing things
+          (each k (f thing)
+                (hash-cons hsh k thing)))))
+
+;; return a new hash containing all the values of the given
+;; hash, but with each corresponding key 'k replaced by (f k)
+(def hash-replace-keys (f hsh)
+  (returnlet newh {}
+    (each k (hash-keys hsh)
+      (hash-set newh (f k) (hash-get hsh k)))))
+
+;; repeatedly assigns an element of hash-keys of 'things to 'kvar,
+;; assign the corresponding value to 'vvar
+;; and executes 'body for each key-value pair
+;; return value of form is whatever the last line of 'body returns
+(mac hash-each (kvar vvar things . body)
+  (w/uniq xs
+    `(let ,xs ,things
+       (each ,kvar (hash-keys ,xs)
+         (let ,vvar (hash-get ,xs ,kvar)
+           ,@body)))))

data/lib/lisp/core-120-settings.nydp

@@ -0,0 +1,46 @@
+(chapter-start 'settings "Utilities for managing settings")
+
+(assign settings {})
+(assign initial-settings {})
+
+; convert expr to a function that returns the expr, unless expr is a symbol in which case we assume it already refers to a fn
+(def settings/fn (expr)
+  (if (sym? expr)                 expr
+      (or (atom? expr) (no expr)) `(k ,expr)
+      (hash? expr)                `(k ',expr)
+      (caris 'quote expr)         `(k ,expr)
+      (caris 'brace-list expr)    `(k ,expr)
+                                  `(fn (_) ,expr)))
+
+; update value of setting 'name
+(mac set-setting (name value)
+  `(do (hash-cons (dox-item-by-type 'setting ',(sym name))
+                  'values
+                  { plugin this-plugin script this-script value ',value })
+       (hash-set settings ',(sym name) ,(settings/fn value))))
+
+; update value of setting 'name
+(mac reset-setting (name)
+  `(set-setting ,name ,(hash-get initial-settings (sym name))))
+
+(mac def-setting (name initial)
+  ; define a setting in the given 'context with a 'name and an 'initial value, with a 'doc to explain it
+  ; if value is a function, it is invoked with 'context and 'name to retrieve its value
+  ; if value is a constant, it is wrapped in a function to return the constant
+  (let context (car:string-split name ".")
+    `(do (dox-add-doc ',(sym name)
+                      'setting
+                      ',(fetch-and-clear-comments)
+                      nil
+                      '(def-setting ,name ,initial)
+                      '(,(sym "settings/~context"))
+                      { setting { default ',initial context ',context name ',name } })
+         (hash-set initial-settings ',(sym name) ',initial)
+         (set-setting ,(sym name) ,initial))))
+
+; get the value of the given setting. Raises an error if the setting is unknown
+(def setting (name)
+  (aif (hash-get settings (sym name))
+       (on-err (error "can't get value of setting ~name : stored object is ~(inspect it)")
+               (it name))
+       (error "unknown setting ~(inspect name)")))