decode improvements

decode.rkt

@@ -9,6 +9,19 @@
 (require "tools.rkt" "library/html.rkt")
 (provide (all-defined-out))
 
+
+;; split list into list of sublists using test
+;; todo: contract & unit tests
+(define (splitf-at* pieces test)
+  (define (splitf-at*-inner pieces [acc '()]) ; use acc for tail recursion
+    (if (empty? pieces) 
+        acc
+        (let-values ([(item rest) 
+                      (splitf-at (dropf pieces test) (compose1 not test))])
+          (splitf-at*-inner rest `(,@acc ,item)))))
+  (splitf-at*-inner (trim pieces test)))
+
+
 ;; Find adjacent newline characters in a list and merge them into one item
 ;; Scribble, by default, makes each newline a separate list item
 ;; In practice, this is worthless.
@@ -43,14 +56,14 @@
 
 
 ;; is the named-xexpr a block element (as opposed to inline)
-(define/contract (block-xexpr? nx)
-  (named-xexpr? . -> . boolean?)
+(define/contract (block-xexpr? x)
+  (any/c . -> . boolean?)
   ;; this is a change in behavior since first pollen
   ;; blocks are only the ones on the html block tag list.
   ;; todo: make sure this is what I want.
   ;; this is, however, more consistent with browser behavior
   ;; (browsers assume that tags are inline by default)
-  (->boolean ((named-xexpr-name nx) . in . block-tags)))
+  ((named-xexpr? x) . and . (->boolean ((named-xexpr-name x) . in . block-tags))))
 
 (module+ test
   (check-true (block-xexpr? '(p "foo")))
@@ -69,14 +82,6 @@
 
 
 
-; trim from beginning & end of list
-(define (trim items test-proc)
-  (dropf-right (dropf items test-proc) test-proc))
-
-(module+ test
-  (check-equal? (trim (list "\n" " " 1 2 3 "\n") whitespace?) '(1 2 3))
-  (check-equal? (trim (list 1 3 2 4 5 6 8 9 13) odd?) '(2 4 5 6 8)))
-
 ;; recursive whitespace test
 ;; Scribble's version misses whitespace in a list
 (define (whitespace? x)
@@ -95,8 +100,27 @@
 
 
 
-;; function to strip metas
-;; todo: make this more recursive?
+;; trim from beginning & end of list
+(define (trim items test-proc)
+  (list? procedure? . -> . list?)
+  (dropf-right (dropf items test-proc) test-proc))
+
+(module+ test
+  (check-equal? (trim (list "\n" " " 1 2 3 "\n") whitespace?) '(1 2 3))
+  (check-equal? (trim (list 1 3 2 4 5 6 8 9 13) odd?) '(2 4 5 6 8)))
+
+
+
+;; test for well-formed meta
+(define/contract (meta-xexpr? x)
+  (any/c . -> . (λ(i) (or (boolean? i) (list? i))))
+  (match x
+    [`(meta ,(? string? key) ,(? string? value)) (list key value)]
+    [else #f]))
+
+
+
+;; function to strip metas (or any tag)
 (define/contract (extract-tag-from-xexpr tag nx)
   (xexpr-name? named-xexpr? . -> . (values named-xexpr? xexpr-content?))
   (define matches '())
@@ -126,7 +150,7 @@
                          #:exclude-xexpr-names [excluded-xexpr-names '()]
                          #:xexpr-name-proc [xexpr-name-proc (λ(x)x)]
                          #:xexpr-attr-proc [xexpr-attr-proc (λ(x)x)]
-                         #:xexpr-content-proc [xexpr-content-proc #f] ; set this to &decode later
+                         #:xexpr-content-proc [xexpr-content-proc (λ(x)x)]
                          #:block-xexpr-proc [block-xexpr-proc (λ(x)x)]
                          #:inline-xexpr-proc [inline-xexpr-proc (λ(x)x)]
                          #:string-proc [string-proc (λ(x)x)]
@@ -145,11 +169,6 @@
     (error (format "decode: ~v not a full named-xexpr" nx)))
   
   (define metas (list))
-  (define/contract (is-meta? x)
-    (any/c . -> . (λ(i) (or (boolean? i) (list? i))))
-    (match x
-      [`(meta ,(? string? key) ,(? string? value)) (list key value)]
-      [else #f]))
   
   (define (&decode x)
     (cond
@@ -158,13 +177,12 @@
                               x
                               (let ([decoded-xexpr 
                                      (apply make-named-xexpr (map &decode (list name attr content)))])
-                                (if (block-xexpr? decoded-xexpr)
-                                    (block-xexpr-proc decoded-xexpr)
-                                    (inline-xexpr-proc decoded-xexpr)))))]
+                                ((if (block-xexpr? decoded-xexpr)
+                                     block-xexpr-proc
+                                     inline-xexpr-proc) decoded-xexpr))))]
       [(xexpr-name? x) (xexpr-name-proc x)]
       [(xexpr-attr? x) (xexpr-attr-proc x)]
-      [(xexpr-content? x) (let ([xexpr-content-proc (or xexpr-content-proc (λ(x) (map &decode x)))])
-                            (xexpr-content-proc x))]
+      [(xexpr-content? x) (map &decode (xexpr-content-proc x))]
       [(string? x) (string-proc x)]
       [else x]))
   

tests/pollen-lang-test.p

@@ -6,6 +6,11 @@ Hello world
    
 ◊em{Love}
 
-Goodnight moon
+Goodnight
+moon
+
+◊foo
+
+
+
 
-◊foo

tests/requires/include-me.rkt

@@ -1,31 +1,79 @@
 #lang racket/base
-(require racket/contract racket/list)
+(require racket/contract racket/list racket/match)
 (require (planet mb/pollen/tools) (planet mb/pollen/decode))
 
 (provide (all-defined-out))
 
 (module+ test (require rackunit))
 
-(define (meta-proc meta)
-  `(meta ((name ,(->string (second meta)))(content ,(->string (third meta))))))
+;; todo: contracts & unit tests
+(define/contract (meta-proc meta)
+  (meta-xexpr? . -> . named-xexpr?)
+  `(meta ((name ,(second meta))(content ,(third meta)))))
 
-(define (string-proc string)
-  "puppies")
+(module+ test
+  (check-equal? (meta-proc '(meta "key" "value")) '(meta ((name "key")(content "value")))))
 
+
+;; how a paragraph break is denoted: two or more newlines
+(define/contract (paragraph-break? str)
+  (string? . -> . boolean?)
+  (->boolean (regexp-match #px"^\n{2,}$" str)))
+  
+(module+ test
+  (check-false (paragraph-break? "foo"))
+  (check-false (paragraph-break? "\n"))
+  (check-true (paragraph-break? "\n\n"))
+  (check-true (paragraph-break? "\n\n\n")))
+
+
+;; convert single newline to br tag
+;; only if neither adjacent tag is a block
+;; otherwise delete
+;; todo: contracts & unit tests
+(define (convert-linebreaks x)  ; x is list
+  (filter-not empty?
+              (for/list ([i (len x)])
+                (cond
+                  [(equal? (get x i) "\n") ; todo: don't hardcode this
+                   (if (andmap (λ(i) (not (block-xexpr? i))) (list (get x (sub1 i)) (get x (add1 i))))
+                       '(br)
+                       '())]
+                  [else (get x i)]))))
+
+;; todo: contracts & unit tests
+(define (prep-paragraph-flow x)
+  (convert-linebreaks (merge-newlines (trim x whitespace?))))
+
+(module+ test
+  (check-equal? (prep-paragraph-flow '("\n" "foo" "\n" "\n" "bar" "\n" "ino" "\n"))
+                '("foo" "\n\n" "bar" (br) "ino")))
+
+;; todo: contracts & unit tests
+(define (wrap-paragraph x) ; x is a list containing paragraph pieces
+  ; if paragraph is just one block-level xexpr
+  (if (and (= (length x) 1) (block-xexpr? (car x))) 
+      (car x) ; leave it
+      `(p ,@x))) ; otherwise wrap in p tag
+
+;; todo: contracts & unit tests
 (define (xexpr-content-proc content)
-  (map (λ(i) "boing") content))
+  (let ([content (prep-paragraph-flow content)]) 
+    (if (ormap paragraph-break? content) ; need this condition to prevent infinite recursion
+        (map wrap-paragraph (splitf-at* content paragraph-break?)) ; split into ¶¶
+        content)))
 
 (define (root . items)
   (named-xexpr? . -> . named-xexpr?)
   (decode (cons 'root items)
-          #:exclude-xexpr-names 'em
-;          #:xexpr-name-proc [xexpr-name-proc (λ(x)x)]
-;          #:xexpr-attr-proc [xexpr-attr-proc (λ(x)x)]
- ;         #:xexpr-content-proc xexpr-content-proc
-;          #:block-xexpr-proc [block-xexpr-proc (λ(x)x)]
-;          #:inline-xexpr-proc [inline-xexpr-proc (λ(x)x)]
- ;         #:string-proc string-proc
- ;         #:meta-proc meta-proc
+          ;          #:exclude-xexpr-names 'em
+          ;          #:xexpr-name-proc [xexpr-name-proc (λ(x)x)]
+          ;          #:xexpr-attr-proc [xexpr-attr-proc (λ(x)x)]
+          #:xexpr-content-proc xexpr-content-proc
+          ;          #:block-xexpr-proc [block-xexpr-proc (λ(x)x)]
+          ;          #:inline-xexpr-proc [inline-xexpr-proc (λ(x)x)]
+          ;         #:string-proc string-proc
+          #:meta-proc meta-proc
           ))
 
 

tools.rkt

@@ -2,7 +2,7 @@
 (require racket/contract racket/match)
 (require (only-in racket/path filename-extension))
 (require (only-in racket/format ~a))
-(require (only-in racket/list empty empty? second filter-not splitf-at takef dropf))
+(require (only-in racket/list empty empty? second filter-not splitf-at takef dropf dropf-right))
 (require (only-in racket/string string-join))
 (require (only-in xml xexpr? xexpr/c))
 
@@ -227,5 +227,3 @@
 (module+ test
   (check-equal? (map-tree (λ(i) (if (number? i) (* 2 i) i)) '(p 1 2 3 (em 4 5))) '(p 2 4 6 (em 8 10)))
   (check-equal? (map-tree (λ(i) (if (symbol? i) 'foo i)) '(p 1 2 3 (em 4 5))) '(foo 1 2 3 (foo 4 5))))
-
-