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 ...)
-  (if (not pred) body ...))
+(define-syntax-rule (if-not pred true-arm false-arm)
+  (if (not pred) true-arm false-arm))
 
-(define-syntax-rule (when-not pred body ...)
-  (when (not pred) body ...))
+(define-syntax-rule (if-let ([ident test]) true-arm false-arm)
+  (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
-	(begin expr ...)
-	#f)))
+    (when ident
+      expr ...)))
 
 (define-syntax for
   (syntax-rules ()
@@ -57,35 +62,55 @@
     [(for ([ident lst] bindings ...) expr ...)
      (let iter ([rest lst])
        (if (pair? rest)
-	   (let ([ident (car rest)])
-	     (append (for (bindings ...) expr ...) (iter (cdr rest))))
-	   '()))]))
+           (let ([ident (car rest)])
+             (append (for (bindings ...) expr ...) (iter (cdr rest))))
+           '()))]))
 
 (define (partial fn . args)
   (lambda x (apply fn (append args x))))
 
 (define (argmin arg lt? . vals)
   (reduce (lambda (val min)
-	    (if (lt? (arg val) (arg min))
-		val
-		min))
-	  #f
-	  vals))
+            (if (lt? (arg val) (arg min))
+                val
+                min))
+          #f
+          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)))
-	   (apply distinct? (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)
@@ -96,17 +121,18 @@
     (call-with-prompt tag
       thunk
       (lambda (k value)
-	(set! thunk k)
-	value))))
+        (set! thunk k)
+        value))))
 
 (define-syntax generator
+  ;; generator with an anaphoric yield
   (lambda (x)
     (syntax-case x ()
       [(generator expr ...)
        (with-syntax ([yield (datum->syntax x 'yield)])
-	 #'(make-generator
-	    (lambda (yield)
-	      expr ...)))])))
+         #'(make-generator
+            (lambda (yield)
+              expr ...)))])))
 
 ;; Why wasn't this included?
 (define macro-expand (compose tree-il->scheme macroexpand))
@@ -121,12 +147,12 @@
     [(amb a b ...)
      (let ([fail0 *fail*])
        (call/cc
-	(lambda (cc)
-	  (set! *fail*
-		(lambda ()
-		  (set! *fail* fail0)
-		  (cc (amb b ...))))
-	  (cc a))))]))
+        (lambda (cc)
+          (set! *fail*
+                (lambda ()
+                  (set! *fail* fail0)
+                  (cc (amb b ...))))
+          (cc a))))]))
 (define (amb-reset)
   ;; Shouldn't be necessary, but prompts are hard and I'm dumb dumb dummy
   (set! *fail* (lambda () (error "Could not satisfy amb"))))

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,37 +1,49 @@
 (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)
-	  [(assert-equal e a) #'(assert e a equal? fail)]
-	  [(assert-not-equal e a) #'(assert e a (compose not equal?) fail)]
-	  [(assert-unspecified v) #'(assert (when #f 'a) v eq? fail)]
-	  [else #'else]))
+        (syntax-case expr (assert-equal assert-not-equal assert-unspecified)
+          [(assert-equal e a) #'(assert e a equal-or-any? 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)
-	(syntax-case test (define-test)
-	  [(define-test test-name e ...)
-	   #`(call/ec (lambda (fail)
-			(format #t "~a: " test-name)
-			(begin
-			  #,@(map assert-stx #'(e ...)))
-			(display "ok")
-			(newline)))]))
+        (syntax-case test (define-test)
+          [(define-test test-name e ...)
+           #`(call/ec (lambda (fail)
+                        (format #t "~a: " test-name)
+                        (begin
+                          #,@(map assert-stx #'(e ...)))
+                        (display "ok")
+                        (newline)))]))
       (syntax-case stx ()
-	[(define-test-suite name test ...)
-	 #`(begin
-	     (format #t "Suite ~a:" name)
-	     (newline)
-	     #,@(map define-test-stx
-		     #'(test ...))
-	     (newline))]))))
+        [(define-test-suite name test ...)
+         #`(begin
+             (format #t "Suite ~a:" name)
+             (newline)
+             #,@(map define-test-stx
+                     #'(test ...))
+             (newline))]))))

test.scm

@@ -1,6 +1,7 @@
 (use-modules (d-)
-	     (d- test)
-	     (srfi srfi-1))
+	     (d- json)
+	     (srfi srfi-1)
+	     (d- test))
 
 (define-test-suite "~>"
   (define-test "unwrapped"
@@ -30,25 +31,28 @@
   (define-test "test"
     (assert-equal 'a (if-not #f 'a 'b))))
 
-(define-test-suite "when-not"
-  (define-test "positive-case"
-    (assert-equal 'return (when-not #f 'do-some-stuff 'return)))
-  (define-test "negative-case"
-    (assert-unspecified (when-not #t 'do-some-stuff 'return))))
+(define-test-suite "if-let"
+  (define-test "positive case"
+    (assert-equal 2 (if-let ([v (or #f 1)]) (+ v 1) 3)))
+  (define-test "negative case"
+    (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"
     (define value (for ([i (iota 2)]
-			[j (iota 2)])
-		       (cons i j)))
+                        [j (iota 2)])
+                       (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,13 +73,25 @@
     (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
       (generator
        (let loop ([i 1])
-	 (yield i)
-	 (loop (1+ i)))))
+         (yield i)
+         (loop (1+ i)))))
     (assert-equal 1 (number-generator))
     (assert-equal 2 (number-generator))
     (assert-equal 3 (number-generator))
@@ -86,16 +102,57 @@
     (define (liars)
       (amb-reset)
       (let ([betty (amb 1 2 3 4 5)]
-	    [ethel (amb 1 2 3 4 5)]
-	    [joan  (amb 1 2 3 4 5)]
-	    [kitty (amb 1 2 3 4 5)]
-	    [mary  (amb 1 2 3 4 5)])
-	;; The "Liars" problem
-	(amb-require (distinct? betty ethel joan kitty mary))
-	(amb-require (or (= kitty 1) (= betty 3)))
-	(amb-require (or (= ethel 1) (= joan  2)))
-	(amb-require (or (= joan  3) (= ethel 5)))
-	(amb-require (or (= kitty 2) (= mary  4)))
-	(amb-require (or (= mary  4) (= betty 1)))
-	(list betty ethel joan kitty mary)))
+            [ethel (amb 1 2 3 4 5)]
+            [joan  (amb 1 2 3 4 5)]
+            [kitty (amb 1 2 3 4 5)]
+            [mary  (amb 1 2 3 4 5)])
+        ;; The "Liars" problem
+        (amb-require (distinct? betty ethel joan kitty mary))
+        (amb-require (or (= kitty 1) (= betty 3)))
+        (amb-require (or (= ethel 1) (= joan  2)))
+        (amb-require (or (= joan  3) (= ethel 5)))
+        (amb-require (or (= kitty 2) (= mary  4)))
+        (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))))))