remove unordered list containers

Although it is possible to incorporate automatic detection of list
containers in the block parser (look ahead for `* `, if not check
for `  `), but I think that this is premature.

The point of the block parser is to take the input and figure out
what block the item is in. All a list container does is compress
together adjacent list items. This can be done in a second pass.

(This might have the effect of causing list items separated by line
breaks to be in the same list. If there is nothing in between, it
would make sense.)

7 files changed, 52 insertions, 70 deletions

diff --git a/market/blocks.scm b/market/blocks.scm
index f80dec5..609584e 100644
--- a/market/blocks.scm
+++ b/market/blocks.scm
@@ -52,10 +52,10 @@
      (set-record-printer!
       <block-node>
       (lambda (x port)
-        (write `(block-node (data ,(node-data x))
-                            (children ,@(list-queue-list (node-children x))))
-               port)
-        (newline port)))))
+        (pp `(block-node (data ,(node-data x))
+                         (children ,@(list-queue-list (node-children x)))
+                         (active-child ,(get-active-child x)))
+            port)))))
   (else))
 
 (define (make-empty-node data continues allowed-inside)
@@ -91,7 +91,7 @@
     ;; `child` and add a new child. Otherwise, add to the paragraph.
     (cond
       ((allowed-inside node line) first-arg => (cut add-new-child node <...>))
-      (else (xstring-append! active-child line))))
+      (else (xstring-append! active-child line #\newline))))
   (define (handle-child-block)
     ;; Handle insertion of a new line when the active child is a block.
     ;; 
@@ -110,10 +110,12 @@
 
 (define (add-new-paragraph node line)
   ;; Add new node as the active child to `node` with the data of `line`.
-  (add-new-active-child! node (line->xstring line)))
+  (let ((new-child (line->xstring line)))
+    (xstring-append! new-child #\newline)
+    (add-new-active-child! node new-child)))
 
 (define (parse-line-to-node node line)
-  ;; Parse LINE as a part of NODE.
+  ;;  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
diff --git a/market/blocks.sld b/market/blocks.sld
index cdec300..4e05c3d 100644
--- a/market/blocks.sld
+++ b/market/blocks.sld
@@ -19,7 +19,8 @@
           (srfi 26) (mcgoron srfi 61) (srfi 117)
           (market string))
   (cond-expand
-    (chicken (import (chicken base)))
+    (chicken (import (chicken base))
+             (import (chicken pretty-print)))
     (else))
   (export make-block-node node-data node-children
           make-empty-node block-node?
diff --git a/market/default.scm b/market/default.scm
index 6e7018c..07a4ec1 100644
--- a/market/default.scm
+++ b/market/default.scm
@@ -15,67 +15,43 @@
  |#
 
 (define (always-false line) #f)
-(define (always-true line) #t)
+(define (line-always-true line) line)
 
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Unordered lists and unordered list items
 ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define (unordered-list? x)
-  (and (block-node? x) (eq? (node-data x) 'unordered-list)))
-
-(define (generate-new-unordered-list line ch num)
-  (define starts-unordered-list-item
-    (let ((prefix (list->string (cons ch
-                                      (unfold zero?
-                                              (lambda (x) #\space)
-                                              (cut - <> 1)
-                                              num)))))
-      (letrec ((starts
-                (lambda (line)
-                  (define (on-success line)
-                    (let ((node (make-empty-node 'unordered-list-item
-                                                  continues-unordered-list-item
-                                                  (default-allowed))))
-                      (values node node line)))
-                  (cond
-                    ((line-prefix? line prefix) => on-success)
-                    (else #f)))))
-        starts)))
-  (define continues-unordered-list-item
-    (let ((prefix (list->string (unfold zero?
-                                        (lambda (x) #\space)
-                                        (cut - <> 1)
-                                        (+ num 1)))))
-      (cut line-prefix? <> prefix)))
-  (define (on-success line)
-    (let* ((inner-list-item (make-empty-node 'unordered-list-item
-                                              continues-unordered-list-item
-                                              (default-allowed)))
-           (list-container (make-block-node 'unordered-list
-                                            always-false
-                                            starts-unordered-list-item
-                                            (list-queue inner-list-item)
-                                            inner-list-item)))
-      (values list-container inner-list-item line)))
-  (on-success line))
+(define-record-type <unordered-list-item-data>
+  (make-unordered-list-item-data ch)
+  unordered-list-item-data?
+  (ch unordered-list-item-char))
+
+(define (unordered-list-item? x)
+  (and (block-node? x) (unordered-list-item-data? (node-data x))))
 
 (define (starts-unordered-list line)
+  (define (on-success line ch number-of-spaces)
+    (define continues
+      (let ((prefix (make-string (+ number-of-spaces 1) #\space)))
+        (cut line-prefix <> prefix)))
+    (let ((item (make-empty-node (make-unordered-list-item-data ch)
+                                 continues
+                                 (default-allowed))))
+      (values item item line)))
   (define (count-more-spaces line ch num)
     (cond
       ((eqv? (line-ref line) #\space)
        (if (>= num 4)
            #f
            (count-more-spaces (line-next line) ch (+ num 1))))
-      (else (generate-new-unordered-list line ch num))))
+      (else (on-success line ch num))))
   (define (check-rest ch line)
     (cond
       ((eqv? (line-ref line) #\space)
        (count-more-spaces (line-next line) ch 1))
       (else #f)))
   (cond
-    ((line-member line '(#\* #\- #\+))
-     first-arg => check-rest)
+    ((line-member line '(#\* #\- #\+)) first-arg => check-rest)
     (else #f)))
 
 ;;; ;;;;;;;;;;;;;;;;;;
@@ -87,8 +63,8 @@
 
 (define (starts-code-block line)
   (define (continues-code-block line)
-    (or (line-prefix? line "    ")
-        (line-prefix? line #\tab)))
+    (or (line-prefix line "    ")
+        (line-prefix line #\tab)))
   (define (on-success line)
     (let ((paragraph (string->xstring "")))
       (values (make-block-node 'code-block
@@ -111,7 +87,7 @@
 
 (define (starts-block-quote line)
   (define (continues-block-quote line)
-    (line-prefix? line "> "))
+    (line-prefix line "> "))
   (define (on-success line)
     (let ((node (make-empty-node 'block-quote
                                  continues-block-quote
diff --git a/market/default.sld b/market/default.sld
index ae6eb70..6b82798 100644
--- a/market/default.sld
+++ b/market/default.sld
@@ -21,7 +21,7 @@
   (cond-expand
     (chicken (import (chicken base)))
     (else))
-  (export unordered-list? code-block? block-quote? atx-heading?
+  (export unordered-list-item? code-block? block-quote? atx-heading?
           default-allowed
           document-node?
           parse->document)
diff --git a/market/string.scm b/market/string.scm
index f68d174..236ba8b 100644
--- a/market/string.scm
+++ b/market/string.scm
@@ -39,7 +39,7 @@
   (chicken
    (set-record-printer! <line>
                         (lambda (x out)
-                          (write `(line (line->string x)) out)))))
+                          (write `(line ,(line->string x)) out)))))
 
 (define (string->line str) (make-line str (string-cursor-start str)))
 
@@ -77,14 +77,14 @@
     ((char? obj) (string->line (string obj)))
     (else (error "cannot convert to string" obj))))
 
-(define (line-prefix? line str)
-  (let line-prefix? ((line line)
+(define (line-prefix line str)
+  (let line-prefix ((line line)
                      (str-line (coerce-to-line str)))
     (cond
       ((empty-line? str-line) line)
       ((empty-line? line) #f)
       ((char=? (line-ref line) (line-ref str-line))
-       (line-prefix? (line-next line) (line-next str-line)))
+       (line-prefix (line-next line) (line-next str-line)))
       (else #f))))
 
 (define (line-member line lst)
@@ -113,15 +113,18 @@
 (define (string->xstring str)
   (xstring (rope str)))
 
-(define (xstring-append! xstring obj)
-  (let ((new-rope
-         (cond
-           ((string? obj) (rope obj))
-           ((line? obj) (rope (line->string obj)))
-           ((char? obj) (rope (string obj)))
-           (else (error "invalid object" obj)))))
-    (set-xstring-rope! xstring
-                       (rope-append (xstring-rope xstring) new-rope))))
+(define (coerce-to-rope obj)
+  (cond
+    ((string? obj) (rope obj))
+    ((line? obj) (rope (line->string obj)))
+    ((char? obj) (rope (string obj)))
+    (else (error "invalid object" obj))))
+
+(define (xstring-append! xstring . objs)
+  (set-xstring-rope! xstring
+                     (rope-concatenate
+                      (cons (xstring-rope xstring)
+                            (map coerce-to-rope objs)))))
 
 (define (line->xstring line)
   (string->xstring (line->string line)))
diff --git a/market/string.sld b/market/string.sld
index a02ce95..73f231d 100644
--- a/market/string.sld
+++ b/market/string.sld
@@ -21,7 +21,7 @@
     (chicken (import (scheme write) (chicken base)))
     (else))
   (export string->line empty-line
-          empty-line? line-ref line-next line->string line-prefix?
+          empty-line? line-ref line-next line->string line-prefix
           line-member
           string->xstring
           xstring? xstring-append! line->xstring)
diff --git a/prelude.scm b/prelude.scm
index c801175..f638595 100644
--- a/prelude.scm
+++ b/prelude.scm
@@ -23,6 +23,6 @@
 
 (define node #f)
 (define (p s) (set! node (parse->document s node)) (display node))
-(p "> lorem")
-(p "> ipsum")
+#;(p "> lorem")
+#;(p "> ipsum")
 ;;; TODO: how to handle empty-line and adding EOL?