# HG changeset patch
# User Steve Losh <steve@stevelosh.com>
# Date 1597207101 14400
# Node ID a450f8f200cd73194c1c9a12f458c7426e31b784
# Parent  ed56ff3ab22444c6b66221ec434c2b54340327b6
Add basic optimized discarder

diff -r ed56ff3ab224 -r a450f8f200cd .TODO.done
--- a/.TODO.done	Tue Aug 11 23:45:07 2020 -0400
+++ b/.TODO.done	Wed Aug 12 00:38:21 2020 -0400
@@ -1,1 +1,2 @@
+Optimize discarding | id:93105ef9d21d33bfb10c67fcac36bc60434d3fb4
 Add basic unit tests | id:ed372a368fce619ce8230043635de5258212f607
diff -r ed56ff3ab224 -r a450f8f200cd TODO
--- a/TODO	Tue Aug 11 23:45:07 2020 -0400
+++ b/TODO	Wed Aug 12 00:38:21 2020 -0400
@@ -1,6 +1,5 @@
 Add read/print disabling mechanism | id:1268bf0b10c13aec23aafbd8f5e236db1e485fa5
 Add basic wrapper definition | id:861f048b3b69079dedf8779be1cb73c05e6fc732
-Optimize discarding | id:93105ef9d21d33bfb10c67fcac36bc60434d3fb4
 Add after-read and before-print functions | id:9f982ca45b68d644159e0c64f0dc1b185f72a2f8
 Add opaque-json type | id:a1a380eb9782d088693dfb75402b99c2b30cf039
 Add dynamic extent wrapper definition | id:a937f1179ff1fac77ca501ce7c70449464411f58
diff -r ed56ff3ab224 -r a450f8f200cd src/main.lisp
--- a/src/main.lisp	Tue Aug 11 23:45:07 2020 -0400
+++ b/src/main.lisp	Wed Aug 12 00:38:21 2020 -0400
@@ -160,6 +160,71 @@
 (defgeneric read% (class contained-class input))
 
 
+(defmethod read% ((class (eql 'nil)) contained-class input)
+  ;; Optimized reader for cases where you don't actually care about the value
+  ;; and just need to parse over it without allocating anything.
+  (labels
+      ((any% ()
+         (case (p input)
+           (:eof (r input) (e nil input "got ~S" :eof))
+           (#\n (literal% "null"))
+           (#\t (literal% "true"))
+           (#\f (literal% "false"))
+           (#\" (string%))
+           (#\{ (object%))
+           (#\[ (array%))
+           ((#\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) (number%))
+           (t (e nil input "unexpected character ~S" (r input)))))
+       (literal% (string)
+         (loop :for next :across string
+               :for char = (r input)
+               :unless (eql next char)
+               :do (e nil input "expected ~S when parsing ~S but got ~S" next string char)))
+       (array% ()
+         (r input) ; [
+         (skip-whitespace input)
+         (if (eql (p input) #\])
+           (r input)
+           (loop (any%)
+                 (skip-whitespace input)
+                 (let ((ch (r input)))
+                   (case ch
+                     (#\] (return))
+                     (#\, (skip-whitespace input))
+                     (t (e nil input "expected ~S or ~S but got ~S." #\] #\, ch)))))))
+       (object% ()
+         (r input) ; {
+         (skip-whitespace input)
+         (if (eql (p input) #\})
+           (r input)
+           (loop
+             (string%)
+             (parse-kv-separator nil input)
+             (any%)
+             (skip-whitespace input)
+             (let ((ch (r input)))
+               (case ch
+                 (#\} (return))
+                 (#\, (skip-whitespace input))
+                 (t (e nil input "expected ~S or ~S but got ~S" #\} #\, ch)))))))
+       (number% ()
+         ;; TODO: Optimize this too.  Not a huge priority since fixnums don't cons.
+         (parse-number input))
+       (string% ()
+         (let ((ch (r input)))
+           (unless (eql ch #\")
+             (e nil input "expected opening ~S but got ~S" #\" ch)))
+         (loop :for ch = (r input)
+               :do (cond
+                     ((eql ch :eof) (e nil input "got ~S" :eof))
+                     ((eql ch #\\) (parse-escaped-character input)) ; TODO: Optimize this too.
+                     ((eql ch #\") (return))
+                     ((requires-escape-p ch) (e nil input "bad unescaped character ~S" ch))
+                     (t nil)))))
+    (skip-whitespace input)
+    (any%)
+    (values)))
+
 (defmethod read% ((class (eql 'keyword)) contained-class input)
   (let ((ch (r input)))
     (case ch
@@ -186,13 +251,13 @@
         :with c = (car contained-class)
         :with cc = (cadr contained-class)
         :collect (read% c cc input)
-            :do (progn
-                  (skip-whitespace input)
-                  (let ((ch (r input)))
-                    (case ch
-                      (#\] (loop-finish))
-                      (#\, (skip-whitespace input))
-                      (t (e 'vector input "expected ~S or ~S but got ~S." #\] #\, ch))))))
+        :do (progn
+              (skip-whitespace input)
+              (let ((ch (r input)))
+                (case ch
+                  (#\] (loop-finish))
+                  (#\, (skip-whitespace input))
+                  (t (e 'vector input "expected ~S or ~S but got ~S." #\] #\, ch))))))
       'vector)))
 
 (defmethod read% ((class (eql 'string)) contained-class input)
@@ -201,12 +266,12 @@
       (e 'string input "expected opening ~S but got ~S" #\" ch)))
   (with-output-to-string (s)
     (loop :for ch = (r input)
-          :collect (cond
-                     ((eql ch :eof) (e 'string input "got ~S" :eof))
-                     ((eql ch #\\) (write-char (parse-escaped-character input) s))
-                     ((eql ch #\") (loop-finish))
-                     ((requires-escape-p ch) (e 'string input "bad unescaped character ~S" ch))
-                     (t (write-char ch s))))))
+          :do (cond
+                ((eql ch :eof) (e 'string input "got ~S" :eof))
+                ((eql ch #\\) (write-char (parse-escaped-character input) s))
+                ((eql ch #\") (loop-finish))
+                ((requires-escape-p ch) (e 'string input "bad unescaped character ~S" ch))
+                (t (write-char ch s))))))
 
 (defmethod read% ((class (eql 'hash-table)) contained-class input)
   (let ((ch (r input)))
@@ -259,6 +324,7 @@
     (t (e 't input "unexpected character ~S" (r input)))))
 
 
+
 ;;;; Object Parsers -----------------------------------------------------------
 (defun lisp-case-to-snake-case (string)
   "Convert a Lisp-cased string designator `\"FOO-BAR\"` into snake cased `\"foo_bar\"`."
diff -r ed56ff3ab224 -r a450f8f200cd test/tests.lisp
--- a/test/tests.lisp	Tue Aug 11 23:45:07 2020 -0400
+++ b/test/tests.lisp	Wed Aug 12 00:38:21 2020 -0400
@@ -42,16 +42,43 @@
        (null (set-difference y x :test #'equal))))
 
 
+(defun check-reads-one-object (object string)
+  (with-input-from-string (s string)
+    (is (same object (jarl:read t s)))
+    (signals end-of-file (jarl:read t s))))
+
+(defun check-discards-one-object (string)
+  (with-input-from-string (s string)
+    (is (null (multiple-value-list (jarl:read nil s))))
+    (signals end-of-file (jarl:read t s))))
+
+(defun check-roundtrips (object)
+  (is (same object (jarl:read t (jarl:print object nil)))))
+
+(defun check-errors (line col string)
+  (dolist (class '(t nil)) ; todo check discarding errors too
+    (handler-case
+        (progn
+          (jarl:read class string)
+          (error "Should have signaled a json-parsing-error when parsing ~S but didn't."
+                 class))
+      (jarl::json-parsing-error (e)
+        (is (equal (list class line col)
+                   (list class (jarl:line e) (jarl:column e))))))))
+
+
 ;;;; Basic Tests --------------------------------------------------------------
 (defmacro define-basic-tests (name &rest clauses)
   `(define-test ,name
      ,@(loop :for (object string) :in clauses :collect
              (alexandria:once-only (object string)
-               `(progn
-                  ; check that the string deserializes to the expected form
-                  (is (same ,object (jarl:read t (json ,string))))
-                  ; check that we can roundtrip the form reliably
-                  (is (same ,object (jarl:read t (jarl:print ,object nil)))))))))
+               `(let ((,string (json ,string)))
+                  ; Check that the entire string deserializes to the expected form.
+                  (check-reads-one-object ,object ,string)
+                  ; Check that we can roundtrip the form reliably.
+                  (is (same ,object (jarl:read t (jarl:print ,object nil))))
+                  ; Check that we can discard it safely.
+                  (check-discards-one-object ,string))))))
 
 
 (define-basic-tests null
@@ -140,12 +167,16 @@
 
 ;;;; Real-World Data ----------------------------------------------------------
 (defmacro define-file-test (name (object path) &body body)
-  `(define-test ,name
-     (let ((,object (with-open-file (s ,path)
-                     (jarl:read t s))))
-       ;; Check that we can roundtrip it first.
-       (is (same ,object (jarl:read t (jarl:print ,object nil))))
-       ,@body)))
+  (alexandria:with-gensyms (string)
+    `(define-test ,name
+       (let ((,string (alexandria:read-file-into-string ,path)))
+         ;; Check that discarding works.
+         (check-discards-one-object ,string)
+         (let ((,object (jarl:read t ,string)))
+           ;; Check that we can discard it.
+           (check-roundtrips ,object)
+           ;; Other test-specific checks.
+           ,@body)))))
 
 
 (define-file-test github/sjl (o "test/data/github/sjl.json")
@@ -164,15 +195,8 @@
 ;;;; Error Tests --------------------------------------------------------------
 (defmacro define-error-tests (name &rest clauses)
   `(define-test ,name
-     ,@(loop :for (line col string) :in clauses :collect
-             (alexandria:once-only (line col string)
-               `(handler-case (progn (jarl:read t (json ,string))
-                                     (error "Should have signaled a json-parsing-error but didn't."))
-                  (jarl::json-parsing-error
-                    (e)
-                    (1am:is (equal (cons ,line ,col)
-                                   (cons (jarl:line e)
-                                         (jarl:column e))))))))))
+     ,@(loop :for (line col string) :in clauses
+             :collect `(check-errors ,line ,col (json ,string)))))
 
 
 (define-error-tests trash