'safe submodule

dev-validator
Matthew Butterick 11 years ago
parent 7f0743100e
commit 5478a41c3a

@ -1,39 +1,43 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base)) (require (for-syntax racket/base))
(require racket/contract racket/match xml racket/list) (require racket/match xml)
(define-syntax (define+provide/contract stx) (module+ safe (require racket/contract))
(define-syntax (define+provide+safe stx)
(syntax-case stx () (syntax-case stx ()
[(_ (proc arg ... . rest-arg) contract body ...) [(_ (proc arg ... . rest-arg) contract body ...)
#'(define+provide/contract proc contract #'(define+provide+safe proc contract
(λ(arg ... . rest-arg) body ...))] (λ(arg ... . rest-arg) body ...))]
[(_ name contract body ...) [(_ name contract body ...)
#'(begin #'(begin
(provide (contract-out [name contract])) (define name body ...)
(define name body ...))])) (provide name)
(module+ safe
(provide (contract-out [name contract]))))]))
(define+provide/contract (txexpr-tag? x) (define+provide+safe (txexpr-tag? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
(symbol? x)) (symbol? x))
(define+provide/contract (txexpr-attr? x) (define+provide+safe (txexpr-attr? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
(match x (match x
[(list (? symbol?) (? string?)) #t] [(list (? symbol?) (? string?)) #t]
[else #f])) [else #f]))
(define+provide/contract (txexpr-attrs? x) (define+provide+safe (txexpr-attrs? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
(match x (match x
[(list (? txexpr-attr?) ...) #t] [(list (? txexpr-attr?) ...) #t]
[else #f])) [else #f]))
(define+provide/contract (txexpr-element? x) (define+provide+safe (txexpr-element? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
(or (string? x) (txexpr? x) (symbol? x) (or (string? x) (txexpr? x) (symbol? x)
(valid-char? x) (cdata? x))) (valid-char? x) (cdata? x)))
(define+provide/contract (txexpr-elements? x) (define+provide+safe (txexpr-elements? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
(match x (match x
[(list elem ...) (andmap txexpr-element? elem)] [(list elem ...) (andmap txexpr-element? elem)]
@ -41,123 +45,128 @@
;; is it a named x-expression? ;; is it a named x-expression?
;; todo: rewrite this recurively so errors can be pinpointed (for debugging) ;; todo: rewrite this recurively so errors can be pinpointed (for debugging)
(define+provide/contract (txexpr? x) (define+provide+safe (txexpr? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
(and (xexpr? x) ; meets basic xexpr contract (and (xexpr? x) ; meets basic xexpr contract
(match x (match x
[(list (? symbol? name) rest ...) ;; is a list starting with a symbol [(list (? symbol? name) rest ...) ;; is a list starting with a symbol
(or (empty? rest) (or (null? rest)
(andmap txexpr-element? rest) ;; the rest is content or ... (andmap txexpr-element? rest) ;; the rest is content or ...
(and (txexpr-attrs? (car rest)) (andmap txexpr-element? (cdr rest))))] ;; attr + content (and (txexpr-attrs? (car rest)) (andmap txexpr-element? (cdr rest))))] ;; attr + content
[else #f]))) [else #f])))
(define+provide/contract (make-txexpr tag [attrs empty] [elements empty]) (define+provide+safe (make-txexpr tag [attrs null] [elements null])
;; todo?: use xexpr/c provides a nicer error message ;; todo?: use xexpr/c provides a nicer error message
((symbol?) (txexpr-attrs? (listof txexpr-element?)) ((symbol?) (txexpr-attrs? (listof txexpr-element?))
. ->* . txexpr?) . ->* . txexpr?)
(filter-not empty? `(,tag ,attrs ,@elements))) (filter (compose1 not null?) `(,tag ,attrs ,@elements)))
(define+provide/contract (txexpr->values x) (define+provide+safe (txexpr->values x)
(txexpr? . -> . (txexpr? . -> .
(values symbol? txexpr-attrs? (listof txexpr-element?))) (values symbol? txexpr-attrs? (listof txexpr-element?)))
(match (match
; txexpr may or may not have attr ; txexpr may or may not have attr
; if not, add empty attr so that decomposition only handles one case ; if not, add null attr so that decomposition only handles one case
(match x (match x
[(list _ (? txexpr-attrs?) _ ...) x] [(list _ (? txexpr-attrs?) _ ...) x]
[else `(,(car x) ,empty ,@(cdr x))]) [else `(,(car x) ,null ,@(cdr x))])
[(list tag attr content ...) (values tag attr content)])) [(list tag attr content ...) (values tag attr content)]))
(define+provide/contract (txexpr->list x) (define+provide+safe (txexpr->list x)
(txexpr? . -> . list?) (txexpr? . -> . list?)
(define-values (tag attrs content) (txexpr->values x)) (define-values (tag attrs content) (txexpr->values x))
(list tag attrs content)) (list tag attrs content))
;; convenience functions to retrieve only one part of txexpr ;; convenience functions to retrieve only one part of txexpr
(define+provide/contract (get-tag x) (define+provide+safe (get-tag x)
(txexpr? . -> . txexpr-tag?) (txexpr? . -> . txexpr-tag?)
(car x)) (car x))
(define+provide/contract (get-attrs x) (define+provide+safe (get-attrs x)
(txexpr? . -> . txexpr-attrs?) (txexpr? . -> . txexpr-attrs?)
(define-values (tag attrs content) (txexpr->values x)) (define-values (tag attrs content) (txexpr->values x))
attrs) attrs)
(define+provide/contract (get-elements x) (define+provide+safe (get-elements x)
(txexpr? . -> . (listof txexpr-element?)) (txexpr? . -> . (listof txexpr-element?))
(define-values (tag attrs elements) (txexpr->values x)) (define-values (tag attrs elements) (txexpr->values x))
elements) elements)
;; helpers. we are getting a string or symbol ;; helpers. we are getting a string or symbol
(define+provide/contract (->txexpr-attr-key x) (define+provide+safe (->txexpr-attr-key x)
(can-be-txexpr-attr-key? . -> . txexpr-attr-key?) (can-be-txexpr-attr-key? . -> . txexpr-attr-key?)
(if (string? x) (string->symbol x) x)) (if (string? x) (string->symbol x) x))
(define+provide/contract (->txexpr-attr-value x) (define+provide+safe (->txexpr-attr-value x)
(can-be-txexpr-attr-value? . -> . txexpr-attr-value?) (can-be-txexpr-attr-value? . -> . txexpr-attr-value?)
(->string x)) (->string x))
(define+provide/contract (txexpr-attr-key? x) (define+provide+safe (txexpr-attr-key? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
(symbol? x)) (symbol? x))
(define+provide/contract (can-be-txexpr-attr-key? x) (define+provide+safe (can-be-txexpr-attr-key? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
(or (symbol? x) (string? x))) (or (symbol? x) (string? x)))
(define+provide/contract (txexpr-attr-value? x) (define+provide+safe (txexpr-attr-value? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
(string? x)) (string? x))
(define+provide/contract (can-be-txexpr-attr-value? x) (define+provide+safe (can-be-txexpr-attr-value? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
(can-be-txexpr-attr-key? x)) (can-be-txexpr-attr-key? x))
(define (->string x) (define (->string x)
(any/c . -> . string?)
(if (symbol? x) (symbol->string x) x)) (if (symbol? x) (symbol->string x) x))
(define+provide/contract (can-be-txexpr-attrs? x) (define+provide+safe (can-be-txexpr-attrs? x)
(any/c . -> . boolean?) (any/c . -> . boolean?)
((or/c txexpr-attr? txexpr-attrs? can-be-txexpr-attr-key? can-be-txexpr-attr-value?) x)) (ormap (λ(test) (test x)) (list txexpr-attr? txexpr-attrs? can-be-txexpr-attr-key? can-be-txexpr-attr-value?)))
(define (flatten orig-sexp)
(let loop ([sexp orig-sexp] [acc null])
(cond [(null? sexp) acc]
[(pair? sexp) (loop (car sexp) (loop (cdr sexp) acc))]
[else (cons sexp acc)])))
(define+provide/contract (attrs->hash . items) (define+provide+safe (attrs->hash . items)
(() #:rest (listof can-be-txexpr-attrs?) . ->* . hash?) (() #:rest (listof can-be-txexpr-attrs?) . ->* . hash?)
;; can be liberal with input because they're all just nested key/value pairs ;; can be liberal with input because they're all just nested key/value pairs
;; but still need this function to make sure that 'foo and "foo" are treated as the same hash key ;; but still need this function to make sure that 'foo and "foo" are treated as the same hash key
(define (make-key-value-list items) (define (make-key-value-list items)
(if (empty? items) (if (null? items)
empty null
(let ([key (->txexpr-attr-key (first items))] (let ([key (->txexpr-attr-key (car items))]
[value (->txexpr-attr-value (second items))] [value (->txexpr-attr-value (cadr items))]
[rest (drop items 2)]) [rest (cddr items)])
(cons (cons key value) (make-key-value-list rest))))) (cons (cons key value) (make-key-value-list rest)))))
(make-immutable-hash (make-key-value-list (flatten items)))) (make-immutable-hash (make-key-value-list (flatten items))))
(define+provide/contract (hash->attrs hash) (define+provide+safe (hash->attrs hash)
(hash? . -> . txexpr-attrs?) (hash? . -> . txexpr-attrs?)
(hash-map hash list)) (hash-map hash list))
(define+provide/contract (attr-set tx key value) (define+provide+safe (attr-set tx key value)
(txexpr? can-be-txexpr-attr-key? can-be-txexpr-attr-value? . -> . txexpr?) (txexpr? can-be-txexpr-attr-key? can-be-txexpr-attr-value? . -> . txexpr?)
(define new-attrs (define new-attrs
(hash->attrs (hash-set (attrs->hash (get-attrs tx)) (->txexpr-attr-key key) (->txexpr-attr-value value)))) (hash->attrs (hash-set (attrs->hash (get-attrs tx)) (->txexpr-attr-key key) (->txexpr-attr-value value))))
(make-txexpr (get-tag tx) new-attrs (get-elements tx))) (make-txexpr (get-tag tx) new-attrs (get-elements tx)))
(define+provide/contract (attr-ref tx key) (define+provide+safe (attr-ref tx key)
(txexpr? can-be-txexpr-attr-key? . -> . txexpr-attr-value?) (txexpr? can-be-txexpr-attr-key? . -> . txexpr-attr-value?)
(with-handlers ([exn:fail? (λ(e) (error (format "attr-ref: no value found for key ~v" key)))]) (with-handlers ([exn:fail? (λ(e) (error (format "attr-ref: no value found for key ~v" key)))])
(hash-ref (attrs->hash (get-attrs tx)) key))) (hash-ref (attrs->hash (get-attrs tx)) key)))
;; convert list of alternating keys & values to attr ;; convert list of alternating keys & values to attr
(define+provide/contract (merge-attrs . items) (define+provide+safe (merge-attrs . items)
(() #:rest (listof can-be-txexpr-attrs?) . ->* . txexpr-attrs?) (() #:rest (listof can-be-txexpr-attrs?) . ->* . txexpr-attrs?)
(define attrs-hash (apply attrs->hash items)) (define attrs-hash (apply attrs->hash items))
;; sort needed for predictable results for unit tests ;; sort needed for predictable results for unit tests
@ -165,17 +174,17 @@
`(,@(map (λ(key) (list key (hash-ref attrs-hash key))) sorted-hash-keys))) `(,@(map (λ(key) (list key (hash-ref attrs-hash key))) sorted-hash-keys)))
(define+provide/contract (remove-attrs x) (define+provide+safe (remove-attrs x)
(txexpr? . -> . txexpr?) (txexpr? . -> . txexpr?)
(cond (cond
[(txexpr? x) (let-values ([(tag attr elements) (txexpr->values x)]) [(txexpr? x) (let-values ([(tag attr elements) (txexpr->values x)])
(make-txexpr tag empty (remove-attrs elements)))] (make-txexpr tag null (remove-attrs elements)))]
[(txexpr-elements? x) (map remove-attrs x)] [(txexpr-elements? x) (map remove-attrs x)]
[else x])) [else x]))
;; todo: exclude-proc will keep things out, but is there a way to keep things in? ;; todo: exclude-proc will keep things out, but is there a way to keep things in?
(define+provide/contract (map-elements/exclude proc x exclude-test) (define+provide+safe (map-elements/exclude proc x exclude-test)
(procedure? txexpr? procedure? . -> . txexpr?) (procedure? txexpr? procedure? . -> . txexpr?)
(cond (cond
[(txexpr? x) [(txexpr? x)
@ -188,22 +197,22 @@
;; but internally we don't care ;; but internally we don't care
[else (proc x)])) [else (proc x)]))
(define+provide/contract (map-elements proc x) (define+provide+safe (map-elements proc x)
(procedure? txexpr? . -> . txexpr?) (procedure? txexpr? . -> . txexpr?)
(map-elements/exclude proc x (λ(x) #f))) (map-elements/exclude proc x (λ(x) #f)))
;; function to split tag out of txexpr ;; function to split tag out of txexpr
(define+provide/contract (splitf-txexpr tx proc) (define+provide+safe (splitf-txexpr tx proc)
(txexpr? procedure? . -> . (values txexpr? (listof txexpr-element?))) (txexpr? procedure? . -> . (values txexpr? (listof txexpr-element?)))
(define matches empty) (define matches null)
(define (do-extraction x) (define (do-extraction x)
(cond (cond
[(proc x) (begin ; store matched item but return empty value [(proc x) (begin ; store matched item but return null value
(set! matches (cons x matches)) (set! matches (cons x matches))
empty)] null)]
[(txexpr? x) (let-values([(tag attr body) (txexpr->values x)]) [(txexpr? x) (let-values([(tag attr body) (txexpr->values x)])
(make-txexpr tag attr (do-extraction body)))] (make-txexpr tag attr (do-extraction body)))]
[(txexpr-elements? x) (filter-not empty? (map do-extraction x))] [(txexpr-elements? x) (filter (compose1 not null?) (map do-extraction x))]
[else x])) [else x]))
(define tx-extracted (do-extraction tx)) ;; do this first to fill matches (define tx-extracted (do-extraction tx)) ;; do this first to fill matches
(values tx-extracted (reverse matches))) (values tx-extracted (reverse matches)))

@ -10,8 +10,17 @@
@author[(author+email "Matthew Butterick" "mb@mbtype.com")] @author[(author+email "Matthew Butterick" "mb@mbtype.com")]
@defmodule[#:multi (txexpr (submod txexpr safe))]
A set of small but handy functions for improving the readability and reliability of programs that operate on tagged X-expressions (for short, @italic{txexpr}s). A set of small but handy functions for improving the readability and reliability of programs that operate on tagged X-expressions (for short, @italic{txexpr}s).
@section{Importing the module}
The module operates in two modes: fast and safe. Fast mode is the default, which you get by importing the module in the usual way: @code{(require txexpr)}.
Safe mode enables the function contracts documented below. Use safe mode by importing the module as @code{(require (submod txexpr safe))}.
@section{Installation} @section{Installation}
At the command line: At the command line:

@ -1,13 +1,11 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base)) (require (for-syntax racket/base))
(require "main.rkt" rackunit) (require (submod "main.rkt" safe) rackunit)
(define-syntax (values->list stx) (define-syntax (values->list stx)
(syntax-case stx () (syntax-case stx ()
[(_ values-expr) #'(call-with-values (λ () values-expr) list)])) [(_ values-expr) #'(call-with-values (λ () values-expr) list)]))
(define empty '())
(check-true (txexpr-tag?'foo)) (check-true (txexpr-tag?'foo))
(check-false (txexpr-tag? "foo")) (check-false (txexpr-tag? "foo"))
(check-false (txexpr-tag? 3)) (check-false (txexpr-tag? 3))
@ -47,16 +45,16 @@
(check-equal? (make-txexpr 'p) '(p)) (check-equal? (make-txexpr 'p) '(p))
(check-equal? (make-txexpr 'p '((key "value"))) '(p ((key "value")))) (check-equal? (make-txexpr 'p '((key "value"))) '(p ((key "value"))))
(check-equal? (make-txexpr 'p empty '("foo" "bar")) '(p "foo" "bar")) (check-equal? (make-txexpr 'p null '("foo" "bar")) '(p "foo" "bar"))
(check-equal? (make-txexpr 'p '((key "value")) (list "foo" "bar")) (check-equal? (make-txexpr 'p '((key "value")) (list "foo" "bar"))
'(p ((key "value")) "foo" "bar")) '(p ((key "value")) "foo" "bar"))
(check-equal? (values->list (txexpr->values '(p))) (check-equal? (values->list (txexpr->values '(p)))
(values->list (values 'p empty empty))) (values->list (values 'p null null)))
(check-equal? (values->list (txexpr->values '(p "foo"))) (check-equal? (values->list (txexpr->values '(p "foo")))
(values->list (values 'p empty '("foo")))) (values->list (values 'p null '("foo"))))
(check-equal? (values->list (txexpr->values '(p ((key "value"))))) (check-equal? (values->list (txexpr->values '(p ((key "value")))))
(values->list (values 'p '((key "value")) empty))) (values->list (values 'p '((key "value")) null)))
(check-equal? (values->list (txexpr->values '(p ((key "value")) "foo"))) (check-equal? (values->list (txexpr->values '(p ((key "value")) "foo")))
(values->list (values 'p '((key "value")) '("foo")))) (values->list (values 'p '((key "value")) '("foo"))))

Loading…
Cancel
Save