diff --git a/main.rkt b/main.rkt new file mode 100644 index 0000000..56e1aef --- /dev/null +++ b/main.rkt @@ -0,0 +1,138 @@ +#lang racket/base +(require racket/contract racket/match xml racket/list) +(require pollen/readability) + + +(provide (all-defined-out)) + +;; 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])) + + + +;; 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])) + + +;; 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]))) + + + +;; 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))))))) + + + + + + +;; 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))) + + + +;; 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)])) + + + +;; 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) + + + + +;; 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])) + diff --git a/tests.rkt b/tests.rkt new file mode 100644 index 0000000..908880c --- /dev/null +++ b/tests.rkt @@ -0,0 +1,64 @@ +#lang racket/base +(require "main.rkt" rackunit) +(define empty '()) + +;; 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)) + +(check-true (xexpr-attr? '())) +(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 + +(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 + + +(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 + + +(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"))) + + +(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")) + +(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")))) + + +(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"))) + +(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"))) \ No newline at end of file