diff --git a/decode.rkt b/decode.rkt index 311ed37..8186e73 100644 --- a/decode.rkt +++ b/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])) diff --git a/tests/pollen-lang-test.p b/tests/pollen-lang-test.p index ccaf70e..c1fbdec 100644 --- a/tests/pollen-lang-test.p +++ b/tests/pollen-lang-test.p @@ -6,6 +6,11 @@ Hello world ◊em{Love} -Goodnight moon +Goodnight +moon + +◊foo + + + -◊foo \ No newline at end of file diff --git a/tests/requires/include-me.rkt b/tests/requires/include-me.rkt index 7be7189..284222a 100644 --- a/tests/requires/include-me.rkt +++ b/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 )) diff --git a/tools.rkt b/tools.rkt index 92c0ee4..e7c9597 100644 --- a/tools.rkt +++ b/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)))) - -