actually use the iterator

Makefile.am

@@ -1,4 +1,4 @@
-SOURCES = d-.scm d-/test.scm
+SOURCES = d-.scm d-/test.scm d-/json.scm
 
 GOBJECTS = $(SOURCES:%.scm=%.go)
 GUILD = @GUILD@

d-.scm

@@ -6,14 +6,16 @@
    ~>>
    as~>
    if-not
-   when-not
    if-let
+   when-let
    for
    partial
    argmin
    iterate
    upply
+   conjoin
    distinct?
+   alambda
    generator
    macro-expand
    amb
@@ -39,17 +41,20 @@
      (let [(as v)]
        (as~> as (fn args ...) more ...))]))
 
-(define-syntax-rule (if-not pred body ...)
+(define-syntax-rule (if-not pred true-arm false-arm)
-  (if (not pred) body ...))
+  (if (not pred) true-arm false-arm))
 
-(define-syntax-rule (when-not pred body ...)
+(define-syntax-rule (if-let ([ident test]) true-arm false-arm)
-  (when (not pred) body ...))
+  (let ([t test])
+    (if t
+        (let ([ident t])
+          true-arm)
+        false-arm)))
 
-(define-syntax-rule (if-let ([ident test]) expr ...)
+(define-syntax-rule (when-let ([ident test]) expr ...)
   (let ([ident test])
-    (if ident
+    (when ident
-	(begin expr ...)
+      expr ...)))
-	#f)))
 
 (define-syntax for
   (syntax-rules ()
@@ -73,20 +78,40 @@
           vals))
 
 (define (iterate n f v)
+  "Repeatedly call f on values returned from (f v)"
   (if (zero? n)
       v
       (iterate (1- n) f (f v))))
 
 (define (upply a b cmp . fs)
+  "U-shapped apply, apply fs to a and b as in compose, then apply cmp to both results"
   (let ([arm-f (apply compose fs)])
     (cmp (arm-f a) (arm-f b))))
 
+(define (conjoin . preds)
+  "Returns a procedure that applies each pred to a single value, and returns #t if all return a truthy value. With no preds returns a one arg function that always returns true"
+  (if (null? preds)
+      (lambda (x) #t)
+      (lambda (x)
+        (if ((car preds) x)
+            ((apply conjoin (cdr preds)) x)
+            #f))))
+
 (define (distinct? . a)
+  "Are all values distinct, as in equal?"
   (if (or (null? a) (null? (cdr a)))
       #t
-      (and (not (any (lambda (x) (eq? (car a) x)) (cdr a)))
+      (and (not (any (lambda (x) (equal? (car a) x)) (cdr a)))
            (apply distinct? (cdr a)))))
 
+(define-syntax alambda
+  (syntax-rules ()
+    [(alambda (kar kdr) body ...)
+     (lambda (kons)
+       (let ([kar (car kons)]
+             [kdr (cdr kons)])
+         body ...))]))
+
 ;; Shamelessly ripped from https://wingolog.org/archives/2013/02/25/on-generators
 (define (make-generator f)
   (define tag (make-prompt-tag))
@@ -100,6 +125,7 @@
         value))))
 
 (define-syntax generator
+  ;; generator with an anaphoric yield
   (lambda (x)
     (syntax-case x ()
       [(generator expr ...)

d-/json.scm

@@ -0,0 +1,95 @@
+(define-module (d- json)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 peg)
+  #:export (json))
+
+(define-peg-pattern ++       none (* (or "\t" "\n" "\r" " ")))
+(define-peg-pattern comma    none (and "," ++))
+(define-peg-pattern open-sq  none (and "[" ++))
+(define-peg-pattern close-sq none (and "]" ++))
+(define-peg-pattern open-cu  none (and "{" ++))
+(define-peg-pattern close-cu none (and "}" ++))
+(define-peg-pattern boolean  all  (and (or "true" "false")
+				       ++))
+(define-peg-pattern number   all  (and (or (and (+ (range #\0 #\9)) "." (* (range #\0 #\9)))
+					   (and (?".") (+ (range #\0 #\9))))
+				       ++))
+(define-peg-pattern string   all  (and (ignore "\"")
+				       (* (or "\\\""
+					      (and (not-followed-by "\"") peg-any)))
+				       (ignore "\"") ++))
+(define-peg-pattern earr     all  (and open-sq close-sq))
+(define-peg-pattern array    all  (or earr
+				      (and open-sq
+					   (* (and value comma))
+					   value
+					   close-sq)))
+(define-peg-pattern eobj     all  (and open-cu close-cu))
+(define-peg-pattern object   all  (or eobj
+				      (and open-cu
+					   (* (and string (ignore ":") ++ value comma))
+					   (and string (ignore ":") ++ value)
+					   close-cu)))
+(define-peg-pattern value    body (or number boolean string array object))
+
+(define default-arr-cons cons)
+(define default-obj-acons
+  (lambda (key value rest)
+    (acons (string->symbol key) value rest)))
+
+(define *arr-cons* (make-parameter default-arr-cons))
+(define *obj-acons* (make-parameter default-obj-acons))
+
+
+(define (parse-boolean s)
+  (if (string= s "true") #t #f))
+
+(define (parse-number s)
+  (string->number s))
+
+(define (parse-string s)
+  s)
+
+(define (parse-array ss)
+  (if (symbol? (car ss))
+      '()
+      (fold-right (*arr-cons*) '() (map parse-value ss))))
+
+(define (parse-object ss)
+  (if (or (null? ss) (null? (cdr ss)))
+      '()
+      (let ([key (parse-value (car ss))]
+	    [value (parse-value (cadr ss))]
+	    [rest (parse-object (cddr ss))])
+	((*obj-acons*) key value rest))))
+
+(define flatwords '(boolean number string array object))
+
+(define (parse-value s)
+  (if (pair? s)
+      (case (car s)
+	[(boolean) (parse-boolean (cadr s))]
+	[(number)  (parse-number  (cadr s))]
+	[(string)  (parse-string  (cadr s))]
+	[(array)   (parse-array   (keyword-flatten flatwords (cdr s)))]
+	[(object)  (parse-object  (keyword-flatten flatwords (cdr s)))])
+      (raise-exception
+       (make-exception
+	(make-programming-error)
+	(make-exception-with-irritants s)))))
+
+(define* (json string #:key
+               (arr-cons default-arr-cons)
+               (obj-acons default-obj-acons))
+"Parses a json string into a sexp
+`arr-cons' sets how arrays are constructed
+`obj-acons` sets how objects are constructed"
+  (define match (match-pattern value string))
+  (if match
+      (parameterize ([*arr-cons* arr-cons]
+                     [*obj-acons* obj-acons])
+	(parse-value (peg:tree match)))
+      (raise-exception (make-exception
+			(make-external-error)
+			(make-exception-with-irritants string)))))

d-/test.scm

@@ -1,21 +1,33 @@
 (define-module (d- test)
+  #:use-module (srfi srfi-1)
   #:use-module (ice-9 format)
   #:use-module (ice-9 control)
-  #:export (define-test-suite))
+  #:export (define-test-suite anything))
+
+(define *anysym* (gensym))
+(define (anything) *anysym*)
 
 (define (assert expected actual eq? fail)
-  (when (not (eq? expected actual))
+  (when (and (not (eq? expected actual)))
     (format #t "fail - expected ~a but got ~a" expected actual)
     (newline)
     (fail)))
 
+(define (equal-or-any? expected actual)
+  (cond
+   [(eq? *anysym* expected) #t]
+   [(or (not (list? expected))
+	(not (list? actual)))
+    (equal? expected actual)]
+   [else (every equal-or-any? expected actual)]))
+
 (define-syntax define-test-suite
   (lambda (stx)
     (with-syntax ([fail (datum->syntax stx 'fail)])
       (define (assert-stx expr)
-	(syntax-case expr (assert-equal assert-not-equal)
+        (syntax-case expr (assert-equal assert-not-equal assert-unspecified)
-	  [(assert-equal e a) #'(assert e a equal? fail)]
+          [(assert-equal e a) #'(assert e a equal-or-any? fail)]
-	  [(assert-not-equal e a) #'(assert e a (compose not equal?) fail)]
+          [(assert-not-equal e a) #'(assert e a (compose not equal-or-any?) fail)]
           [(assert-unspecified v) #'(assert (when #f 'a) v eq? fail)]
           [else #'else]))
       (define (define-test-stx test)

test.scm

@@ -1,6 +1,7 @@
 (use-modules (d-)
-	     (d- test)
+	     (d- json)
-	     (srfi srfi-1))
+	     (srfi srfi-1)
+	     (d- test))
 
 (define-test-suite "~>"
   (define-test "unwrapped"
@@ -30,11 +31,20 @@
   (define-test "test"
     (assert-equal 'a (if-not #f 'a 'b))))
 
-(define-test-suite "when-not"
+(define-test-suite "if-let"
-  (define-test "positive-case"
+  (define-test "positive case"
-    (assert-equal 'return (when-not #f 'do-some-stuff 'return)))
+    (assert-equal 2 (if-let ([v (or #f 1)]) (+ v 1) 3)))
-  (define-test "negative-case"
+  (define-test "negative case"
-    (assert-unspecified (when-not #t 'do-some-stuff 'return))))
+    (assert-equal 3 (if-let ([v (and #f 1)]) (+ v 1) 3)))
+  (define-test "variable not shadowed in false arm"
+    (define v 3)
+    (assert-equal 3 (if-let ([v #f]) (+ v 1) v))))
+
+(define-test-suite "when-let"
+  (define-test "positive case"
+    (assert-equal 2 (when-let ([v (or #f 1)]) (+ v 1))))
+  (define-test "negative case"
+    (assert-equal (when #f #t) (when-let ([v (and #f 1)]) (+ v 1)))))
 
 (define-test-suite "for"
   (define-test "permutation"
@@ -43,12 +53,6 @@
                        (cons i j)))
     (assert-equal '((0 . 0) (0 . 1) (1 . 0) (1 . 1)) value)))
 
-(define-test-suite "if-let"
-  (define-test "positive-case"
-    (assert-equal 2 (if-let ([v (or #f 1)]) (+ v 1))))
-  (define-test "negative-case"
-    (assert-equal #f (if-let ([v (and #f 1)]) (+ v 1)))))
-
 (define-test-suite "partial"
   (define-test "test"
     (define value (partial / 2))
@@ -69,6 +73,18 @@
     (define value (upply -3 5 = abs 1-))
     (assert-equal #t value)))
 
+(define-test-suite "conjoin"
+  (define-test "test"
+    (assert-equal #t ((conjoin negative? odd? rational?) -3))
+    (assert-equal #f ((conjoin negative? odd? rational?) -4)))
+  (define-test "vacuous"
+    (assert-equal #t ((conjoin) '(some donkus)))))
+
+(define-test-suite "alambda"
+  (define-test "map"
+    (assert-equal '(4 4 4)
+                  (map (alambda (i v) (+ i v)) '((3 . 1) (2 . 2) (1 . 3))))))
+
 (define-test-suite "generator"
   (define-test "test"
     (define number-generator
@@ -99,3 +115,44 @@
         (amb-require (or (= mary  4) (= betty 1)))
         (list betty ethel joan kitty mary)))
     (assert-equal '(3 5 2 1 4) (liars))))
+
+(define-test-suite "test"
+  (define-test "anything"
+    (assert-equal `(dog ,(anything)) '(dog cat))))
+
+(define-test-suite "json"
+  (define-test "boolean"
+    (assert-equal #t (json "true"))
+    (assert-equal #f (json "false")))
+  (define-test "number"
+    (assert-equal 1.1 (json "1.1"))
+    (assert-equal 0.1 (json ".1"))
+    (assert-equal 1.0 (json "1.")))
+  (define-test "string"
+    (assert-equal "hello" (json "\"hello\""))
+    (assert-equal "\\\"hello\\\"" (json "\"\\\"hello\\\"\"")))
+  (define-test "array"
+    (assert-equal '() (json "[]"))
+    (assert-equal '(1 "two" #f) (json "[1, \"two\", false]"))
+    (assert-equal '(() (())) (json "[[], [[]]]"))
+    (assert-equal "catdogsnail"
+                  (json "[\"cat\", \"dog\", \"snail\"]"
+                        #:arr-cons
+                        (lambda (a d)
+                          (if (null? d)
+                              a
+                              (string-append a d))))))
+  (define-test "object"
+    (assert-equal '() (json "{}"))
+    (assert-equal '((cat . 1)
+		    (bat . #t)
+		    (rat . "yessir"))
+		  (json "{\"cat\": 1, \"bat\": true, \"rat\": \"yessir\"}"))
+    (assert-equal '((butter . 1)
+		    (brownie))
+		  (json "{\"butter\": 1, \"brownie\": {}}"))
+    (assert-equal '(1 2)
+		  (json "{\"hello\": 1, \"world\": 2}"
+			#:obj-acons
+			(lambda (_key value rest)
+			  (cons value rest))))))