Commits

Moritz Heidkamp  committed 184c2e9

Add emitters (except for tags)

  • Participants
  • Parent commits 37d339f

Comments (0)

Files changed (5)

File edn-impl.scm

 
 (define (read-edn #!optional (input (current-input-port)))
   (parse (edn-element) input))
+
+(define (emit-keyword kw out)
+  (display #\: out)
+  (display (keyword->string kw) out))
+
+(define (emit-boolean x out)
+  (display (if x "true" "false") out))
+
+(define (coll-emitter open close)
+  (lambda (coll out)
+    (display open out)
+    (unless (null? (cdr coll))
+      (let loop ((items (cdr coll)))
+        (write-edn (car items) out)
+        (unless (null? (cdr items))
+          (display #\space out)
+          (loop (cdr items)))))
+    (display close out)))
+
+(define (car? x)
+  (lambda (p)
+    (and (pair? p) (eq? (car p) x))))
+
+(define emit-curly-coll
+  (coll-emitter #\{ #\}))
+
+(define (emit-set set out)
+  (display #\# out)
+  (emit-curly-coll set out))
+
+(define (emit-map coll out)
+  (emit-curly-coll
+   (->> (cdr coll)
+        (append-map (lambda (x) (list (car x) (cdr x))))
+        (cons (car coll)))
+   out))
+
+(define edn-emitters
+  (make-parameter
+   (list (cons keyword?       emit-keyword)
+         (cons symbol?        write)
+         (cons number?        write)
+         (cons string?        write)
+         (cons boolean?       emit-boolean)
+         (cons (car? 'list)   (coll-emitter #\( #\)))
+         (cons (car? 'vector) (coll-emitter #\[ #\]))
+         (cons (car? 'set)    emit-set)
+         (cons (car? 'map)    emit-map))))
+
+(define (emitter-ref obj)
+  (or (alist-ref obj (edn-emitters) (lambda (pred? _) (pred? obj)))
+      (error "No emitter found for given object" obj)))
+
+(define (write-edn obj #!optional (output (current-output-port)))
+  ((emitter-ref obj) obj output))
 (module edn
 
-(read-edn register-edn-tag! handle-unknown-edn-tags?)
+(read-edn
+ edn-parsers
+ register-edn-tag!
+ handle-unknown-edn-tags?
+ write-edn
+ edn-emitters)
 
 "edn-impl.scm"
 

File tests/read.scm

-(use test lazy-seq edn (prefix numbers numbers-))
+(use lazy-seq (prefix numbers numbers-))
+
+(test-begin "reading")
 
 (define-syntax test-read
   (syntax-rules ()
     ((_ in)
      (test-error in (read-edn in)))))
 
-
-(test-begin)
-
 (test-group "booleans & nil"
   (test-read "true" #t)
   (test-read "false" #f))
     (test-read "#{#{1} #{2}}" '(set (set 1) (set 2)))))
 
 (test-group "tags"
-  (test-read "#inst 123" '(tag (#f . inst) 123))
-  (test-read "#uuid \"foobar\"" '(tag (#f . uuid) "foobar"))
+  (test-read "#inst \"1985-04-12T23:20:50.52Z\""
+             '(tag (#f . inst) "1985-04-12T23:20:50.52Z"))
+  (test-read "#uuid \"f81d4fae-7dec-11d0-a765-00a0c91e6bf6\""
+             '(tag (#f . uuid) "f81d4fae-7dec-11d0-a765-00a0c91e6bf6"))
   (test-read "#yak/sie masz" '(tag (yak . sie) masz))
   (parameterize ((handle-unknown-edn-tags? #f))
     (test-read-error "#yak/sie masz")))
   (test-read "#nice/string \"edn\"" "edn is nice!"))
 
 (test-end)
-
-(test-exit)

File tests/run.scm

+(use test edn)
+
+(test-begin)
+
 (load-relative "read.scm")
+(load-relative "write.scm")
+
+(test-end)
+
+(test-exit)

File tests/write.scm

+(define-syntax test-write
+  (syntax-rules ()
+    ((_ in out)
+     (test (with-output-to-string (lambda () (write in)))
+           out
+           (with-output-to-string (lambda () (write-edn in)))))))
+
+(test-begin "writing")
+
+(test-group "atoms"
+  (test-write foo: ":foo")
+  (test-write 'foo "foo")
+  (test-write 'foo/bar "foo/bar")
+  (test-write 123 "123")
+  (test-write "hey\na string!" "\"hey\\na string!\"")
+  (test-write #t "true")
+  (test-write #f "false")
+  (test-write 'nil "nil"))
+
+(test-group "collections"
+  (test-write '(list a "b" c:) "(a \"b\" :c)")
+  (test-write '(vector (vector x)) "[[x]]")
+  (test-write '(map (foo: . 1) (bar: . 2)) "{:foo 1 :bar 2}")
+  (test-write '(set x y z) "#{x y z}"))
+
+(test-group "tags"
+  (test-write '(tag (#f . inst) "1985-04-12T23:20:50.52Z")
+              "#inst \"1985-04-12T23:20:50.52Z\"")
+  (test-write "#uuid \"f81d4fae-7dec-11d0-a765-00a0c91e6bf6\""
+              '(tag (#f . uuid) "f81d4fae-7dec-11d0-a765-00a0c91e6bf6")))
+
+(test-end)