nydp 0.4.2 → 0.5.1

data/lib/lisp/core-070-prefix-list.nydp

@@ -29,5 +29,5 @@
 (define-prefix-list-macro "^λ.*" vars expr
   ;; allows (map λa(upcase a.name) people)
   ;; as shortcut for (map (fn (a) (upcase a.name)) people)
-  (let var-list (map sym (collect !empty? (cdr:string-split vars)))
+  (let var-list (map sym (collect !empty? (cdr:string-split vars "")))
     `(fn ,var-list ,expr)))

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)
@@ -17,6 +43,8 @@
   (fn (thing)
       (if (isa 'string thing)
           (pp/esc-str-literal thing)
+          (isa 'symbol thing)
+          "\~|~(just thing)|"
           "\~~(pp thing)")))
 
 (def pp/string-pieces (pp things) "\"~(joinstr "" (map (pp/string-piece pp) things))\"")
@@ -35,11 +63,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 +76,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 +84,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 +99,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 +195,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

@@ -21,6 +21,12 @@
 (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
@@ -47,9 +53,9 @@
 ; 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))))
@@ -64,6 +70,14 @@
         (let mi (m2i anchor)
           (map λm(i2m (+ mi m)) mm))))
 
+;; 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 (things last-cons)
     `(with (,last-cons (cons) ,things nil)
@@ -72,6 +86,17 @@
          ,@body
          (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)
@@ -160,3 +185,58 @@
               (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

@@ -1,7 +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 (fn (k) h.,k) (hash-keys 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)))
+(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

@@ -1,12 +1,16 @@
 (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
+  (if (sym? expr)                 expr
       (or (atom? expr) (no expr)) `(k ,expr)
-      `(fn (_) ,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)
@@ -15,6 +19,10 @@
                   { 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
@@ -27,9 +35,12 @@
                       '(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
+; get the value of the given setting. Raises an error if the setting is unknown
 (def setting (name)
-  (on-err (error "can't get value of setting ~name")
-          ((hash-get settings (sym name)) 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)")))

data/lib/lisp/core-130-validations.nydp

@@ -0,0 +1,51 @@
+(chapter-start 'validations "utilities to record and run validation routines")
+
+(let validations {}
+  (def validate/reset ()
+    (= validations {}))
+  (def validate/fns (thing context)
+    (hash-get validations (list (type-of thing) context)))
+  (def validate/fn+ (type context f)
+    (hash-cons validations (list type context) f)))
+
+;;
+;; returns a hash of error-name to list of error messages
+;;
+;; An empty return value signifies an error-free 'thing
+;;
+(def validate (thing context)
+  (returnlet msgs {}
+    (let msgf λem(hash-cons msgs e m)
+      (eachl λv(v thing context msgf)
+             (validate/fns thing context)))))
+
+;; declare a validation routine for type 'type in context 'context
+;;
+;; 'type must be a symbol
+;; 'context must be a symbol
+;; 'body is one or more nydp expressions.
+;;
+;; 'body will be embedded in a function with access to the following variables :
+;;
+;; * the value of the 'type argument
+;; * ctx
+;; * mf
+;;
+;; 'mf ("message function") is a function that takes two arguments and is used to store
+;; the validation error message
+;; example: (mf "Last name" "Last name must not be empty")
+;;
+;; example usage:
+;;
+;; (validate/def invoice issue
+;;   (if (no invoice.account)
+;;       (mf "Account" "Account must be a client account"))
+;;   (if (!> invoice.total 0)
+;;       (mf "Amount"  "Amount must be greater than zero"))
+;;   (if (any? !&group invoice.invoice-items)
+;;       (mf "Group"   "Each line must be assigned to a group")))
+;;
+;; if your routine makes no call to 'mf then 'validate will return an empty hash, which should be
+;; interpreted as signifying that the object in question is error free in the given context.
+(mac validate/def (type context . body)
+  `(validate/fn+ ',type ',context (fn (,type ctx mf) ,@body)))