working …

pull/9/head
Matthew Butterick 10 years ago
parent 218bf29a5c
commit 8d78b98258

@ -22,7 +22,7 @@
(define+provide/contract (decode nx
#:exclude-xexpr-tags [excluded-xexpr-tags '()]
#:xexpr-tag-proc [xexpr-tag-proc (λ(x)x)]
#:xexpr-attr-proc [xexpr-attr-proc (λ(x)x)]
#:xexpr-attrs-proc [xexpr-attrs-proc (λ(x)x)]
#:xexpr-elements-proc [xexpr-elements-proc (λ(x)x)]
#:block-xexpr-proc [block-xexpr-proc (λ(x)x)]
#:inline-xexpr-proc [inline-xexpr-proc (λ(x)x)]
@ -34,7 +34,7 @@
;; and return a string as output
(#:exclude-xexpr-tags list?
#:xexpr-tag-proc procedure?
#:xexpr-attr-proc procedure?
#:xexpr-attrs-proc procedure?
#:xexpr-elements-proc procedure?
#:block-xexpr-proc procedure?
#:inline-xexpr-proc procedure?
@ -46,7 +46,7 @@
(define (&decode x)
(cond
[(tagged-xexpr? x) (let-values([(tag attr elements) (break-tagged-xexpr x)])
[(tagged-xexpr? x) (let-values([(tag attr elements) (tagged-xexpr->values x)])
(if (tag . in? . excluded-xexpr-tags)
x ; let x pass through untouched
(let ([decoded-xexpr (apply make-tagged-xexpr
@ -54,10 +54,10 @@
((if (block-xexpr? decoded-xexpr)
block-xexpr-proc
inline-xexpr-proc) decoded-xexpr))))]
[(xexpr-tag? x) (xexpr-tag-proc x)]
[(xexpr-attr? x) (xexpr-attr-proc x)]
[(tagged-xexpr-tag? x) (xexpr-tag-proc x)]
[(tagged-xexpr-attrs? x) (xexpr-attrs-proc x)]
;; need this for operations that may depend on context in list
[(xexpr-elements? x) (map &decode (xexpr-elements-proc x))]
[(tagged-xexpr-elements? x) (map &decode (xexpr-elements-proc x))]
[(string? x) (string-proc x)]
;; if something has made it through undecoded, that's a problem
[else (error "Can't decode" x)]))
@ -140,7 +140,7 @@
(cond
[(string? x) (replace-last-space x)]
[(tagged-xexpr? x)
(let-values([(tag attr elements) (break-tagged-xexpr x)])
(let-values([(tag attr elements) (tagged-xexpr->values x)])
(if (> (length elements) 0) ; elements is list of xexprs
(let-values ([(all-but-last last) (split-at elements (sub1 (length elements)))])
(make-tagged-xexpr tag attr `(,@all-but-last ,(find-last-word-space (car last)))))
@ -169,7 +169,7 @@
#:double-prepend [double-pp '(dquo)])
((tagged-xexpr?) (#:single-prepend list? #:double-prepend list?) . ->* . tagged-xexpr?)
(define two-or-more-char-string? (λ(i) (and (string? i) (>= (len i) 2))))
(define-values (tag attr elements) (break-tagged-xexpr nx))
(define-values (tag attr elements) (tagged-xexpr->values nx))
(make-tagged-xexpr tag attr
(if (and (list? elements) (not (empty? elements)))
(let ([new-car-elements (match (car elements)
@ -209,7 +209,7 @@
;; turn the right items into <br> tags
(define/contract (convert-linebreaks xc #:newline [newline "\n"])
((xexpr-elements?) (#:newline string?) . ->* . xexpr-elements?)
((tagged-xexpr-elements?) (#:newline string?) . ->* . tagged-xexpr-elements?)
;; todo: should this test be not block + not whitespace?
(define not-block? (λ(i) (not (block-xexpr? i))))
(filter-not empty?
@ -292,7 +292,7 @@
;; prepare elements for paragraph testing
(define/contract (prep-paragraph-flow xc)
(xexpr-elements? . -> . xexpr-elements?)
(tagged-xexpr-elements? . -> . tagged-xexpr-elements?)
(convert-linebreaks (merge-newlines (trim xc whitespace?))))
(module+ test
@ -301,7 +301,7 @@
;; apply paragraph tag
(define/contract (wrap-paragraph xc #:tag [tag 'p])
((xexpr-elements?) (#:tag symbol?) . ->* . block-xexpr?)
((tagged-xexpr-elements?) (#:tag symbol?) . ->* . block-xexpr?)
(match xc
[(list (? block-xexpr? bx)) bx] ; leave a single block xexpr alone
[else (make-tagged-xexpr tag empty xc)])) ; otherwise wrap in p tag
@ -317,7 +317,7 @@
;; detect paragraphs
;; todo: unit tests
(define/contract (detect-paragraphs elements)
(xexpr-elements? . -> . xexpr-elements?)
(tagged-xexpr-elements? . -> . tagged-xexpr-elements?)
(let ([elements (prep-paragraph-flow elements)])
(if (ormap paragraph-break? elements) ; need this condition to prevent infinite recursion
(map wrap-paragraph (splitf-at* elements paragraph-break?)) ; split into ¶¶

@ -16,7 +16,7 @@
(define project-block-tags block-tags)
(define+provide/contract (append-block-tag tag)
(xexpr-tag? . -> . void?)
(tagged-xexpr-tag? . -> . void?)
(set! project-block-tags (cons tag project-block-tags)))
;; is the tagged-xexpr a block element (as opposed to inline)

@ -1,5 +1,5 @@
#lang racket/base
(require racket/contract racket/string xml xml/path racket/bool)
(require racket/contract racket/string xml xml/path)
(require "tools.rkt" "ptree.rkt" sugar/scribble sugar/coerce sugar tagged-xexpr)
;; setup for test cases
@ -44,7 +44,7 @@
(define/contract (find query px)
(query-key? (or/c false? puttable-item?) . -> . (or/c false? xexpr-element?))
(query-key? (or/c #f puttable-item?) . -> . (or/c #f tagged-xexpr-element?))
(define result (and px (or (find-in-metas px query) (find-in-main px query))))
(and result (car result))) ;; return false or first element
@ -58,7 +58,7 @@
|#
(define/contract (find-in-metas px key)
(puttable-item? query-key? . -> . (or/c false? xexpr-elements?))
(puttable-item? query-key? . -> . (or/c #f tagged-xexpr-elements?))
(and (has-decoder-source? px)
(let ([metas (dynamic-require (->decoder-source-path px) 'metas)]
[key (->string key)])
@ -74,7 +74,7 @@
(define/contract (find-in-main px query)
(puttable-item? (or/c query-key? (listof query-key?))
. -> . (or/c false? xexpr-elements?))
. -> . (or/c #f tagged-xexpr-elements?))
(let* ([px (put px)]
;; make sure query is a list of symbols (required by se-path*/list)
[query (map ->symbol (->list query))]
@ -95,10 +95,10 @@
;; todo: explain why
;; todo: do I need this?
(define/contract (splice x)
((or/c tagged-xexpr? xexpr-elements? string?) . -> . xexpr-elements?)
((or/c tagged-xexpr? tagged-xexpr-elements? string?) . -> . tagged-xexpr-elements?)
(cond
[(tagged-xexpr? x) (tagged-xexpr-elements x)]
[(xexpr-elements? x) x]
[(tagged-xexpr-elements? x) x]
[(string? x) (->list x)]))
(module+ test
@ -108,7 +108,7 @@
(define/contract (make-html x)
((or/c tagged-xexpr? xexpr-elements? xexpr-element?) . -> . string?)
((or/c tagged-xexpr? tagged-xexpr-elements? tagged-xexpr-element?) . -> . string?)
(cond
[(tagged-xexpr? x) (xexpr->string x)]
[else (let ([x (->list x)])
@ -118,7 +118,6 @@
(define-values (put-as-html splice-as-html)
(apply values (map (λ(proc) (λ(x) (make-html (proc x)))) (list put splice))))
(define ->html put-as-html)

Loading…
Cancel
Save