fix tight nesting of block quotes

5 files changed, 61 insertions, 10 deletions

diff --git a/market/blocks.sld b/market/blocks.sld
index 4e05c3d..d4a78dc 100644
--- a/market/blocks.sld
+++ b/market/blocks.sld
@@ -24,5 +24,6 @@
     (else))
   (export make-block-node node-data node-children
           make-empty-node block-node?
+          add-new-active-child!
           parse-line-to-node)
   (include "blocks.scm"))
diff --git a/market/default.scm b/market/default.scm
index 07a4ec1..ade7b7b 100644
--- a/market/default.scm
+++ b/market/default.scm
@@ -85,17 +85,37 @@
 (define (block-quote? x)
   (and (block-node? x) (eq? (node-data x) 'block-quote)))
 
+(define (continues-block-quote line)
+  (cond
+    ((line-prefix line ">") => (cut line-prefix-opt <> " "))
+    (else #f)))
+
+(define (make-empty-block-quote)
+  (make-empty-node 'block-quote
+                   continues-block-quote
+                   (default-allowed)))
+
 (define (starts-block-quote line)
-  (define (continues-block-quote line)
-    (line-prefix line "> "))
-  (define (on-success line)
-    (let ((node (make-empty-node 'block-quote
-                                 continues-block-quote
-                                 (default-allowed))))
-      (values node node line)))
-  ;; TODO: handle `>>...`
+  (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)
+            (let ((next-node (make-empty-block-quote)))
+              (add-new-active-child! cur-node next-node)
+              (loop next-node (- number-of-> 1)))))))
+  (define (expect-nesting-or-space line number-of->)
+    (let ((ch (line-ref line)))
+      (cond
+        ((or (eof-object? ch) (char=? ch #\space))
+         (on-success (line-next line) number-of->))
+        ((char=? ch #\>)
+         (expect-nesting-or-space (line-next line) (+ 1 number-of->)))
+        (else #f))))
   (cond
-    ((continues-block-quote line) => on-success)
+    ((eqv? (line-ref line) #\>) (expect-nesting-or-space (line-next line)
+                                                         1))
     (else #f)))
 
 ;;; ;;;;;;;;;;;;;;;;;;;;
diff --git a/market/string.scm b/market/string.scm
index 9d733ca..c226c89 100644
--- a/market/string.scm
+++ b/market/string.scm
@@ -87,6 +87,9 @@
        (line-prefix (line-next line) (line-next str-line)))
       (else #f))))
 
+(define (line-prefix-opt line str)
+  (or (line-prefix line str) line))
+
 (define (line-member line lst)
   (if (empty-line? line)
       #f
diff --git a/market/string.sld b/market/string.sld
index 0895993..4f53844 100644
--- a/market/string.sld
+++ b/market/string.sld
@@ -22,6 +22,7 @@
     (else))
   (export string->line empty-line
           empty-line? line-ref line-next line->string line-prefix
+          line-prefix-opt
           line-member
           string->xstring xstring->generator xstring->string
           xstring? xstring-append! line->xstring)
diff --git a/tests/run.scm b/tests/run.scm
index ef1c172..bc67ab6 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -140,4 +140,30 @@
                 (chain (node-children block)
                        (list-queue-list _)
                        (list-ref _ 0)
-                       (xstring->string _)))))
+                       (xstring->string _))))
+  (test-group "two nested without spaces"
+    (define block
+      (chain (parse->document ">> hello, world" #f)
+             (parse->document ">> continuing nested" _)
+             (parse->document "> at first level" _)
+             (parse->document "> continuing first level" _)
+             (node-children _)
+             (list-queue-list _)
+             (list-ref _ 0)))
+    (test-assert "first block quote" (block-quote? block))
+    (test-equal "first block quote paragraph"
+                "at first level\ncontinuing first level\n"
+                (chain (node-children block)
+                       (list-queue-list _)
+                       (list-ref _ 1)
+                       (xstring->string _)))
+    (define nested-str (chain (node-children block)
+                              (list-queue-list _)
+                              (list-ref _ 0)
+                              (node-children _)
+                              (list-queue-list _)
+                              (list-ref _ 0)
+                              (xstring->string _)))
+    (test-equal "nested block quote paragraph"
+                "hello, world\ncontinuing nested\n"
+                nested-str)))