From 5478a41c3a17506a420cb6277f245b5b5b5873ea Mon Sep 17 00:00:00 2001
From: Matthew Butterick <mb@mbtype.com>
Date: Fri, 21 Feb 2014 20:26:30 -0800
Subject: [PATCH] 'safe submodule

---
 main.rkt                 | 107 +++++++++++++++++++++------------------
 scribblings/txexpr.scrbl |   9 ++++
 tests.rkt                |  12 ++---
 3 files changed, 72 insertions(+), 56 deletions(-)

diff --git a/main.rkt b/main.rkt
index b39f78e..85f8f20 100644
--- a/main.rkt
+++ b/main.rkt
@@ -1,39 +1,43 @@
 #lang 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 ()
     [(_ (proc arg ... . rest-arg) contract body ...)
-     #'(define+provide/contract proc contract
+     #'(define+provide+safe proc contract
          (λ(arg ... . rest-arg) body ...))]
     [(_ name contract body ...)
      #'(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?)
   (symbol? x)) 
 
-(define+provide/contract (txexpr-attr? x)
+(define+provide+safe (txexpr-attr? x)
   (any/c . -> . boolean?)
   (match x
     [(list (? symbol?) (? string?)) #t]
     [else #f]))
 
-(define+provide/contract (txexpr-attrs? x)
+(define+provide+safe (txexpr-attrs? x)
   (any/c . -> . boolean?)
   (match x
     [(list (? txexpr-attr?) ...) #t]
     [else #f]))
 
-(define+provide/contract (txexpr-element? x)
+(define+provide+safe (txexpr-element? x)
   (any/c . -> . boolean?)
   (or (string? x) (txexpr? x) (symbol? x)
       (valid-char? x) (cdata? x)))
 
-(define+provide/contract (txexpr-elements? x)
+(define+provide+safe (txexpr-elements? x)
   (any/c . -> . boolean?)
   (match x
     [(list elem ...) (andmap txexpr-element? elem)]
@@ -41,123 +45,128 @@
 
 ;; is it a named x-expression?
 ;; todo: rewrite this recurively so errors can be pinpointed (for debugging)
-(define+provide/contract (txexpr? x)
+(define+provide+safe (txexpr? 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 (empty? rest) 
+          (or (null? rest) 
               (andmap txexpr-element? rest)           ;; the rest is content or ...
               (and (txexpr-attrs? (car rest)) (andmap txexpr-element? (cdr rest))))] ;; attr + content 
          [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
   ((symbol?) (txexpr-attrs? (listof txexpr-element?)) 
              . ->* . 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? . -> . 
            (values symbol? txexpr-attrs? (listof txexpr-element?)))
   (match 
       ; 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
         [(list _ (? txexpr-attrs?) _ ...) x]
-        [else `(,(car x) ,empty ,@(cdr x))])
+        [else `(,(car x) ,null ,@(cdr x))])
     [(list tag attr content ...) (values tag attr content)]))
 
 
-(define+provide/contract (txexpr->list x)
+(define+provide+safe (txexpr->list x)
   (txexpr? . -> . list?)
   (define-values (tag attrs content) (txexpr->values x))
   (list tag attrs content))
 
 
 ;; convenience functions to retrieve only one part of txexpr
-(define+provide/contract (get-tag x)
+(define+provide+safe (get-tag x)
   (txexpr? . -> . txexpr-tag?)
   (car x))
 
 
-(define+provide/contract (get-attrs x)
+(define+provide+safe (get-attrs x)
   (txexpr? . -> . txexpr-attrs?)
   (define-values (tag attrs content) (txexpr->values x))
   attrs)
 
 
-(define+provide/contract (get-elements x)
+(define+provide+safe (get-elements x)
   (txexpr? . -> . (listof txexpr-element?))
   (define-values (tag attrs elements) (txexpr->values x))
   elements)
 
 
 ;; 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?)
   (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?)
   (->string x))
 
-(define+provide/contract (txexpr-attr-key? x) 
+(define+provide+safe (txexpr-attr-key? x) 
   (any/c . -> . boolean?)
   (symbol? x))
 
-(define+provide/contract (can-be-txexpr-attr-key? x)
+(define+provide+safe (can-be-txexpr-attr-key? x)
   (any/c . -> . boolean?)
   (or (symbol? x) (string? x)))
 
-(define+provide/contract (txexpr-attr-value? x) 
+(define+provide+safe (txexpr-attr-value? x) 
   (any/c . -> . boolean?)
   (string? x))
 
-(define+provide/contract (can-be-txexpr-attr-value? x) 
+(define+provide+safe (can-be-txexpr-attr-value? x) 
   (any/c . -> . boolean?)
   (can-be-txexpr-attr-key? x))
 
 (define (->string x) 
-  (any/c . -> . string?)
   (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?)
-  ((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?)
   ;; 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
   (define (make-key-value-list items)
-    (if (empty? items)
-        empty
-        (let ([key (->txexpr-attr-key (first items))]
-              [value (->txexpr-attr-value (second items))]
-              [rest (drop items 2)])
+    (if (null? items)
+        null
+        (let ([key (->txexpr-attr-key (car items))]
+              [value (->txexpr-attr-value (cadr items))]
+              [rest (cddr items)])
           (cons (cons key value) (make-key-value-list rest)))))
   (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-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?)
   (define new-attrs 
     (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)))
 
 
-(define+provide/contract (attr-ref tx key)
+(define+provide+safe (attr-ref tx key)
   (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)))])
     (hash-ref (attrs->hash (get-attrs tx)) key)))
 
 ;; 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?)
   (define attrs-hash (apply attrs->hash items))
   ;; sort needed for predictable results for unit tests
@@ -165,17 +174,17 @@
   `(,@(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?)
   (cond
     [(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)]
     [else x]))
 
 
 ;; 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?)
   (cond
     [(txexpr? x) 
@@ -188,22 +197,22 @@
     ;; but internally we don't care
     [else (proc x)]))
 
-(define+provide/contract (map-elements proc x)
+(define+provide+safe (map-elements proc x)
   (procedure? txexpr? . -> . txexpr?)
   (map-elements/exclude proc x (λ(x) #f)))
 
 ;; 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?)))
-  (define matches empty)
+  (define matches null)
   (define (do-extraction x)
     (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))
-                  empty)]
+                  null)]
       [(txexpr? x) (let-values([(tag attr body) (txexpr->values x)]) 
                      (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]))
   (define tx-extracted (do-extraction tx)) ;; do this first to fill matches
   (values tx-extracted (reverse matches))) 
diff --git a/scribblings/txexpr.scrbl b/scribblings/txexpr.scrbl
index e12f017..76f17d8 100644
--- a/scribblings/txexpr.scrbl
+++ b/scribblings/txexpr.scrbl
@@ -10,8 +10,17 @@
 
 @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).
 
+@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}
 
 At the command line:
diff --git a/tests.rkt b/tests.rkt
index 9d358c2..c4d7a51 100644
--- a/tests.rkt
+++ b/tests.rkt
@@ -1,13 +1,11 @@
 #lang racket/base
 (require (for-syntax racket/base))
-(require "main.rkt" rackunit)
+(require (submod "main.rkt" safe) rackunit)
 
 (define-syntax (values->list stx)
   (syntax-case stx ()
     [(_ values-expr) #'(call-with-values (λ () values-expr) list)]))
 
-(define empty '())
-
 (check-true (txexpr-tag?'foo))
 (check-false (txexpr-tag? "foo"))
 (check-false (txexpr-tag? 3))
@@ -47,16 +45,16 @@
 
 (check-equal? (make-txexpr 'p) '(p))
 (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")) 
               '(p ((key "value")) "foo" "bar"))
 
 (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"))) 
-              (values->list (values 'p empty '("foo"))))
+              (values->list (values 'p null '("foo"))))
 (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"))) 
               (values->list (values 'p '((key "value")) '("foo"))))