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

decode improvements: contracts on decode arguments, new decode/block module

Browse Source
pull/9/head
Matthew Butterick 11 years ago
parent 13e82a05be
commit c295603914
4 changed files with 57 additions and 55 deletions
Show Stats Download Patch File Download Diff File

65
decode.rkt
Unescape Escape View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require xml txexpr sugar/define) (require xml txexpr sugar/define)
(require "predicates.rkt" "decode/typography.rkt" "debug.rkt") (require "decode/block.rkt" "decode/typography.rkt" "debug.rkt")
(provide (all-from-out "decode/typography.rkt")) (provide (all-from-out "decode/typography.rkt"))
@ -17,56 +17,59 @@
[(char? x) (format "~a" x)] [(char? x) (format "~a" x)]
[else (error)])))) ; put this last so other xexprish things don't get caught [else (error)])))) ; put this last so other xexprish things don't get caught
;; add a block tag to the list
(define+provide/contract (register-block-tag tag)
(symbol? . -> . void?)
(append-block-tag tag))
;; decoder wireframe ;; decoder wireframe
(define+provide/contract (decode txexpr (define+provide/contract (decode txexpr
#:exclude-xexpr-tags [excluded-xexpr-tags '()] #:txexpr-tag-proc [txexpr-tag-proc (λ(x)x)]
#:xexpr-tag-proc [xexpr-tag-proc (λ(x)x)] #:txexpr-attrs-proc [txexpr-attrs-proc (λ(x)x)]
#:xexpr-attrs-proc [xexpr-attrs-proc (λ(x)x)] #:txexpr-elements-proc [txexpr-elements-proc (λ(x)x)]
#:xexpr-elements-proc [xexpr-elements-proc (λ(x)x)] #:block-txexpr-proc [block-txexpr-proc (λ(x)x)]
#:block-xexpr-proc [block-xexpr-proc (λ(x)x)] #:inline-txexpr-proc [inline-txexpr-proc (λ(x)x)]
#:inline-xexpr-proc [inline-xexpr-proc (λ(x)x)]
#:string-proc [string-proc (λ(x)x)] #:string-proc [string-proc (λ(x)x)]
#:symbol-proc [symbol-proc (λ(x)x)] #:symbol-proc [symbol-proc (λ(x)x)]
#:valid-char-proc [valid-char-proc (λ(x)x)] #:valid-char-proc [valid-char-proc (λ(x)x)]
#:cdata-proc [cdata-proc (λ(x)x)]) #:cdata-proc [cdata-proc (λ(x)x)]
#:exclude-tags [excluded-tags '()])
((xexpr/c) ((xexpr/c)
(#:exclude-xexpr-tags list? (#:txexpr-tag-proc (txexpr-tag? . -> . txexpr-tag?)
#:xexpr-tag-proc procedure? #:txexpr-attrs-proc (txexpr-attrs? . -> . txexpr-attrs?)
#:xexpr-attrs-proc procedure? #:txexpr-elements-proc (txexpr-elements? . -> . txexpr-elements?)
#:xexpr-elements-proc procedure? #:block-txexpr-proc (block-txexpr? . -> . block-txexpr?)
#:block-xexpr-proc procedure? #:inline-txexpr-proc (txexpr? . -> . txexpr?)
#:inline-xexpr-proc procedure? #:string-proc (string? . -> . string?)
#:string-proc procedure? #:symbol-proc (symbol? . -> . symbol?)
#:symbol-proc procedure? #:valid-char-proc (valid-char? . -> . valid-char?)
#:valid-char-proc procedure? #:cdata-proc (cdata? . -> . cdata?)
#:cdata-proc procedure?) . ->* . txexpr?) #:exclude-tags (listof symbol?) ) . ->* . txexpr?)
(let loop ([x txexpr]) (let loop ([x txexpr])
(cond (cond
[(txexpr? x) (let-values([(tag attrs elements) (txexpr->values x)]) [(txexpr? x) (let-values([(tag attrs elements) (txexpr->values x)])
(if (member tag excluded-xexpr-tags) (if (member tag excluded-tags)
x ; because it's excluded x ; because it's excluded
;; we apply processing here rather than do recursive descent on the pieces ;; we apply processing here rather than do recursive descent on the pieces
;; because if we send them back through loop, certain element types are ambiguous ;; because if we send them back through loop, certain element types are ambiguous
;; e.g., ((p "foo")) tests out as both txexpr-attrs and txexpr-elements ;; e.g., ((p "foo")) tests out as both txexpr-attrs and txexpr-elements
(let ([decoded-xexpr (let ([decoded-txexpr
(apply make-txexpr (list (xexpr-tag-proc tag) (apply make-txexpr (list (txexpr-tag-proc tag)
(xexpr-attrs-proc attrs) (txexpr-attrs-proc attrs)
(map loop (xexpr-elements-proc elements))))]) (map loop (txexpr-elements-proc elements))))])
((if (block-xexpr? decoded-xexpr) ((if (block-txexpr? decoded-txexpr)
block-xexpr-proc block-txexpr-proc
inline-xexpr-proc) decoded-xexpr))))] inline-txexpr-proc) decoded-txexpr))))]
[(string? x) (string-proc x)] [(string? x) (string-proc x)]
[(symbol? x) (symbol-proc x)] [(symbol? x) (symbol-proc x)]
[(valid-char? x) (valid-char-proc x)] [(valid-char? x) (valid-char-proc x)]
[(cdata? x) (cdata-proc x)] [(cdata? x) (cdata-proc x)]
[else (error "decode: can't decode" x)]))) [else (error "decode: can't decode" x)])))

18
decode/block.rkt
Unescape Escape View File

@ -0,0 +1,18 @@
#lang racket/base
(require (prefix-in html: css-tools/html) sugar/define txexpr)
;; initial set of block tags: from html
(define+provide project-block-tags
(make-parameter html:block-tags))
;; tags are inline unless they're registered as block tags.
(define+provide/contract (block-txexpr? x)
(any/c . -> . boolean?)
(and (txexpr? x) (member (get-tag x) (project-block-tags)) #t))
(define+provide/contract (register-block-tag tag)
(txexpr-tag? . -> . void?)
(project-block-tags (cons tag (project-block-tags))))

8
decode/typography.rkt
Unescape Escape View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require racket/match) (require racket/match)
(require "../tools.rkt" "../predicates.rkt" sugar txexpr) (require "../tools.rkt" "block.rkt" sugar txexpr)
(provide (contract-out (provide (contract-out
@ -12,7 +12,7 @@
[paragraph-break? ((any/c) (#:pattern pregexp?) . ->* . boolean?)] [paragraph-break? ((any/c) (#:pattern pregexp?) . ->* . boolean?)]
[merge-newlines (list? . -> . list?)] [merge-newlines (list? . -> . list?)]
[prep-paragraph-flow (txexpr-elements? . -> . txexpr-elements?)] [prep-paragraph-flow (txexpr-elements? . -> . txexpr-elements?)]
[wrap-paragraph ((txexpr-elements?) (#:tag symbol?) . ->* . block-xexpr?)] [wrap-paragraph ((txexpr-elements?) (#:tag symbol?) . ->* . block-txexpr?)]
[detect-paragraphs (txexpr-elements? . -> . txexpr-elements?)])) [detect-paragraphs (txexpr-elements? . -> . txexpr-elements?)]))
;; This module is a library of functions to be used in building pollen decoders. ;; This module is a library of functions to be used in building pollen decoders.
@ -140,7 +140,7 @@
(define (convert-linebreaks xc #:newline [newline "\n"]) (define (convert-linebreaks xc #:newline [newline "\n"])
;; 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-txexpr? i))))
(filter-not empty? (filter-not empty?
(for/list ([i (len xc)]) (for/list ([i (len xc)])
(let ([item (get xc i)]) (let ([item (get xc i)])
@ -220,7 +220,7 @@
(define (wrap-paragraph xc #:tag [tag 'p]) (define (wrap-paragraph xc #:tag [tag 'p])
(match xc (match xc
[(list (? block-xexpr? bx)) bx] ; leave a single block xexpr alone [(list (? block-txexpr? bx)) bx] ; leave a single block xexpr alone
[else (make-txexpr tag empty xc)])) ; otherwise wrap in p tag [else (make-txexpr tag empty xc)])) ; otherwise wrap in p tag

21
predicates.rkt
Unescape Escape View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require racket/contract racket/match racket/set) (require racket/contract racket/match racket/set)
(require css-tools/html sugar txexpr) (require sugar txexpr)
(require "world.rkt" "file-tools.rkt" "debug.rkt") (require "world.rkt" "file-tools.rkt" "debug.rkt")
(provide (all-from-out "file-tools.rkt")) (provide (all-from-out "file-tools.rkt"))
@ -12,22 +12,3 @@
[`(meta ,(? string? key) ,(? string? value)) #t] [`(meta ,(? string? key) ,(? string? value)) #t]
[else #f])) [else #f]))
;; initial set of block tags: from html
(define project-block-tags block-tags)
(define+provide/contract (append-block-tag tag)
(txexpr-tag? . -> . void?)
(set! project-block-tags (cons tag project-block-tags)))
;; is the txexpr a block element (as opposed to inline)
;; tags are inline unless they're registered as block tags.
(define+provide/contract (block-xexpr? x)
(any/c . -> . boolean?)
;; (car x) = shorthand for tag of xexpr
((txexpr? x) . and . ((car x) . in? . project-block-tags)))

Write Preview
Loading…
Cancel
Save