diff --git a/command.rkt b/command.rkt index 2e3b7fe..e9253c4 100644 --- a/command.rkt +++ b/command.rkt @@ -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) + diff --git a/debug.rkt b/debug.rkt index aecca73..7d1520c 100644 --- a/debug.rkt +++ b/debug.rkt @@ -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)) diff --git a/decode.rkt b/decode.rkt index 57ff8ab..4270a90 100644 --- a/decode.rkt +++ b/decode.rkt @@ -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))) diff --git a/file-tools.rkt b/file-tools.rkt index 71fb176..919816b 100644 --- a/file-tools.rkt +++ b/file-tools.rkt @@ -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) diff --git a/main-helper.rkt b/main-helper.rkt index 1c162b4..28f28d1 100644 --- a/main-helper.rkt +++ b/main-helper.rkt @@ -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 diff --git a/main-imports.rkt b/main-imports.rkt index b23a6e6..d364e61 100644 --- a/main-imports.rkt +++ b/main-imports.rkt @@ -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)) \ No newline at end of file diff --git a/main-preproc-imports.rkt b/main-preproc-imports.rkt index 12d7798..014c211 100644 --- a/main-preproc-imports.rkt +++ b/main-preproc-imports.rkt @@ -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)) \ No newline at end of file diff --git a/main-preproc.rkt b/main-preproc.rkt index 7136345..e4eabed 100644 --- a/main-preproc.rkt +++ b/main-preproc.rkt @@ -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])) diff --git a/main.rkt b/main.rkt index 84d4cb6..3aff03d 100644 --- a/main.rkt +++ b/main.rkt @@ -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 diff --git a/predicates.rkt b/predicates.rkt index 8756b7a..ee3ceab 100644 --- a/predicates.rkt +++ b/predicates.rkt @@ -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 isn’t" - "Items aren’t") " 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"))))) + diff --git a/ptree.rkt b/ptree.rkt index 88da701..2cd4021 100644 --- a/ptree.rkt +++ b/ptree.rkt @@ -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?) diff --git a/render.rkt b/render.rkt index 67d8542..30df435 100644 --- a/render.rkt +++ b/render.rkt @@ -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)) diff --git a/server-routes.rkt b/server-routes.rkt index cb8e0b2..f962749 100644 --- a/server-routes.rkt +++ b/server-routes.rkt @@ -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)) diff --git a/template.rkt b/template.rkt index 92ed858..2dccfa9 100644 --- a/template.rkt +++ b/template.rkt @@ -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) diff --git a/tests/file-tools-tests.rkt b/tests/test-file-tools.rkt similarity index 100% rename from tests/file-tools-tests.rkt rename to tests/test-file-tools.rkt diff --git a/tests/test-predicates.rkt b/tests/test-predicates.rkt new file mode 100644 index 0000000..a98caac --- /dev/null +++ b/tests/test-predicates.rkt @@ -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"))))) \ No newline at end of file diff --git a/tools.rkt b/tools.rkt index a46e420..ad3d499 100644 --- a/tools.rkt +++ b/tools.rkt @@ -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) (stringstring 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)))