From c295603914f54adbff94bf9258fcdaa24fae4996 Mon Sep 17 00:00:00 2001 From: Matthew Butterick Date: Fri, 7 Mar 2014 19:26:32 -0800 Subject: [PATCH] decode improvements: contracts on decode arguments, new decode/block module --- decode.rkt | 65 ++++++++++++++++++++++--------------------- decode/block.rkt | 18 ++++++++++++ decode/typography.rkt | 8 +++--- predicates.rkt | 21 +------------- 4 files changed, 57 insertions(+), 55 deletions(-) create mode 100644 decode/block.rkt diff --git a/decode.rkt b/decode.rkt index 32cb726..06fa4d2 100644 --- a/decode.rkt +++ b/decode.rkt @@ -1,6 +1,6 @@ #lang racket/base (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")) @@ -17,56 +17,59 @@ [(char? x) (format "~a" x)] [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 (define+provide/contract (decode txexpr - #:exclude-xexpr-tags [excluded-xexpr-tags '()] - #:xexpr-tag-proc [xexpr-tag-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)] + #:txexpr-tag-proc [txexpr-tag-proc (λ(x)x)] + #:txexpr-attrs-proc [txexpr-attrs-proc (λ(x)x)] + #:txexpr-elements-proc [txexpr-elements-proc (λ(x)x)] + #:block-txexpr-proc [block-txexpr-proc (λ(x)x)] + #:inline-txexpr-proc [inline-txexpr-proc (λ(x)x)] #:string-proc [string-proc (λ(x)x)] #:symbol-proc [symbol-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) - (#:exclude-xexpr-tags list? - #:xexpr-tag-proc procedure? - #:xexpr-attrs-proc procedure? - #:xexpr-elements-proc procedure? - #:block-xexpr-proc procedure? - #:inline-xexpr-proc procedure? - #:string-proc procedure? - #:symbol-proc procedure? - #:valid-char-proc procedure? - #:cdata-proc procedure?) . ->* . txexpr?) + (#:txexpr-tag-proc (txexpr-tag? . -> . txexpr-tag?) + #:txexpr-attrs-proc (txexpr-attrs? . -> . txexpr-attrs?) + #:txexpr-elements-proc (txexpr-elements? . -> . txexpr-elements?) + #:block-txexpr-proc (block-txexpr? . -> . block-txexpr?) + #:inline-txexpr-proc (txexpr? . -> . txexpr?) + #:string-proc (string? . -> . string?) + #:symbol-proc (symbol? . -> . symbol?) + #:valid-char-proc (valid-char? . -> . valid-char?) + #:cdata-proc (cdata? . -> . cdata?) + #:exclude-tags (listof symbol?) ) . ->* . txexpr?) (let loop ([x txexpr]) (cond [(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 ;; 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 ;; e.g., ((p "foo")) tests out as both txexpr-attrs and txexpr-elements - (let ([decoded-xexpr - (apply make-txexpr (list (xexpr-tag-proc tag) - (xexpr-attrs-proc attrs) - (map loop (xexpr-elements-proc elements))))]) - ((if (block-xexpr? decoded-xexpr) - block-xexpr-proc - inline-xexpr-proc) decoded-xexpr))))] + (let ([decoded-txexpr + (apply make-txexpr (list (txexpr-tag-proc tag) + (txexpr-attrs-proc attrs) + (map loop (txexpr-elements-proc elements))))]) + ((if (block-txexpr? decoded-txexpr) + block-txexpr-proc + inline-txexpr-proc) decoded-txexpr))))] [(string? x) (string-proc x)] [(symbol? x) (symbol-proc x)] [(valid-char? x) (valid-char-proc x)] [(cdata? x) (cdata-proc x)] [else (error "decode: can't decode" x)]))) + + + + + + + diff --git a/decode/block.rkt b/decode/block.rkt new file mode 100644 index 0000000..39d5ef8 --- /dev/null +++ b/decode/block.rkt @@ -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)))) diff --git a/decode/typography.rkt b/decode/typography.rkt index ae8341f..928d04f 100644 --- a/decode/typography.rkt +++ b/decode/typography.rkt @@ -1,6 +1,6 @@ #lang racket/base (require racket/match) -(require "../tools.rkt" "../predicates.rkt" sugar txexpr) +(require "../tools.rkt" "block.rkt" sugar txexpr) (provide (contract-out @@ -12,7 +12,7 @@ [paragraph-break? ((any/c) (#:pattern pregexp?) . ->* . boolean?)] [merge-newlines (list? . -> . list?)] [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?)])) ;; 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"]) ;; 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? (for/list ([i (len xc)]) (let ([item (get xc i)]) @@ -220,7 +220,7 @@ (define (wrap-paragraph xc #:tag [tag 'p]) (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 diff --git a/predicates.rkt b/predicates.rkt index 03f2e2c..4a2c8ec 100644 --- a/predicates.rkt +++ b/predicates.rkt @@ -1,6 +1,6 @@ #lang racket/base (require racket/contract racket/match racket/set) -(require css-tools/html sugar txexpr) +(require sugar txexpr) (require "world.rkt" "file-tools.rkt" "debug.rkt") (provide (all-from-out "file-tools.rkt")) @@ -12,22 +12,3 @@ [`(meta ,(? string? key) ,(? string? value)) #t] [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))) - - - - - -