partial suppor for ATX headings

4 files changed, 102 insertions, 8 deletions

diff --git a/market/blocks.scm b/market/blocks.scm
index 609584e..a124cab 100644
--- a/market/blocks.scm
+++ b/market/blocks.scm
@@ -79,8 +79,13 @@
 (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)
-  (parse-line-to-node continue-node line))
+  (if continue-node
+      (parse-line-to-node continue-node line)
+      (set-active-child! node #f)))
 
 (define (process-active-child node line active-child)
   ;; Act on the `active-child` with the given `line`.
diff --git a/market/default.scm b/market/default.scm
index ade7b7b..cbf02f9 100644
--- a/market/default.scm
+++ b/market/default.scm
@@ -123,21 +123,26 @@
 ;;; ;;;;;;;;;;;;;;;;;;;;
 
 (define-record-type <atx-heading>
-  (make-atx-heading-data data indent)
+  (make-atx-heading-data indent)
   atx-heading-data?
-  (data atx-heading-string)
-  (indent atx-heading-indent))
+  (indent atx-heading-data-indent))
 
 (define (atx-heading? x)
   (and (block-node? x) (atx-heading-data? (node-data x))))
 
+(define (atx-heading-indent block)
+  (atx-heading-data-indent (node-data block)))
+
 (define (starts-atx-heading line)
   ;; TODO: add detecting the end of the heading
   (define (on-success line indent)
-    (let* ((data (make-atx-heading-data (line->string line)
-                                        indent))
-           (node (make-empty-node data always-false always-false)))
-      (values node node (empty-line))))
+    (values (make-block-node (make-atx-heading-data indent)
+                             always-false
+                             always-false
+                             (list-queue (line->xstring line))
+                             #f)
+            #f
+            line))
   (let detect ((line line)
                (indent 0))
     (cond
diff --git a/market/default.sld b/market/default.sld
index 6b82798..6a1ad0e 100644
--- a/market/default.sld
+++ b/market/default.sld
@@ -22,6 +22,7 @@
     (chicken (import (chicken base)))
     (else))
   (export unordered-list-item? code-block? block-quote? atx-heading?
+          atx-heading-indent
           default-allowed
           document-node?
           parse->document)
diff --git a/tests/run.scm b/tests/run.scm
index bc67ab6..d44abb8 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -167,3 +167,86 @@
     (test-equal "nested block quote paragraph"
                 "hello, world\ncontinuing nested\n"
                 nested-str)))
+
+(test-group "atx headings"
+  (test-group "heading 1"
+    (let ((heading (chain (parse->document "# hello" #f)
+                          (node-children _)
+                          (list-queue-list _)
+                          (list-ref _ 0))))
+      (test-assert "atx-heading?" (atx-heading? heading))
+      (test-equal "indent" 1 (atx-heading-indent heading))
+      (test-equal "text" "hello" (chain (node-children heading)
+                                        (list-queue-list _)
+                                        (list-ref _ 0)
+                                        (xstring->string _)))))
+  (test-group "heading 6"
+    (let ((heading (chain (parse->document "###### hello" #f)
+                          (node-children _)
+                          (list-queue-list _)
+                          (list-ref _ 0))))
+      (test-assert "atx-heading?" (atx-heading? heading))
+      (test-equal "indent" 6 (atx-heading-indent heading))
+      (test-equal "text" "hello" (chain (node-children heading)
+                                        (list-queue-list _)
+                                        (list-ref _ 0)
+                                        (xstring->string _)))))
+  (test-group "heading followed by paragraph"
+    (let ((children (chain (parse->document "## hello, " #f)
+                           (parse->document "world" _)
+                           (parse->document "## another heading" _)
+                           (node-children _)
+                           (list-queue-list _))))
+      (test-group "atx heading 1"
+        (define heading (list-ref children 0))
+        (test-equal "indent" 2 (atx-heading-indent heading))
+        (define text (chain (node-children heading)
+                            (list-queue-list _)
+                            (list-ref _ 0)
+                            (xstring->string _)))
+        (test-equal "text" "hello, " text))
+      (test-group "paragraph"
+        (define text (chain (list-ref children 1)
+                            (xstring->string _)))
+        (test-equal "text" "world\n" text))
+      (test-group "atx heading 2"
+        (define heading (list-ref children 2))
+        (test-equal "indent" 2 (atx-heading-indent heading))
+        (define text (chain (node-children heading)
+                            (list-queue-list _)
+                            (list-ref _ 0)
+                            (xstring->string _)))
+        (test-equal "text" "another heading" text))))
+  (test-group "heading inside block quote"
+    (let ((children (chain (parse->document "> # nested heading" #f)
+                           (parse->document "> text inside quote" _)
+                           (parse->document "### outside of quote" _)
+                           (node-children _)
+                           (list-queue-list _))))
+      (test-group "block quote"
+        (define block-quote (list-ref children 0))
+        (test-assert "block-quote?" (block-quote? block-quote))
+        (let ((children (chain (node-children block-quote)
+                               (list-queue-list _))))
+          (test-group "atx heading"
+            (define heading (list-ref children 0))
+            (test-equal "indent" 1 (atx-heading-indent heading))
+            (test-equal "text" "nested heading"
+                        (chain (node-children heading)
+                               (list-queue-list _)
+                               (list-ref _ 0)
+                               (xstring->string _))))
+          (test-group "paragraph"
+            (define par (list-ref children 1))
+            (test-equal "text"
+                        "text inside quote\n"
+                        (xstring->string par)))))
+      (test-group "heading outside of quote"
+        (define heading (list-ref children 1))
+        (test-equal "indent" 3 (atx-heading-indent heading))
+        (test-equal "text"
+                    "outside of quote"
+                    (chain (node-children heading)
+                           (list-queue-list _)
+                           (list-ref _ 0)
+                           (xstring->string _)))))))