thematic breaks

3 files changed, 158 insertions, 10 deletions

diff --git a/market/default.scm b/market/default.scm
index 0687ea7..243b4fa 100644
--- a/market/default.scm
+++ b/market/default.scm
@@ -17,6 +17,16 @@
 (define (always-false node line) #f)
 (define (line-always-true node line) line)
 
+(define (up-to-spaces line max-spaces)
+  ;; Read up to `max-spaces` spaces from `line`. On success, tail-call
+  ;; `(K line)`, where `line` starts at the first non-space.
+  (let loop ((counted 0))
+    (if (eqv? (line-ref line) #\space)
+        (if (> counted max-spaces)
+            #f
+            (up-to-spaces (line-next line) (- max-spaces 1)))
+        (values line counted))))
+
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Unordered lists and unordered list items
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -43,20 +53,18 @@
                                  (default-allowed))))
       (add-new-child! node item #t)
       (values item line)))
-  (define (count-more-spaces line ch num)
+  (define (expect-space number-of-spaces ch line)
     (cond
       ((eqv? (line-ref line) #\space)
-       (if (>= num 4)
-           #f
-           (count-more-spaces (line-next line) ch (+ num 1))))
-      (else (on-success line ch num))))
-  (define (check-rest ch line)
+       (on-success (line-next line) ch (+ number-of-spaces 1)))
+      (else #f)))
+  (define (check-member line number-of-spaces )
     (cond
-      ((eqv? (line-ref line) #\space)
-       (count-more-spaces (line-next line) ch 1))
+      ((line-member line '(#\* #\- #\+))
+       first-arg => (cut expect-space number-of-spaces <...>))
       (else #f)))
   (cond
-    ((line-member line '(#\* #\- #\+)) first-arg => check-rest)
+    ((up-to-spaces line 3) first-arg => check-member)
     (else #f)))
 
 ;;; ;;;;;;;;;;;;;;;;;;;;;
@@ -162,6 +170,40 @@
        (on-success (line-next line) indent))
       (else #f))))
 
+;;; ;;;;;;;;;;;;;;;
+;;; Thematic breaks
+;;; ;;;;;;;;;;;;;;;
+
+(define (starts-thematic-break node line)
+  (define (start)
+    (cond
+      ((up-to-spaces line 3) first-arg => read-break)
+      (else #f)))
+  (define (read-break line _)
+    (cond
+      ((line-member line '(#\* #\- #\_)) first-arg => read-more)
+      (else #f)))
+  (define (read-more ch line)
+    (let loop ((count 1)
+               (line line))
+      (cond
+        ((and (empty-line? line) (>= count 3))
+         (let ((new-node (make-empty-node 'thematic-break
+                                          always-false
+                                          always-false)))
+           (add-new-child! node new-node #f)
+           (values node line)))
+        ((empty-line? line) #f)
+        ((char=? (line-ref line) ch) (loop (+ count 1)
+                                           (line-next line)))
+        ((char-whitespace? (line-ref line)) (loop count
+                                                  (line-next line)))
+        (else #f))))
+  (start))
+
+(define (thematic-break? x)
+  (and (block-node? x) (eqv? (node-data x) 'thematic-break)))
+
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Default blocks
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;
@@ -173,6 +215,7 @@
        ((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-thematic-break node line) first-arg => values)
        ((starts-unordered-list node line) first-arg => values)
        (else #f)))))
 
diff --git a/market/default.sld b/market/default.sld
index 6a1ad0e..25f3194 100644
--- a/market/default.sld
+++ b/market/default.sld
@@ -15,13 +15,14 @@
  |#
 
 (define-library (market default)
-  (import (scheme base) (scheme write)
+  (import (scheme base) (scheme write) (scheme char)
           (srfi 1) (srfi 26) (mcgoron srfi 61) (srfi 117)
           (market blocks) (market string))
   (cond-expand
     (chicken (import (chicken base)))
     (else))
   (export unordered-list-item? code-block? block-quote? atx-heading?
+          thematic-break?
           atx-heading-indent
           default-allowed
           document-node?
diff --git a/tests/run.scm b/tests/run.scm
index 014522e..2fef24a 100644
--- a/tests/run.scm
+++ b/tests/run.scm
@@ -566,3 +566,107 @@
      (chain-lambda (test-child "xstring?" xstring? 2 _)
                    (xstring->string _)
                    (test-equal-then "text" "bar\n" _)))))
+
+(test-group "thematic breaks"
+  (define (test-single-thematic-break name data)
+    (with-test-chain name
+      (test-parse->document data)
+      (test-node-list "document children" 1 _)
+      (test-child "thematic break" thematic-break? 0 _)))
+  (define (test-as-code-block name data)
+    (with-test-chain name
+      (test-parse->document (string-append "\t" data))
+      (test-node-list "document-children" 1 _)
+      (test-child "code block" code-block? 0 _)
+      (test-node-list "block list" 1 _)
+      (test-child "xstring?" xstring? 0 _)
+      (xstring->string _)
+      (test-equal-then "text"
+                       (string-append data "\n")
+                       _)))
+  (define (test-as-paragraph name data)
+    (with-test-chain name
+      (test-parse->document data)
+      (test-node-list "document children" 1 _)
+      (test-child "xstring?" xstring? 0 _)
+      (xstring->string _)
+      (test-equal-then "text"
+                       (string-append data "\n")
+                       _)))
+  (test-single-thematic-break "***" "***")
+  (test-single-thematic-break " ***" " ***")
+  (test-single-thematic-break "  ***" "  ***")
+  (test-single-thematic-break "   ***" "   ***")
+  (test-single-thematic-break "* * *" "* * *")
+  (test-single-thematic-break "*********" "*********")
+  (test-as-code-block "code block ***" "***")
+  (test-as-paragraph "**" "**")
+  (test-as-paragraph "***a***" "***a***")
+  (test-single-thematic-break "-" "---")
+  (test-single-thematic-break " -" " ---")
+  (test-single-thematic-break "  -" "  ---")
+  (test-single-thematic-break "   -" "   ---")
+  (test-as-code-block "code block ---" "---")
+  (test-as-paragraph "--" "--")
+  (test-as-paragraph "--" "--")
+  (test-as-paragraph "---a" "---a")
+  (test-as-paragraph "   -----a------" "   -----a------")
+  (test-single-thematic-break "- - -" "- - -")
+  (test-single-thematic-break "---------" "---------")
+  (test-single-thematic-break "_" "___")
+  (test-single-thematic-break " _" " ___")
+  (test-single-thematic-break "  _" "  ___")
+  (test-single-thematic-break "   _" "   ___")
+  (test-as-code-block "code block ___" "___")
+  (test-as-paragraph "__" "__")
+  (test-single-thematic-break "_ _ _" "_ _ _")
+  (test-single-thematic-break "_________" "_________")
+  (test-as-paragraph "__" "__")
+  (test-as-paragraph "___a" "___a")
+  (test-as-paragraph "   _____a______" "   _____a______")
+  (with-test-chain "break takes precedence"
+    (test-parse->document "* hello")
+    (test-parse->document "* * *" _)
+    (test-parse->document "* world" _)
+    (test-node-list "document children" 3 _)
+    (fork
+     "first list item"
+     _
+     (chain-lambda (test-child "unordered list?" unordered-list-item? 0 _)
+                   (test-node-list "children" 1 _)
+                   (test-child "xstring?" xstring? 0 _)
+                   (xstring->string _)
+                   (test-equal-then "text" "hello\n" _)))
+    (fork
+     "thematic break"
+     _
+     (chain-lambda (test-child "thematic break" thematic-break? 1 _)))
+    (fork
+     "third list item"
+     _
+     (chain-lambda (test-child "unordered list?" unordered-list-item? 2 _)
+                   (test-node-list "children" 1 _)
+                   (test-child "xstring?" xstring? 0 _)
+                   (xstring->string _)
+                   (test-equal-then "text" "world\n" _))))
+  (with-test-chain "interrupt paragraph"
+    (test-parse->document "hello")
+    (test-parse->document "***" _)
+    (test-parse->document "world" _)
+    (test-node-list "document children" 3 _)
+    (fork
+     "hello"
+     _
+     (chain-lambda (test-child "xstring?" xstring? 0 _)
+                   (xstring->string _)
+                   (test-equal-then "text" "hello\n" _)))
+    (fork
+     "break"
+     _
+     (chain-lambda (test-child "thematic break" thematic-break? 1 _)))
+    (fork
+     "world"
+     _
+     (chain-lambda (test-child "xstring?" xstring? 2 _)
+                   (xstring->string _)
+                   (test-equal-then "text" "world\n" _)))))