in progress ...

pull/9/head
Matthew Butterick 10 years ago
parent 50ca995c42
commit 218bf29a5c

@ -5,8 +5,8 @@
(require (for-syntax sugar "world.rkt"))
(define-syntax (handle-pollen-command syntax-context)
(datum->syntax syntax-context
(define-syntax (handle-pollen-command stx)
(datum->syntax stx
(let* ([args (current-command-line-arguments)]
[arg (if (> (len args) 0) (get args 0) "")])
(display (format "~a: " COMMAND_FILE))
@ -65,3 +65,4 @@ polcom [filename] (renders individual file)")]
`(displayln (format "No command defined for '~a'" ,arg))))]))))
(handle-pollen-command)

@ -1,8 +1,8 @@
#lang racket/base
(require racket/date racket/string)
(require sugar/debug)
(require sugar/debug sugar/define)
(provide message make-datestamp make-timestamp display-stack-trace (all-from-out sugar/debug))
(provide (all-from-out sugar/debug))
; todo: contracts, tests, docs
@ -25,7 +25,7 @@
str
(string-append (make-string (- count (string-length str)) #\0) str)))
(define (make-datestamp)
(define+provide (make-datestamp)
(define date (current-date))
(define date-fields (map (λ(x) (zero-fill x 2))
(list
@ -35,7 +35,7 @@
)))
(string-join date-fields "-"))
(define (make-timestamp)
(define+provide (make-timestamp)
(define date (current-date))
(define time-fields (map (λ(x) (zero-fill x 2))
(list
@ -57,14 +57,12 @@
;; todo: consolidate these two message functions
(define (basic-message . items)
(define+provide (basic-message . items)
(displayln (string-join `(,@(map (λ(x)(if (string? x) x (format "~v" x))) items))) (current-error-port)))
(define (message . items)
(define+provide (message . items)
(displayln (string-join `(,(make-debug-timestamp) ,@(map (λ(x)(if (string? x) x (format "~v" x))) items))) (current-error-port)))
(define (exn+stack->string exn)
(string-append
(string-append "Exception: " (exn-message exn))

@ -1,31 +1,17 @@
#lang racket/base
(require racket/contract racket/list racket/string racket/match)
(require (only-in xml xexpr/c))
(require "tools.rkt" "predicates.rkt")
(require "tools.rkt" "predicates.rkt" sugar tagged-xexpr)
(module+ test (require rackunit))
(provide (except-out (all-defined-out) decode register-block-tag))
(provide (contract-out
[decode ((xexpr/c) ;; use xexpr/c for contract on nx because it gives better error messages
;; todo: how to write more specific contracts for these procedures?
;; e.g., string-proc should be restricted to procs that accept a string as input
;; and return a string as output
(#:exclude-xexpr-tags list?
#:xexpr-tag-proc procedure?
#:xexpr-attr-proc procedure?
#:xexpr-elements-proc procedure?
#:block-xexpr-proc procedure?
#:inline-xexpr-proc procedure?
#:string-proc procedure?)
. ->* . tagged-xexpr?)]
[register-block-tag (symbol? . -> . void?)]))
;; add a block tag to the list
;; this function is among the predicates because it alters a predicate globally.
(define (register-block-tag tag)
(define+provide/contract (register-block-tag tag)
(symbol? . -> . void?)
(append-block-tag tag))
(module+ test
@ -33,7 +19,7 @@
;; decoder wireframe
(define (decode nx
(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)]
@ -41,7 +27,19 @@
#:block-xexpr-proc [block-xexpr-proc (λ(x)x)]
#:inline-xexpr-proc [inline-xexpr-proc (λ(x)x)]
#:string-proc [string-proc (λ(x)x)])
((xexpr/c) ;; use xexpr/c for contract on nx because it gives better error messages
;; todo: how to write more specific contracts for these procedures?
;; e.g., string-proc should be restricted to procs that accept a string as input
;; and return a string as output
(#:exclude-xexpr-tags list?
#:xexpr-tag-proc procedure?
#:xexpr-attr-proc procedure?
#:xexpr-elements-proc procedure?
#:block-xexpr-proc procedure?
#:inline-xexpr-proc procedure?
#:string-proc procedure?)
. ->* . tagged-xexpr?)
(when (not (tagged-xexpr? nx))
(error (format "decode: ~v not a full tagged-xexpr" nx)))

@ -3,8 +3,6 @@
(require (only-in racket/path filename-extension))
(require "world.rkt" sugar)
(module+ test (require rackunit))
;; for files like svg that are not source in pollen terms,
;; but have a textual representation separate from their display.
(define+provide/contract (sourceish? x)

@ -1,5 +1,5 @@
#lang racket/base
(require (for-syntax racket/base pollen/tools))
(require (for-syntax racket/base pollen/tools sugar))
(require racket/contract/region)
@ -54,7 +54,7 @@
;; so raises possibility of inconsistent values.
;; Whereas the complete path is unambiguous,
;; and can be made relative by the caller (or otherwise altered).
(->string hp)))))
((bound/c ->string) hp)))))
; Second step: apply a separate syntax transform to the identifier itself

@ -8,10 +8,14 @@
pollen/tools
pollen/main-helper
pollen/top
tagged-xexpr
sugar
(only-in pollen/ptree ptree-source-decode path->pnode ptree?))
(provide (all-from-out racket/list
pollen/tools
pollen/main-helper
pollen/top
tagged-xexpr
sugar
pollen/ptree))

@ -5,12 +5,10 @@
;; and cached for the benefit of the render eval function.
(require pollen/top
(only-in sugar ->list)
(only-in pollen/tools trim)
(only-in sugar ->list ->string trim)
(only-in pollen/predicates whitespace?))
(provide (all-from-out
pollen/top
sugar
pollen/tools
pollen/predicates))

@ -1,6 +1,6 @@
#lang racket/base
(require "main-preproc-imports.rkt" sugar)
(require "main-preproc-imports.rkt")
(provide (except-out (all-from-out racket/base) #%module-begin)
(rename-out [module-begin #%module-begin]))

@ -26,7 +26,7 @@
;; and why doesn't this work:
;; (require pollen/main-imports)
;; (provide (all-from-out pollen/main-imports))
(require pollen/tools pollen/main-helper pollen/top pollen/ptree)
(require pollen/tools pollen/main-helper pollen/top pollen/ptree sugar tagged-xexpr)
(require-and-provide-extras) ; brings in the project require files
expr ... ; body of module
@ -57,7 +57,7 @@
;; split out the metas now (in raw form)
(define-values (metas-raw main-raw)
(split-tag-from-xexpr 'meta (make-tagged-xexpr 'irrelevant-tag empty all-elements)))
((bound/c split-tag-from-xexpr) 'meta (make-tagged-xexpr 'irrelevant-tag empty all-elements)))
(define metas (make-meta-hash metas-raw))
@ -72,7 +72,7 @@
;; Because if it's overridden to something other than *.ptree,
;; ptree processing will fail.
;; This defeats rule that ptree file suffix triggers ptree decoding.
(define here-is-ptree? ((bound/c ptree-source?) (->path inner-here-path)))
(define here-is-ptree? ((bound/c ptree-source?) ((bound/c ->path) inner-here-path)))
(define main (apply (if here-is-ptree?
;; ptree source files will go this way,
@ -81,7 +81,7 @@
;; Root is treated as a function.
;; If it's not defined elsewhere,
;; it just hits #%top and becomes a tagged-xexpr.
root) (tagged-xexpr-elements main-raw)))
root) ((bound/c tagged-xexpr-elements) main-raw)))
(provide main metas here

@ -1,171 +1,34 @@
#lang racket/base
(require racket/contract racket/match racket/list xml racket/set)
(require css-tools/html)
(require "world.rkt" sugar "file-tools.rkt" "debug.rkt")
(module+ test (require rackunit))
(provide (all-defined-out)
(all-from-out "file-tools.rkt"))
;; is it an xexpr tag?
(define/contract (xexpr-tag? x)
(any/c . -> . boolean?)
(symbol? x))
;; is it an xexpr attributes?
(define/contract (xexpr-attr? x)
(any/c . -> . boolean?)
(match x
; list of symbol + string pairs
[(list (list (? symbol? key) (? string? value)) ...) #t]
[else #f]))
(module+ test
(check-true (xexpr-attr? empty))
(check-true (xexpr-attr? '((key "value"))))
(check-true (xexpr-attr? '((key "value") (foo "bar"))))
(check-false (xexpr-attr? '((key "value") "foo" "bar"))) ; content, not attr
(check-false (xexpr-attr? '(key "value"))) ; not a nested list
(check-false (xexpr-attr? '(("key" "value")))) ; two strings
(check-false (xexpr-attr? '((key value))))) ; two symbols
;; is it xexpr content?
(define/contract (xexpr-element? x)
(any/c . -> . boolean?)
(or (string? x) (tagged-xexpr? x)))
;; Not a great idea to use "plural" (i.e. listlike) contracts.
;; Instead of foobars? use (listof foobar?) as contract
;; Reason is that listof will show you the specific element that fails
;; whereas foobars? will just announce the result for the whole list.
;; Since contracts are intended to tell you why your input is defective,
;; the (listof foobar?) behavior is better.
;; outside of contracts, instead of testing (foobars? list),
;; test (andmap foobar? list)
(define/contract (xexpr-elements? x)
(any/c . -> . boolean?)
(match x
;; this is more strict than xexpr definition in xml module
;; don't allow symbols or numbers to be part of content
[(list elem ...) (andmap xexpr-element? elem)]
[else #f]))
(module+ test
(check-true (xexpr-elements? '("p" "foo" "123")))
(check-false (xexpr-elements? "foo")) ; not a list
(check-false (xexpr-elements? '("p" "foo" 123))) ; includes number
(check-false (xexpr-elements? '(p "foo" "123"))) ; includes symbol
(check-false (xexpr-elements? '(((key "value")) "foo" "bar"))) ; includes attr
(check-false (xexpr-elements? '("foo" "bar" ((key "value")))))) ; malformed
;; is it a named x-expression?
;; todo: rewrite this recurively so errors can be pinpointed (for debugging)
(define/contract (tagged-xexpr? x)
(any/c . -> . boolean?)
(and (xexpr? x) ; meets basic xexpr contract
(match x
[(list (? symbol? name) rest ...) ; is a list starting with a symbol
(or (andmap xexpr-element? rest) ; the rest is content or ...
(and (xexpr-attr? (car rest)) (andmap xexpr-element? (cdr rest))))] ; attr + content
[else #f])))
(module+ test
(check-true (tagged-xexpr? '(p "foo" "bar")))
(check-true (tagged-xexpr? '(p ((key "value")) "foo" "bar")))
(check-false (tagged-xexpr? "foo")) ; not a list with symbol
(check-false (tagged-xexpr? '(p "foo" "bar" ((key "value"))))) ; malformed
(check-false (tagged-xexpr? '("p" "foo" "bar"))) ; no name
(check-false (tagged-xexpr? '(p 123)))) ; content is a number
(require racket/contract racket/match racket/set)
(require css-tools/html sugar tagged-xexpr)
(require "world.rkt" "file-tools.rkt" "debug.rkt")
(provide (all-from-out "file-tools.rkt"))
;; test for well-formed meta
(define/contract (meta-xexpr? x)
(define+provide/contract (meta-xexpr? x)
(any/c . -> . boolean?)
(match x
[`(meta ,(? string? key) ,(? string? value)) #t]
[else #f]))
(module+ test
(check-true (meta-xexpr? '(meta "key" "value")))
(check-false (meta-xexpr? '(meta "key" "value" "foo")))
(check-false (meta-xexpr? '(meta))))
;; initial set of block tags: from html
(define project-block-tags block-tags)
(define/contract (append-block-tag tag)
(define+provide/contract (append-block-tag tag)
(xexpr-tag? . -> . void?)
(set! project-block-tags (cons tag project-block-tags)))
;; is the tagged-xexpr a block element (as opposed to inline)
;; tags are inline unless they're registered as block tags.
(define/contract (block-xexpr? x)
(define+provide/contract (block-xexpr? x)
(any/c . -> . boolean?)
;; (car x) = shorthand for tag of xexpr
((tagged-xexpr? x) . and . ((car x) . in? . project-block-tags)))
(module+ test
(check-true (block-xexpr? '(p "foo")))
(check-true (block-xexpr? '(div "foo")))
(check-false (block-xexpr? '(em "foo")))
(check-false (block-xexpr? '(barfoo "foo"))))
;; count incidence of elements in a list
;; returns hash where key is element, value is incidence
;; todo: move this? Ideally it would be in tools,
;; but that would create a circular dependency.
(define/contract (count-incidence x)
(list? . -> . hash?)
(define counter (make-hash))
(for ([item (flatten x)])
(hash-set! counter item (add1 (hash-ref counter item 0))))
counter)
(module+ test
(check-equal? (hash-ref (count-incidence '(a b c d b c)) 'b) 2)
(check-equal? (hash-ref (count-incidence '(a b c d b c)) 'a) 1))
(define/contract (members-unique? x)
(any/c . -> . boolean?)
(cond
[(list? x) (= (len (apply set x)) (len x))]
[(vector? x) (members-unique? (->list x))]
[(string? x) (members-unique? (string->list x))]
[else #t]))
(define/contract (members-unique?/error x)
(any/c . -> . boolean?)
(define result (members-unique? x))
(if (not result)
(let* ([duplicate-keys (filter-not empty? (hash-map (count-incidence x)
(λ(k v) (if (> v 1) k '()))))])
(error (string-append (if (= (len duplicate-keys) 1)
"Item isnt"
"Items arent") " unique:") duplicate-keys))
result))
(module+ test
(check-true (members-unique? '(1 2 3)))
(check-false (members-unique? '(1 2 2)))
(check-true (members-unique? (->vector '(1 2 3))))
(check-false (members-unique? (->vector '(1 2 2))))
(check-true (members-unique? "fob"))
(check-false (members-unique? "foo")))
;; recursive whitespace test
(define/contract (whitespace? x)
(define+provide/contract (whitespace? x)
(any/c . -> . boolean?)
(cond
[(or (vector? x) (list? x) (set? x)) (andmap whitespace? (->list x))]
@ -173,14 +36,6 @@
[(or (symbol? x) (string? x)) (->boolean (regexp-match #px"^\\s+$" (->string x)))]
[else #f]))
(module+ test
(check-true (whitespace? " "))
(check-false (whitespace? "foo"))
(check-false (whitespace? 'foo))
(check-false (whitespace? #\Ø))
(check-false (whitespace? " ")) ; a nonbreaking space. todo: why is this so?
(check-true (whitespace? "\n \n"))
(check-true (whitespace? (list "\n" " " "\n")))
(check-true (whitespace? (list "\n" " " "\n" (list "\n" "\n")))))

@ -1,6 +1,6 @@
#lang racket/base
(require racket/contract racket/match xml/path racket/bool racket/rerequire)
(require "tools.rkt" "world.rkt" "debug.rkt" "decode.rkt")
(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)
(module+ test (require rackunit))
@ -8,7 +8,8 @@
(define/contract (pnode? x)
(any/c . -> . boolean?)
(and (stringish? x) (not (whitespace? (->string x)))))
(try (not (whitespace? (->string x)))
(except [exn:fail? (λ(e) #f)])))
(define/contract (pnode?/error x)
(any/c . -> . boolean?)

@ -1,6 +1,8 @@
#lang racket/base
(require racket/port racket/file racket/rerequire racket/contract)
(require "world.rkt" "tools.rkt" "template.rkt")
(require racket/port racket/file racket/rerequire racket/contract racket/path)
;(require "world.rkt" )
;;todo: why is pollen/top operating in this file?
(module+ test (require rackunit))

@ -5,7 +5,7 @@
(require web-server/http/request-structs)
(require web-server/http/response-structs)
(require 2htdp/image)
(require "world.rkt" "render.rkt" sugar "predicates.rkt" "debug.rkt" "ptree.rkt")
(require "world.rkt" "render.rkt" sugar tagged-xexpr "predicates.rkt" "debug.rkt" "ptree.rkt")
(module+ test (require rackunit))

@ -1,11 +1,12 @@
#lang racket/base
(require racket/contract racket/string xml xml/path racket/bool)
(require "tools.rkt" "ptree.rkt" sugar/scribble)
(require "tools.rkt" "ptree.rkt" sugar/scribble sugar/coerce sugar tagged-xexpr)
;; setup for test cases
(module+ test (require rackunit racket/path))
(provide (all-defined-out))
(provide (all-from-out sugar/scribble sugar/coerce))
;; todo: better fallback template
@ -35,11 +36,11 @@
[(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)]))
(module+ test
#|(module+ test
(check-equal? (put '(foo "bar")) '(foo "bar"))
(check-equal? (put "tests/template/put.pd")
'(root "\n" "\n" (em "One") " paragraph" "\n" "\n" "Another " (em "paragraph") "\n" "\n")))
|#
(define/contract (find query px)
@ -47,12 +48,14 @@
(define result (and px (or (find-in-metas px query) (find-in-main px query))))
(and result (car result))) ;; return false or first element
#|
(module+ test
(parameterize ([current-directory "tests/template"])
(check-false (find "nonexistent-key" "put"))
(check-equal? (find "foo" "put") "bar")
(check-equal? (find "em" "put") "One"))
(check-equal? (find "foo" #f) #f))
|#
(define/contract (find-in-metas px key)
(puttable-item? query-key? . -> . (or/c false? xexpr-elements?))
@ -61,13 +64,13 @@
[key (->string key)])
(and (key . in? . metas ) (->list (get metas key))))))
(module+ test
#|(module+ test
(parameterize ([current-directory "tests/template"])
(check-equal? (find-in-metas "put" "foo") (list "bar"))
(let* ([metas (dynamic-require (->decoder-source-path 'put) 'metas)]
[here (find-in-metas 'put 'here)])
(check-equal? here (list "tests/template/put")))))
|#
(define/contract (find-in-main px query)
(puttable-item? (or/c query-key? (listof query-key?))
@ -79,11 +82,12 @@
;; if results exist, send back xexpr as output
(and (not (empty? results)) results)))
#|
(module+ test
(parameterize ([current-directory "tests/template"])
(check-false (find-in-main "put" "nonexistent-key"))
(check-equal? (find-in-main "put" "em") (list "One" "paragraph"))))
|#
;; turns input into xexpr-elements so they can be spliced into template
;; (as opposed to dropped in as a full tagged-xexpr)

@ -0,0 +1,40 @@
#lang racket/base
(require "../predicates.rkt" racket/list sugar)
(module+ test (require rackunit))
(module+ test
(check-true (meta-xexpr? '(meta "key" "value")))
(check-false (meta-xexpr? '(meta "key" "value" "foo")))
(check-false (meta-xexpr? '(meta))))
(module+ test
(check-true (block-xexpr? '(p "foo")))
(check-true (block-xexpr? '(div "foo")))
(check-false (block-xexpr? '(em "foo")))
(check-false (block-xexpr? '(barfoo "foo"))))
(module+ test
(check-equal? (hash-ref (count-incidence '(a b c d b c)) 'b) 2)
(check-equal? (hash-ref (count-incidence '(a b c d b c)) 'a) 1))
(module+ test
(check-true (members-unique? '(1 2 3)))
(check-false (members-unique? '(1 2 2)))
(check-true (members-unique? (->vector '(1 2 3))))
(check-false (members-unique? (->vector '(1 2 2))))
(check-true (members-unique? "fob"))
(check-false (members-unique? "foo")))
(module+ test
(check-true (whitespace? " "))
(check-false (whitespace? "foo"))
(check-false (whitespace? 'foo))
(check-false (whitespace? #\Ø))
(check-false (whitespace? " ")) ; a nonbreaking space. todo: why is this so?
(check-true (whitespace? "\n \n"))
(check-true (whitespace? (list "\n" " " "\n")))
(check-true (whitespace? (list "\n" " " "\n" (list "\n" "\n")))))

@ -1,19 +1,14 @@
#lang racket/base
(require racket/contract racket/match racket/path)
(require (only-in racket/format ~a))
(require racket/list)
(require (only-in racket/string string-join))
(require (only-in xml xexpr? xexpr/c))
(require sugar "debug.rkt" "predicates.rkt" "world.rkt")
(provide (all-defined-out) (all-from-out sugar "debug.rkt" "predicates.rkt" racket/list racket/path))
(require racket/contract racket/list)
(require tagged-xexpr sugar "debug.rkt" "predicates.rkt" "world.rkt")
(provide (all-from-out "debug.rkt" "predicates.rkt" racket/list))
;; setup for test cases
(module+ test (require rackunit))
;; list of all eligible requires in project require directory
(define/contract (get-project-require-files)
(-> (or/c (listof complete-path?) boolean?))
(define+provide/contract (get-project-require-files)
(-> (or/c #f (listof complete-path?)))
(define extras-directory (build-path PROJECT_ROOT EXTRAS_DIR))
(and (directory-exists? extras-directory)
;; #:build? option returns complete paths (instead of just file names)
@ -21,215 +16,10 @@
(and (not (empty? files)) files))))
;; helper for comparison of values
;; normal function won't work for this. Has to be syntax-rule
(define-syntax-rule (values->list vs)
(call-with-values (λ() vs) list))
;; convert list of alternating keys & values to attr
;; todo: make contract. Which is somewhat complicated:
;; list of items, made of xexpr-attr or even numbers of symbol/string pairs
;; use splitf*-at with xexpr-attr? as test, then check lengths of resulting lists
(define/contract (make-xexpr-attr . items)
(() #:rest (listof (λ(i) (or (xexpr-attr? i) (symbol? i) (string? i)))) . ->* . xexpr-attr?)
;; need this function to make sure that 'foo and "foo" are treated as the same hash key
(define (make-attr-list items)
(if (empty? items)
empty
(let ([key (->symbol (first items))]
[value (->string (second items))]
[rest (drop items 2)])
(append (list key value) (make-attr-list rest)))))
;; use flatten to splice xexpr-attrs into list
;; use hash to ensure keys are unique (later values will overwrite earlier)
(define attr-hash (apply hash (make-attr-list (flatten items))))
`(,@(map (λ(k) (list k (get attr-hash k)))
;; sort needed for predictable results for unit tests
(sort (hash-keys attr-hash) (λ(a b) (string<? (->string a) (->string b)))))))
(module+ test
(check-equal? (make-xexpr-attr 'foo "bar") '((foo "bar")))
(check-equal? (make-xexpr-attr "foo" 'bar) '((foo "bar")))
(check-equal? (make-xexpr-attr "foo" "bar" "goo" "gar") '((foo "bar")(goo "gar")))
(check-equal? (make-xexpr-attr (make-xexpr-attr "foo" "bar" "goo" "gar") "hee" "haw")
'((foo "bar")(goo "gar")(hee "haw")))
(check-equal? (make-xexpr-attr '((foo "bar")(goo "gar")) "foo" "haw") '((foo "haw")(goo "gar"))))
;; create tagged-xexpr from parts (opposite of break-tagged-xexpr)
(define/contract (make-tagged-xexpr name [attr empty] [content empty])
; xexpr/c provides a nicer error message,
; but is not sufficient on its own (too permissive)
((symbol?) (xexpr-attr? (listof xexpr-element?))
. ->* . tagged-xexpr?)
(filter-not empty? `(,name ,attr ,@content)))
(module+ test
(check-equal? (make-tagged-xexpr 'p) '(p))
(check-equal? (make-tagged-xexpr 'p '((key "value"))) '(p ((key "value"))))
(check-equal? (make-tagged-xexpr 'p empty '("foo" "bar")) '(p "foo" "bar"))
(check-equal? (make-tagged-xexpr 'p '((key "value")) (list "foo" "bar"))
'(p ((key "value")) "foo" "bar")))
;; decompose tagged-xexpr into parts (opposite of make-tagged-xexpr)
(define/contract (break-tagged-xexpr nx)
(tagged-xexpr? . -> .
(values symbol? xexpr-attr? (listof xexpr-element?)))
(match
; tagged-xexpr may or may not have attr
; if not, add empty attr so that decomposition only handles one case
(match nx
[(list _ (? xexpr-attr?) _ ...) nx]
[else `(,(car nx) ,empty ,@(cdr nx))])
[(list tag attr content ...) (values tag attr content)]))
(module+ test
(check-equal? (values->list (break-tagged-xexpr '(p)))
(values->list (values 'p empty empty)))
(check-equal? (values->list (break-tagged-xexpr '(p "foo")))
(values->list (values 'p empty '("foo"))))
(check-equal? (values->list (break-tagged-xexpr '(p ((key "value")))))
(values->list (values 'p '((key "value")) empty)))
(check-equal? (values->list (break-tagged-xexpr '(p ((key "value")) "foo")))
(values->list (values 'p '((key "value")) '("foo")))))
;; convenience functions to retrieve only one part of tagged-xexpr
(define (tagged-xexpr-tag nx)
(tagged-xexpr? . -> . xexpr-tag?)
(define-values (tag attr content) (break-tagged-xexpr nx))
tag)
(define (tagged-xexpr-attr nx)
(tagged-xexpr? . -> . xexpr-attr?)
(define-values (tag attr content) (break-tagged-xexpr nx))
attr)
(define (tagged-xexpr-elements nx)
(tagged-xexpr? . -> . (listof xexpr-element?))
(define-values (tag attrt elements) (break-tagged-xexpr nx))
elements)
(module+ test
(check-equal? (tagged-xexpr-tag '(p ((key "value"))"foo" "bar" (em "square"))) 'p)
(check-equal? (tagged-xexpr-attr '(p ((key "value"))"foo" "bar" (em "square"))) '((key "value")))
(check-equal? (tagged-xexpr-elements '(p ((key "value"))"foo" "bar" (em "square")))
'("foo" "bar" (em "square"))))
;; remove all attr blocks (helper function)
(define/contract (remove-attrs x)
(tagged-xexpr? . -> . tagged-xexpr?)
(match x
[(? tagged-xexpr?) (let-values ([(tag attr elements) (break-tagged-xexpr x)])
(make-tagged-xexpr tag empty (remove-attrs elements)))]
[(? list?) (map remove-attrs x)]
[else x]))
(module+ test
(check-equal? (remove-attrs '(p ((foo "bar")) "hi")) '(p "hi"))
(check-equal? (remove-attrs '(p ((foo "bar")) "hi" (p ((foo "bar")) "hi"))) '(p "hi" (p "hi"))))
;; apply filter proc recursively
(define/contract (filter-tree proc tree)
(procedure? list? . -> . list?)
(define (remove-empty x)
(cond
[(list? x) (filter-not empty? (map remove-empty x))]
[else x]))
(define (filter-tree-inner proc x)
(cond
[(list? x) (map (λ(i) (filter-tree-inner proc i)) x)]
[else (if (proc x) x empty)]))
(remove-empty (filter-tree-inner proc tree)))
(module+ test
(check-equal? (filter-tree string? '(p)) empty)
(check-equal? (filter-tree string? '(p "foo" "bar")) '("foo" "bar"))
(check-equal? (filter-tree string? '(p "foo" (p "bar"))) '("foo" ("bar")))
(check-equal? (filter-tree (λ(i) (and (string? i) (equal? i "\n"))) '("\n" (foo "bar") "\n")) '("\n" "\n")))
;; apply filter-not proc recursively
(define/contract (filter-not-tree proc tree)
(procedure? list? . -> . list?)
(filter-tree (λ(i) (not (proc i))) tree))
(module+ test
(check-equal? (filter-not-tree string? '(p)) '(p))
(check-equal? (filter-not-tree string? '(p "foo" "bar")) '(p))
(check-equal? (filter-not-tree string? '(p "foo" (p "bar"))) '(p (p)))
;(check-equal? (filter-tree (λ(i) (and (tagged-xexpr? i) (equal? 'em (car i)))) '(p "foo" (em "bar"))) '(p "foo"))
)
;; todo: doc this function
(define/contract (map-tree proc tree)
(procedure? list? . -> . list?)
(cond
[(list? tree) (map (λ(i) (map-tree proc i)) tree)]
[else (proc tree)]))
(module+ test
(check-equal? (map-tree (λ(i) (if (number? i) (* 2 i) i)) '(p 1 2 3 (em 4 5))) '(p 2 4 6 (em 8 10)))
(check-equal? (map-tree (λ(i) (if (symbol? i) 'foo i)) '(p 1 2 3 (em 4 5))) '(foo 1 2 3 (foo 4 5))))
(define/contract (map-xexpr-elements proc tx)
(procedure? tagged-xexpr? . -> . tagged-xexpr?)
(define-values (tag attr elements) (break-tagged-xexpr tx))
(make-tagged-xexpr tag attr (map proc elements)))
(module+ test
(check-equal? (map-xexpr-elements (λ(x) (if (string? x) "boing" x))
'(p "foo" "bar" (em "square")))
'(p "boing" "boing" (em "square"))))
;; function to split tag out of tagged-xexpr
(define/contract (split-tag-from-xexpr tag tx)
(xexpr-tag? tagged-xexpr? . -> . (values (listof xexpr-element?) tagged-xexpr? ))
(define matches '())
(define (extract-tag x)
(cond
[(and (tagged-xexpr? x) (equal? tag (car x)))
; stash matched tag but return empty value
(begin
(set! matches (cons x matches))
empty)]
[(tagged-xexpr? x) (let-values([(tag attr body) (break-tagged-xexpr x)])
(make-tagged-xexpr tag attr (extract-tag body)))]
[(xexpr-elements? x) (filter-not empty? (map extract-tag x))]
[else x]))
(define tx-extracted (extract-tag tx)) ;; do this first to fill matches
(values (reverse matches) tx-extracted))
(module+ test
(define xx '(root (meta "foo" "bar") "hello" "world" (meta "foo2" "bar2")
(em "goodnight" "moon" (meta "foo3" "bar3"))))
(check-equal? (values->list (split-tag-from-xexpr 'meta xx))
(list '((meta "foo" "bar") (meta "foo2" "bar2") (meta "foo3" "bar3"))
'(root "hello" "world" (em "goodnight" "moon")))))
;; convert list of meta tags to a hash for export from pollen document.
;; every meta is form (meta "key" "value") (enforced by contract)
;; later metas with the same name will override earlier ones.
(define/contract (make-meta-hash mxs)
(define+provide/contract (make-meta-hash mxs)
((listof meta-xexpr?) . -> . hash?)
(apply hash (append-map tagged-xexpr-elements mxs)))

Loading…
Cancel
Save