mbutterick
/
pollen
3
3
Fork 0
Code Issues 1 Pull Requests Projects Releases Wiki Activity

working …

Browse Source
pull/9/head
Matthew Butterick 11 years ago
parent 218bf29a5c
commit 8d78b98258
3 changed files with 20 additions and 21 deletions
Show Stats Download Patch File Download Diff File

24
decode.rkt
Unescape Escape View File

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

2
predicates.rkt
Unescape Escape View File

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

15
template.rkt
Unescape Escape View File

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

Write Preview
Loading…
Cancel
Save