expand starts and continues by adding current node as argument

This simplifies the parser at the expense of moving the `add-new-node!`
declaration into the `starts` procedure. This allows for the procedure
to mutate the node when needed, which is needed for properly parsing
pandoc-style grid tables.

5 files changed, 91 insertions, 80 deletions

diff --git a/README.md b/README.md
index 1fb9903..8cdb8fe 100644
--- a/README.md
+++ b/README.md
@@ -33,7 +33,16 @@ child block of the block. After going as far possible, the line is then
 checked with a `starts` procedure (stored in each block) to see if any
 new block can be started.
 
-Todo: add no-paragraph blocks?
+TODO: According to the continuation line rules, block continuations
+consisting entirely of spaces must be placed to make sure a blank line
+is in the correct block, even though such text is not visible. The
+seemingly correct thing to do is to make the block continue on a blank
+line, but this cannot be done for every block (then blockquotes cannot
+be separated by blank lines).
+
+The continuation could check for an empty line. Currently empty lines are
+handled in a special way. They could be merged with the `add-new-paragraph`
+handler, so that continuations could check for empty lines.
 
 ## Inline Syntax
 
diff --git a/market/blocks.scm b/market/blocks.scm
index a124cab..91319ce 100644
--- a/market/blocks.scm
+++ b/market/blocks.scm
@@ -59,33 +59,28 @@
   (else))
 
 (define (make-empty-node data continues allowed-inside)
+  ;; Create a new node with no children.
   (make-block-node data continues allowed-inside
                    (list-queue) #f))
 
 (define (allowed-inside node line)
-  ((get-allowed-inside node) line))
+  ((get-allowed-inside node) node line))
 
 (define (continues node line)
-  ((get-continues node) line))
+  ((get-continues node) node line))
 
-(define (close-active-children node)
+(define (close-active-children! node)
   ;; Close all active children in the current node.
   (set-active-child! node #f))
 
-(define (add-new-active-child! node child)
+(define (add-new-child! node child active-child?)
+  ;; Add a new `child` to `node`. If `active-child?` is truthy, then
+  ;; `child` is the new active child of `node`. Otherwise, `child` is added
+  ;; and no child of `node` is active.
   (list-queue-add-back! (node-children node) child)
-  (set-active-child! node child))
-
-(define (add-new-child node new-child-of-node continue-node line)
-  ;; Add `new-child-of-node` to `node`, and continue parsing with
-  ;; `continue-node` and `line`.
-  ;; 
-  ;; For leaf blocks (like headings), `continue-node` is `#f`, which
-  ;; means to close the block.
-  (add-new-active-child! node new-child-of-node)
-  (if continue-node
-      (parse-line-to-node continue-node line)
-      (set-active-child! node #f)))
+  (set-active-child! node (if active-child?
+                              child
+                              #f)))
 
 (define (process-active-child node line active-child)
   ;; Act on the `active-child` with the given `line`.
@@ -95,7 +90,8 @@
     ;; If the new line is the start of a block allowed in `node` then close
     ;; `child` and add a new child. Otherwise, add to the paragraph.
     (cond
-      ((allowed-inside node line) first-arg => (cut add-new-child node <...>))
+      ((allowed-inside node line) first-arg => parse-line-to-node!)
+      ((empty-line? line) (close-active-children! node))
       (else (xstring-append! active-child line #\newline))))
   (define (handle-child-block)
     ;; Handle insertion of a new line when the active child is a block.
@@ -104,8 +100,9 @@
     ;; allowed after `child` in this node. Finally, check if `line` is
     ;; allowed inside this node. If not, add the line as a paragraph.
     (cond
-      ((continues active-child line) => (cut parse-line-to-node active-child <>))
-      ((allowed-inside node line) first-arg => (cut add-new-child node <...>))
+      ((continues active-child line) => (cut parse-line-to-node! active-child <>))
+      ((allowed-inside node line) first-arg => (cut parse-line-to-node! <...>))
+      ((empty-line? line) (close-active-children! node))
       (else (add-new-paragraph node line))))
   (cond
     ((xstring? active-child)
@@ -117,19 +114,17 @@
   ;; Add new node as the active child to `node` with the data of `line`.
   (let ((new-child (line->xstring line)))
     (xstring-append! new-child #\newline)
-    (add-new-active-child! node new-child)))
+    (add-new-child! node new-child #t)))
 
-(define (parse-line-to-node node line)
+(define (parse-line-to-node! node line)
   ;;  NODE.
   ;; 
   ;; If there is an active node, either add the line to the node or start a
   ;; new node. If there is no active node, start a new node, either by
   ;; starting a new block or by starting a new paragraph.
   (cond
-    ((empty-line? line) (close-active-children node))
     ((get-active-child node)
      => (cut process-active-child node line <>))
-    ((allowed-inside node line)
-     first-arg => (cut add-new-child node <...>))
+    ((allowed-inside node line) first-arg => parse-line-to-node!)
     (else (add-new-paragraph node line))))
 
diff --git a/market/blocks.sld b/market/blocks.sld
index d4a78dc..9a10edd 100644
--- a/market/blocks.sld
+++ b/market/blocks.sld
@@ -24,6 +24,6 @@
     (else))
   (export make-block-node node-data node-children
           make-empty-node block-node?
-          add-new-active-child!
-          parse-line-to-node)
+          add-new-child!
+          parse-line-to-node!)
   (include "blocks.scm"))
diff --git a/market/default.scm b/market/default.scm
index 0f0ecae..85a1e53 100644
--- a/market/default.scm
+++ b/market/default.scm
@@ -14,8 +14,8 @@
  | limitations under the License.
  |#
 
-(define (always-false line) #f)
-(define (line-always-true line) line)
+(define (always-false node line) #f)
+(define (line-always-true node line) line)
 
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Unordered lists and unordered list items
@@ -29,7 +29,7 @@
 (define (unordered-list-item? x)
   (and (block-node? x) (unordered-list-item-data? (node-data x))))
 
-(define (starts-unordered-list line)
+(define (starts-unordered-list node line)
   (define (on-success line ch number-of-spaces)
     (define continues
       (let ((prefix (make-string (+ number-of-spaces 1) #\space)))
@@ -37,7 +37,8 @@
     (let ((item (make-empty-node (make-unordered-list-item-data ch)
                                  continues
                                  (default-allowed))))
-      (values item item line)))
+      (add-new-child! node item #t)
+      (values item line)))
   (define (count-more-spaces line ch num)
     (cond
       ((eqv? (line-ref line) #\space)
@@ -61,20 +62,21 @@
 (define (code-block? x)
   (and (block-node? x) (eq? (node-data x) 'code-block)))
 
-(define (starts-code-block line)
-  (define (continues-code-block line)
+(define (starts-code-block node line)
+  (define (continues-code-block node line)
     (or (line-prefix line "    ")
         (line-prefix line #\tab)))
   (define (on-success line)
     (let* ((paragraph (string->xstring ""))
-           (node (make-block-node 'code-block
-                                  continues-code-block
-                                  always-false
-                                  (list-queue paragraph)
-                                  paragraph)))
-      (values node node line)))
+           (new-node (make-block-node 'code-block
+                                      continues-code-block
+                                      always-false
+                                      (list-queue paragraph)
+                                      paragraph)))
+      (add-new-child! node new-node #t)
+      (values new-node line)))
   (cond
-    ((continues-code-block line) => on-success)
+    ((continues-code-block node line) => on-success)
     (else #f)))
 
 ;;; ;;;;;;;;;;;;;;;;;
@@ -84,7 +86,7 @@
 (define (block-quote? x)
   (and (block-node? x) (eq? (node-data x) 'block-quote)))
 
-(define (continues-block-quote line)
+(define (continues-block-quote node line)
   (cond
     ((line-prefix line ">") => (cut line-prefix-opt <> " "))
     (else #f)))
@@ -94,15 +96,17 @@
                    continues-block-quote
                    (default-allowed)))
 
-(define (starts-block-quote line)
+(define (starts-block-quote node line)
   (define (on-success line number-of->)
     (let ((top-node (make-empty-block-quote)))
       (let loop ((cur-node top-node)
                  (number-of-> number-of->))
         (if (= number-of-> 1)
-            (values top-node cur-node line)
+            (begin
+              (add-new-child! node top-node #t)
+              (values cur-node line))
             (let ((next-node (make-empty-block-quote)))
-              (add-new-active-child! cur-node next-node)
+              (add-new-child! cur-node next-node #t)
               (loop next-node (- number-of-> 1)))))))
   (define (expect-nesting-or-space line number-of->)
     (let ((ch (line-ref line)))
@@ -132,16 +136,16 @@
 (define (atx-heading-indent block)
   (atx-heading-data-indent (node-data block)))
 
-(define (starts-atx-heading line)
+(define (starts-atx-heading node line)
   ;; TODO: add detecting the end of the heading
   (define (on-success line indent)
-    (values (make-block-node (make-atx-heading-data indent)
-                             always-false
-                             always-false
-                             (list-queue (line->xstring line))
-                             #f)
-            #f
-            line))
+    (let ((new-node (make-block-node (make-atx-heading-data indent)
+                                     always-false
+                                     always-false
+                                     (list-queue (line->xstring line))
+                                     #f)))
+      (add-new-child! node new-node #f)
+      (values node line)))
   (let detect ((line line)
                (indent 0))
     (cond
@@ -160,12 +164,12 @@
 
 (define default-allowed
   (make-parameter
-   (lambda (line)
+   (lambda (node line)
      (cond
-       ((starts-code-block line) first-arg => values)
-       ((starts-block-quote line) first-arg => values)
-       ((starts-atx-heading line) first-arg => values)
-       ((starts-unordered-list line) first-arg => values)
+       ((starts-code-block node line) first-arg => values)
+       ((starts-block-quote node line) first-arg => values)
+       ((starts-atx-heading node line) first-arg => values)
+       ((starts-unordered-list node line) first-arg => values)
        (else #f)))))
 
 ;;; ;;;;;;;;;;;;;;;;;
@@ -177,10 +181,13 @@
 
 (define (document-node)
   (make-empty-node 'document
-                   (lambda (x) x)
+                   line-always-true
                    (default-allowed)))
 
-(define (parse->document str node)
-  (let ((node (or node (document-node))))
-    (parse-line-to-node node (string->line str))
-    node))
+(define parse->document
+  (case-lambda
+    ((str) (parse->document str (document-node)))
+    ((str node)
+     (parse-line-to-node! node (string->line str))
+     node)))
+
diff --git a/tests/run.scm b/tests/run.scm
index 550534d..4e8c8ae 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -29,14 +29,14 @@
 
 (test-group "paragraphs"
   (let ((str
-         (chain (parse->document "hello, world" #f)
+         (chain (parse->document "hello, world")
                 (node-children _)
                 (list-queue-list _)
                 (list-ref _ 0)
                 (xstring->string _))))
     (test-equal "single line" str "hello, world\n"))
   (let ((str
-         (chain (parse->document "hello," #f)
+         (chain (parse->document "hello,")
                 (parse->document "world" _)
                 (node-children _)
                 (list-queue-list _)
@@ -45,7 +45,7 @@
     (test-equal "two lines" str "hello,\nworld\n"))
   (test-group "two paragraphs"
     (let ((children
-       (chain (parse->document "hello" #f)
+       (chain (parse->document "hello")
               (parse->document "" _)
               (parse->document "world" _)
               (node-children _)
@@ -59,7 +59,7 @@
 
 (test-group "block quotes"
   (test-group "single line"
-    (let ((block (chain (parse->document "> hello, world" #f)
+    (let ((block (chain (parse->document "> hello, world")
                         (node-children _)
                         (list-queue-list _)
                         (list-ref _ 0))))
@@ -69,7 +69,7 @@
                         (list-ref _ 0)
                         (xstring->string _))))
         (test-equal "string" str "hello, world\n"))))
-  (let ((str (chain (parse->document "> hello," #f)
+  (let ((str (chain (parse->document "> hello,")
                     (parse->document "> world" _)
                     (node-children _)
                     (list-queue-list _)
@@ -80,7 +80,7 @@
                     (xstring->string _))))
     (test-equal "two lines" str "hello,\nworld\n"))
   (test-group "multiple paragraphs"
-    (let ((lst (chain (parse->document "> hello" #f)
+    (let ((lst (chain (parse->document "> hello")
                       (parse->document "> " _)
                       (parse->document "> world" _)
                       (node-children _)
@@ -95,7 +95,7 @@
                   (xstring->string (list-ref lst 1))
                   "world\n")))
   (test-group "interrupted"
-    (let ((lst (chain (parse->document "> hello, world" #f)
+    (let ((lst (chain (parse->document "> hello, world")
                       (parse->document "outside of a block quote" _)
                       (node-children _)
                       (list-queue-list _))))
@@ -116,7 +116,7 @@
                   (xstring->string (list-ref lst 1)))))
   (test-group "two nested with spaces"
     (define block
-      (chain (parse->document "> > hello, world" #f)
+      (chain (parse->document "> > hello, world")
              (parse->document "> > continuing nested" _)
              (parse->document "> outside of the block quote" _)
              (node-children _)
@@ -143,7 +143,7 @@
                        (xstring->string _))))
   (test-group "two nested without spaces"
     (define block
-      (chain (parse->document ">> hello, world" #f)
+      (chain (parse->document ">> hello, world")
              (parse->document ">> continuing nested" _)
              (parse->document "> at first level" _)
              (parse->document "> continuing first level" _)
@@ -170,7 +170,7 @@
 
 (test-group "atx headings"
   (test-group "heading 1"
-    (let ((heading (chain (parse->document "# hello" #f)
+    (let ((heading (chain (parse->document "# hello")
                           (node-children _)
                           (list-queue-list _)
                           (list-ref _ 0))))
@@ -181,7 +181,7 @@
                                         (list-ref _ 0)
                                         (xstring->string _)))))
   (test-group "heading 6"
-    (let ((heading (chain (parse->document "###### hello" #f)
+    (let ((heading (chain (parse->document "###### hello")
                           (node-children _)
                           (list-queue-list _)
                           (list-ref _ 0))))
@@ -192,7 +192,7 @@
                                         (list-ref _ 0)
                                         (xstring->string _)))))
   (test-group "heading followed by paragraph"
-    (let ((children (chain (parse->document "## hello, " #f)
+    (let ((children (chain (parse->document "## hello, ")
                            (parse->document "world" _)
                            (parse->document "## another heading" _)
                            (node-children _)
@@ -218,7 +218,7 @@
                             (xstring->string _)))
         (test-equal "text" "another heading" text))))
   (test-group "heading inside block quote"
-    (let ((children (chain (parse->document "> # nested heading" #f)
+    (let ((children (chain (parse->document "> # nested heading")
                            (parse->document "> text inside quote" _)
                            (parse->document "### outside of quote" _)
                            (node-children _)
@@ -253,7 +253,7 @@
 
 (test-group "code blocks"
   (test-group "single line, 4 spaces"
-    (let ((block (chain (parse->document "    (procedure? call/cc)" #f)
+    (let ((block (chain (parse->document "    (procedure? call/cc)")
                         (node-children _)
                         (list-queue-list _)
                         (list-ref _ 0))))
@@ -265,7 +265,7 @@
                          (list-ref _ 0)
                          (xstring->string _)))))
   (test-group "single line, tab"
-    (let ((block (chain (parse->document "\t(procedure? call/cc)" #f)
+    (let ((block (chain (parse->document "\t(procedure? call/cc)")
                         (node-children _)
                         (list-queue-list _)
                         (list-ref _ 0))))
@@ -277,7 +277,7 @@
                          (list-ref _ 0)
                          (xstring->string _)))))
   (test-group "multiple lines, mixing"
-    (let ((str (chain (parse->document "    (lambda (x)" #f)
+    (let ((str (chain (parse->document "    (lambda (x)")
                       (parse->document "\t  x)" _)
                       (node-children _)
                       (list-queue-list _)
@@ -290,7 +290,7 @@
                   "(lambda (x)\n  x)\n"
                   str)))
   (test-group "no quotes in code blocks"
-    (let ((first-child (chain (parse->document "    > not a block" #f)
+    (let ((first-child (chain (parse->document "    > not a block")
                               (node-children _)
                               (list-queue-list _)
                               (list-ref _ 0)
@@ -302,7 +302,7 @@
                   "> not a block\n"
                   (xstring->string first-child))))
   (test-group "code block in quotes"
-    (let ((node (chain (parse->document ">     quoted code" #f)
+    (let ((node (chain (parse->document ">     quoted code")
                        (node-children _)
                        (list-queue-list _)
                        (list-ref _ 0))))