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

update to work with revised txexpr module

Browse Source
pull/9/head
Matthew Butterick 11 years ago
parent 4e356b3d04
commit 40f0a70965
10 changed files with 68 additions and 66 deletions
Show Stats Download Patch File Download Diff File

46
decode.rkt
Unescape Escape View File

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
(require racket/contract racket/list racket/string racket/match) (require racket/contract racket/list racket/string racket/match)
(require (only-in xml xexpr/c)) (require (only-in xml xexpr/c))
(require "tools.rkt" "predicates.rkt" sugar tagged-xexpr) (require "tools.rkt" "predicates.rkt" sugar txexpr)
(module+ test (require rackunit)) (module+ test (require rackunit))
@ -39,25 +39,25 @@
#:block-xexpr-proc procedure? #:block-xexpr-proc procedure?
#:inline-xexpr-proc procedure? #:inline-xexpr-proc procedure?
#:string-proc procedure?) #:string-proc procedure?)
. ->* . tagged-xexpr?) . ->* . txexpr?)
(when (not (tagged-xexpr? nx)) (when (not (txexpr? nx))
(error (format "decode: ~v not a full tagged-xexpr" nx))) (error (format "decode: ~v not a full txexpr" nx)))
(define (&decode x) (define (&decode x)
(cond (cond
[(tagged-xexpr? x) (let-values([(tag attr elements) (tagged-xexpr->values x)]) [(txexpr? x) (let-values([(tag attr elements) (txexpr->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-txexpr
(map &decode (list tag attr elements)))]) (map &decode (list tag attr elements)))])
((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))))]
[(tagged-xexpr-tag? x) (xexpr-tag-proc x)] [(txexpr-tag? x) (xexpr-tag-proc x)]
[(tagged-xexpr-attrs? x) (xexpr-attrs-proc x)] [(txexpr-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
[(tagged-xexpr-elements? x) (map &decode (xexpr-elements-proc x))] [(txexpr-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)]))
@ -118,7 +118,7 @@
(define/contract (nonbreaking-last-space x (define/contract (nonbreaking-last-space x
#:nbsp [nbsp (->string #\u00A0)] #:nbsp [nbsp (->string #\u00A0)]
#:minimum-word-length [minimum-word-length 6]) #:minimum-word-length [minimum-word-length 6])
((tagged-xexpr?) (#:nbsp string? #:minimum-word-length integer?) . ->* . tagged-xexpr?) ((txexpr?) (#:nbsp string? #:minimum-word-length integer?) . ->* . txexpr?)
;; todo: parameterize this, as it will be different for each project ;; todo: parameterize this, as it will be different for each project
(define tags-to-pay-attention-to '(p aside)) ; only apply to paragraphs (define tags-to-pay-attention-to '(p aside)) ; only apply to paragraphs
@ -139,11 +139,11 @@
(define (find-last-word-space x) ; recursively traverse xexpr (define (find-last-word-space x) ; recursively traverse xexpr
(cond (cond
[(string? x) (replace-last-space x)] [(string? x) (replace-last-space x)]
[(tagged-xexpr? x) [(txexpr? x)
(let-values([(tag attr elements) (tagged-xexpr->values x)]) (let-values([(tag attr elements) (txexpr->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-txexpr tag attr `(,@all-but-last ,(find-last-word-space (car last)))))
x))] x))]
[else x])) [else x]))
@ -167,10 +167,10 @@
(define/contract (wrap-hanging-quotes nx (define/contract (wrap-hanging-quotes nx
#:single-prepend [single-pp '(squo)] #:single-prepend [single-pp '(squo)]
#:double-prepend [double-pp '(dquo)]) #:double-prepend [double-pp '(dquo)])
((tagged-xexpr?) (#:single-prepend list? #:double-prepend list?) . ->* . tagged-xexpr?) ((txexpr?) (#:single-prepend list? #:double-prepend list?) . ->* . txexpr?)
(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) (tagged-xexpr->values nx)) (define-values (tag attr elements) (txexpr->values nx))
(make-tagged-xexpr tag attr (make-txexpr 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)
[(? two-or-more-char-string? tcs) [(? two-or-more-char-string? tcs)
@ -184,7 +184,7 @@
[(str-first . in? . '("\'" "‘")) [(str-first . in? . '("\'" "‘"))
`(,@single-pp ,(->string #\‘) ,str-rest)] `(,@single-pp ,(->string #\‘) ,str-rest)]
[else tcs])] [else tcs])]
[(? tagged-xexpr? nx) (wrap-hanging-quotes nx)] [(? txexpr? nx) (wrap-hanging-quotes nx)]
[else (car elements)])]) [else (car elements)])])
(cons new-car-elements (cdr elements))) (cons new-car-elements (cdr elements)))
elements))) elements)))
@ -196,7 +196,7 @@
(check-equal? (wrap-hanging-quotes '(p "'Hi' there")) '(p (squo "‘" "Hi' there"))) (check-equal? (wrap-hanging-quotes '(p "'Hi' there")) '(p (squo "‘" "Hi' there")))
(check-equal? (wrap-hanging-quotes '(p "'Hi' there") #:single-prepend '(foo ((bar "ino")))) (check-equal? (wrap-hanging-quotes '(p "'Hi' there") #:single-prepend '(foo ((bar "ino"))))
'(p (foo ((bar "ino")) "‘" "Hi' there"))) '(p (foo ((bar "ino")) "‘" "Hi' there")))
;; make sure tagged-xexpr without elements passes through unscathed ;; make sure txexpr without elements passes through unscathed
(check-equal? (wrap-hanging-quotes '(div ((style "height:2em")))) '(div ((style "height:2em"))))) (check-equal? (wrap-hanging-quotes '(div ((style "height:2em")))) '(div ((style "height:2em")))))
@ -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"])
((tagged-xexpr-elements?) (#:newline string?) . ->* . tagged-xexpr-elements?) ((txexpr-elements?) (#:newline string?) . ->* . txexpr-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)
(tagged-xexpr-elements? . -> . tagged-xexpr-elements?) (txexpr-elements? . -> . txexpr-elements?)
(convert-linebreaks (merge-newlines (trim xc whitespace?)))) (convert-linebreaks (merge-newlines (trim xc whitespace?))))
(module+ test (module+ test
@ -301,10 +301,10 @@
;; apply paragraph tag ;; apply paragraph tag
(define/contract (wrap-paragraph xc #:tag [tag 'p]) (define/contract (wrap-paragraph xc #:tag [tag 'p])
((tagged-xexpr-elements?) (#:tag symbol?) . ->* . block-xexpr?) ((txexpr-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-txexpr tag empty xc)])) ; otherwise wrap in p tag
(module+ test (module+ test
(check-equal? (wrap-paragraph '("foo" "bar")) '(p "foo" "bar")) (check-equal? (wrap-paragraph '("foo" "bar")) '(p "foo" "bar"))
@ -317,7 +317,7 @@
;; detect paragraphs ;; detect paragraphs
;; todo: unit tests ;; todo: unit tests
(define/contract (detect-paragraphs elements) (define/contract (detect-paragraphs elements)
(tagged-xexpr-elements? . -> . tagged-xexpr-elements?) (txexpr-elements? . -> . txexpr-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 ¶¶

1
info.rkt
Unescape Escape View File

@ -1,3 +1,4 @@
#lang info #lang info
(define collection "pollen") (define collection "pollen")
(define scribblings '(("scribblings/pollen.scrbl" ()))) (define scribblings '(("scribblings/pollen.scrbl" ())))
(define deps '("txexpr" "sugar"))

4
main-imports.rkt
Unescape Escape View File

@ -8,7 +8,7 @@
pollen/tools pollen/tools
pollen/main-helper pollen/main-helper
pollen/top pollen/top
tagged-xexpr txexpr
sugar sugar
(only-in pollen/ptree ptree-source-decode path->pnode ptree?)) (only-in pollen/ptree ptree-source-decode path->pnode ptree?))
@ -16,6 +16,6 @@
pollen/tools pollen/tools
pollen/main-helper pollen/main-helper
pollen/top pollen/top
tagged-xexpr txexpr
sugar sugar
pollen/ptree)) pollen/ptree))

12
main.rkt
Unescape Escape View File

@ -26,7 +26,7 @@
;; and why doesn't this work: ;; and why doesn't this work:
;; (require pollen/main-imports) ;; (require pollen/main-imports)
;; (provide (all-from-out pollen/main-imports)) ;; (provide (all-from-out pollen/main-imports))
(require pollen/tools pollen/main-helper pollen/top pollen/ptree sugar tagged-xexpr) (require pollen/tools pollen/main-helper pollen/top pollen/ptree sugar txexpr)
(require-and-provide-extras) ; brings in the project require files (require-and-provide-extras) ; brings in the project require files
expr ... ; body of module expr ... ; body of module
@ -50,14 +50,14 @@
;; doc is probably a list, but might be a single string ;; doc is probably a list, but might be a single string
[(string? doc) (list doc)] [(string? doc) (list doc)]
;; if it's a single nx, just leave it ;; if it's a single nx, just leave it
[(tagged-xexpr? doc) (list doc)] [(txexpr? doc) (list doc)]
;; if it's nx content, splice it in ;; if it's nx content, splice it in
[(list? doc) doc])))) [(list? doc) doc]))))
;; split out the metas now (in raw form) ;; split out the metas now (in raw form)
(define-values (metas-raw main-raw) (define-values (metas-raw main-raw)
((bound/c split-tag-from-xexpr) 'meta (make-tagged-xexpr 'irrelevant-tag empty all-elements))) ((bound/c split-tag-from-xexpr) 'meta (make-txexpr 'irrelevant-tag empty all-elements)))
(define metas (make-meta-hash metas-raw)) (define metas (make-meta-hash metas-raw))
@ -80,8 +80,8 @@
;; ... but other files, including pollen, will go this way. ;; ... but other files, including pollen, will go this way.
;; Root is treated as a function. ;; Root is treated as a function.
;; If it's not defined elsewhere, ;; If it's not defined elsewhere,
;; it just hits #%top and becomes a tagged-xexpr. ;; it just hits #%top and becomes a txexpr.
root) ((bound/c tagged-xexpr-elements) main-raw))) root) ((bound/c get-elements) main-raw)))
(provide main metas here (provide main metas here
@ -97,7 +97,7 @@
(if here-is-ptree? (if here-is-ptree?
(displayln (format "(ptree? main) ~a" (ptree? main))) (displayln (format "(ptree? main) ~a" (ptree? main)))
(displayln (format "(tagged-xexpr? main) ~a" (tagged-xexpr? main)))) (displayln (format "(txexpr? main) ~a" (txexpr? main))))
(displayln "") (displayln "")
(displayln ";-------------------------") (displayln ";-------------------------")
(displayln "; pollen 'metas") (displayln "; pollen 'metas")

8
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 tagged-xexpr) (require css-tools/html 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"))
@ -16,15 +16,15 @@
(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)
(tagged-xexpr-tag? . -> . void?) (txexpr-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 txexpr a block element (as opposed to inline)
;; tags are inline unless they're registered as block tags. ;; tags are inline unless they're registered as block tags.
(define+provide/contract (block-xexpr? x) (define+provide/contract (block-xexpr? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
;; (car x) = shorthand for tag of xexpr ;; (car x) = shorthand for tag of xexpr
((tagged-xexpr? x) . and . ((car x) . in? . project-block-tags))) ((txexpr? x) . and . ((car x) . in? . project-block-tags)))
;; recursive whitespace test ;; recursive whitespace test

6
ptree.rkt
Unescape Escape View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require racket/contract racket/match racket/path xml/path racket/bool racket/rerequire) (require racket/contract racket/match racket/path xml/path racket/bool racket/rerequire)
(require "tools.rkt" "world.rkt" "debug.rkt" "decode.rkt" sugar tagged-xexpr) (require "tools.rkt" "world.rkt" "debug.rkt" "decode.rkt" sugar txexpr)
(module+ test (require rackunit)) (module+ test (require rackunit))
@ -28,7 +28,7 @@
(define/contract (ptree? x) (define/contract (ptree? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
(and (tagged-xexpr? x) (andmap (λ(i) (or (pnode? i) (ptree? i))) x))) (and (txexpr? x) (andmap (λ(i) (or (pnode? i) (ptree? i))) x)))
(module+ test (module+ test
(check-true (ptree? '(foo))) (check-true (ptree? '(foo)))
@ -207,7 +207,7 @@
;; this sets default input for following functions ;; this sets default input for following functions
(define/contract (ptree-root->ptree tx) (define/contract (ptree-root->ptree tx)
;; (not/c ptree) prevents ptrees from being accepted as input ;; (not/c ptree) prevents ptrees from being accepted as input
((and/c tagged-xexpr?) . -> . ptree?) ((and/c txexpr?) . -> . ptree?)
tx) tx)

8
server-routes.rkt
Unescape Escape View File

@ -5,7 +5,7 @@
(require web-server/http/request-structs) (require web-server/http/request-structs)
(require web-server/http/response-structs) (require web-server/http/response-structs)
(require 2htdp/image) (require 2htdp/image)
(require "world.rkt" "render.rkt" sugar tagged-xexpr "predicates.rkt" "debug.rkt" "ptree.rkt") (require "world.rkt" "render.rkt" sugar txexpr "predicates.rkt" "debug.rkt" "ptree.rkt")
(module+ test (require rackunit)) (module+ test (require rackunit))
@ -54,7 +54,7 @@
;; extract main xexpr from a path ;; extract main xexpr from a path
(define/contract (file->xexpr path #:render [wants-render #t]) (define/contract (file->xexpr path #:render [wants-render #t])
((complete-path?) (#:render boolean?) . ->* . tagged-xexpr?) ((complete-path?) (#:render boolean?) . ->* . txexpr?)
(when wants-render (render path)) (when wants-render (render path))
(dynamic-rerequire path) ; stores module mod date; reloads if it's changed (dynamic-rerequire path) ; stores module mod date; reloads if it's changed
(dynamic-require path 'main)) (dynamic-require path 'main))
@ -74,11 +74,11 @@
(check-equal? (slurp (build-path (current-directory) "tests/server-routes/bar.html") #:render #f) "<html><body><p>bar</p></body></html>")) (check-equal? (slurp (build-path (current-directory) "tests/server-routes/bar.html") #:render #f) "<html><body><p>bar</p></body></html>"))
;; add a wrapper to tagged-xexpr that displays it as monospaced text ;; add a wrapper to txexpr that displays it as monospaced text
;; for "view source"ish functions ;; for "view source"ish functions
;; takes either a string or an xexpr ;; takes either a string or an xexpr
(define/contract (format-as-code x) (define/contract (format-as-code x)
(xexpr? . -> . tagged-xexpr?) (xexpr? . -> . txexpr?)
(body-wrapper `(tt ,x))) (body-wrapper `(tt ,x)))

29
template.rkt
Unescape Escape View File

@ -1,11 +1,12 @@
#lang racket/base #lang racket/base
(require racket/contract racket/string xml xml/path) (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 txexpr)
;; setup for test cases ;; setup for test cases
(module+ test (require rackunit racket/path)) (module+ test (require rackunit racket/path))
(provide (all-defined-out)) (provide (all-defined-out))
(require sugar/scribble sugar/coerce)
(provide (all-from-out sugar/scribble sugar/coerce)) (provide (all-from-out sugar/scribble sugar/coerce))
;; todo: better fallback template ;; todo: better fallback template
@ -16,7 +17,7 @@
(define/contract (puttable-item? x) (define/contract (puttable-item? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
(or (tagged-xexpr? x) (or (txexpr? x)
(has-decoder-source? x) (has-decoder-source? x)
(and (pnode? x) (pnode->url x) (has-decoder-source? (pnode->url x))))) (and (pnode? x) (pnode->url x) (has-decoder-source? (pnode->url x)))))
@ -29,10 +30,10 @@
(or (string? x) (symbol? x))) (or (string? x) (symbol? x)))
(define/contract (put x) (define/contract (put x)
(puttable-item? . -> . tagged-xexpr?) (puttable-item? . -> . txexpr?)
(cond (cond
;; Using put has no effect on tagged-xexprs. It's here to make the idiom smooth. ;; Using put has no effect on txexprs. It's here to make the idiom smooth.
[(tagged-xexpr? x) x] [(txexpr? x) x]
[(has-decoder-source? x) (dynamic-require (->decoder-source-path x) 'main)] [(has-decoder-source? x) (dynamic-require (->decoder-source-path x) 'main)]
[(has-decoder-source? (pnode->url x)) (dynamic-require (->decoder-source-path (pnode->url x)) 'main)])) [(has-decoder-source? (pnode->url x)) (dynamic-require (->decoder-source-path (pnode->url x)) 'main)]))
@ -44,7 +45,7 @@
(define/contract (find query px) (define/contract (find query px)
(query-key? (or/c #f puttable-item?) . -> . (or/c #f tagged-xexpr-element?)) (query-key? (or/c #f puttable-item?) . -> . (or/c #f txexpr-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 +59,7 @@
|# |#
(define/contract (find-in-metas px key) (define/contract (find-in-metas px key)
(puttable-item? query-key? . -> . (or/c #f tagged-xexpr-elements?)) (puttable-item? query-key? . -> . (or/c #f txexpr-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 +75,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 #f tagged-xexpr-elements?)) . -> . (or/c #f txexpr-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))]
@ -90,15 +91,15 @@
|# |#
;; turns input into xexpr-elements so they can be spliced into template ;; turns input into xexpr-elements so they can be spliced into template
;; (as opposed to dropped in as a full tagged-xexpr) ;; (as opposed to dropped in as a full txexpr)
;; by returning a list, pollen rules will automatically merge into main flow ;; by returning a list, pollen rules will automatically merge into main flow
;; 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? tagged-xexpr-elements? string?) . -> . tagged-xexpr-elements?) ((or/c txexpr? txexpr-elements? string?) . -> . txexpr-elements?)
(cond (cond
[(tagged-xexpr? x) (tagged-xexpr-elements x)] [(txexpr? x) (get-elements x)]
[(tagged-xexpr-elements? x) x] [(txexpr-elements? x) x]
[(string? x) (->list x)])) [(string? x) (->list x)]))
(module+ test (module+ test
@ -108,9 +109,9 @@
(define/contract (make-html x) (define/contract (make-html x)
((or/c tagged-xexpr? tagged-xexpr-elements? tagged-xexpr-element?) . -> . string?) ((or/c txexpr? txexpr-elements? txexpr-element?) . -> . string?)
(cond (cond
[(tagged-xexpr? x) (xexpr->string x)] [(txexpr? x) (xexpr->string x)]
[else (let ([x (->list x)]) [else (let ([x (->list x)])
(string-join (map xexpr->string x) ""))])) (string-join (map xexpr->string x) ""))]))

16
tools.rkt
Unescape Escape View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require racket/contract racket/list) (require racket/contract racket/list)
(require tagged-xexpr sugar "debug.rkt" "predicates.rkt" "world.rkt") (require txexpr sugar "debug.rkt" "predicates.rkt" "world.rkt")
(provide (all-from-out "debug.rkt" "predicates.rkt" racket/list)) (provide (all-from-out "debug.rkt" "predicates.rkt" racket/list))
;; setup for test cases ;; setup for test cases
@ -21,7 +21,7 @@
;; later metas with the same name will override earlier ones. ;; later metas with the same name will override earlier ones.
(define+provide/contract (make-meta-hash mxs) (define+provide/contract (make-meta-hash mxs)
((listof meta-xexpr?) . -> . hash?) ((listof meta-xexpr?) . -> . hash?)
(apply hash (append-map tagged-xexpr-elements mxs))) (apply hash (append-map get-elements mxs)))
(module+ test (module+ test
(check-equal? (make-meta-hash '((meta "foo" "bar")(meta "hee" "haw"))) (check-equal? (make-meta-hash '((meta "foo" "bar")(meta "hee" "haw")))
@ -31,20 +31,20 @@
;; function to split tag out of tagged-xexpr ;; function to split tag out of txexpr
(define+provide/contract (split-tag-from-xexpr tag tx) (define+provide/contract (split-tag-from-xexpr tag tx)
(xexpr-tag? tagged-xexpr? . -> . (values (listof xexpr-element?) tagged-xexpr? )) (txexpr-tag? txexpr? . -> . (values (listof txexpr-element?) txexpr? ))
(define matches '()) (define matches '())
(define (extract-tag x) (define (extract-tag x)
(cond (cond
[(and (tagged-xexpr? x) (equal? tag (car x))) [(and (txexpr? x) (equal? tag (car x)))
; stash matched tag but return empty value ; stash matched tag but return empty value
(begin (begin
(set! matches (cons x matches)) (set! matches (cons x matches))
empty)] empty)]
[(tagged-xexpr? x) (let-values([(tag attr body) (tagged-xexpr->values x)]) [(txexpr? x) (let-values([(tag attr body) (txexpr->values x)])
(make-tagged-xexpr tag attr (extract-tag body)))] (make-txexpr tag attr (extract-tag body)))]
[(xexpr-elements? x) (filter-not empty? (map extract-tag x))] [(txexpr-elements? x) (filter-not empty? (map extract-tag x))]
[else x])) [else x]))
(define tx-extracted (extract-tag tx)) ;; do this first to fill matches (define tx-extracted (extract-tag tx)) ;; do this first to fill matches
(values (reverse matches) tx-extracted)) (values (reverse matches) tx-extracted))

2
top.rkt
Unescape Escape View File

@ -2,7 +2,7 @@
;; Changes the default behavior of #%top. ;; Changes the default behavior of #%top.
;; Unbound identifiers are allowed, and treated as the ;; Unbound identifiers are allowed, and treated as the
;; tag in a tagged-xexpr (with the rest of the expression treated as the body) ;; tag in a txexpr (with the rest of the expression treated as the body)
;; To suppress this behavior, use bound/c to wrap any name. ;; To suppress this behavior, use bound/c to wrap any name.
;; If that name isn't already defined, you'll get the usual syntax error. ;; If that name isn't already defined, you'll get the usual syntax error.

Write Preview
Loading…
Cancel
Save