diff --git a/cache.rkt b/cache.rkt index d774a9c..23c3dd2 100644 --- a/cache.rkt +++ b/cache.rkt @@ -1,17 +1,24 @@ #lang racket/base (require (for-syntax racket/base) "define.rkt") + (define+provide+safe (make-caching-proc base-proc) (procedure? . -> . procedure?) (let ([cache (make-hash)]) (make-keyword-procedure (λ (kws kw-args . args) - (hash-ref! cache args (λ () (keyword-apply base-proc kws kw-args args))))))) + (hash-ref! cache (list* kws kw-args args) (λ () (keyword-apply base-proc kws kw-args args))))))) + + +(define-for-syntax (lambdafy stx) + (syntax-case stx () + [(_ (id arg ... . rest-arg) body ...) + #'(id (λ (arg ... . rest-arg) body ...))] + [(_ id body-exp) + #'(id body-exp)])) + (provide+safe define/caching) (define-syntax (define/caching stx) - (syntax-case stx () - [(_ (name arg ... . rest-arg) body ...) - #'(define/caching name (λ(arg ... . rest-arg) body ...))] - [(_ name body ...) - #'(define name (make-caching-proc body ...))])) \ No newline at end of file + (with-syntax ([(id lambda-expr) (lambdafy stx)]) + #'(define id (make-caching-proc lambda-expr)))) diff --git a/coerce.rkt b/coerce.rkt index d18c92d..d402d32 100644 --- a/coerce.rkt +++ b/coerce.rkt @@ -1,165 +1,12 @@ #lang racket/base -(require (for-syntax racket/base racket/syntax)) -(require net/url racket/set racket/sequence "unstable/len.rkt" "define.rkt") -(define-syntax-rule (make-coercion-error-handler target-format x) - (λ(e) (error (string->symbol (format "->~a" target-format)) (format "Can't convert ~s to ~a" x target-format)))) +(define-syntax-rule (r+p modname ...) + (begin + (begin + (require modname) + (provide (all-from-out modname)) + (module+ safe + (require (submod modname safe)) + (provide (all-from-out (submod modname safe))))) ...)) - -(define+provide+safe (->int x) - (any/c . -> . integer?) - (with-handlers ([exn:fail? (make-coercion-error-handler 'int x)]) - (cond - [(or (integer? x) (real? x)) (inexact->exact (floor x))] - [(complex? x) (->int (real-part x))] - [(string? x) (let ([strnum (string->number x)]) - (if (real? strnum) (->int strnum) (error 'ineligible-string)))] - [(or (symbol? x) (path? x) (bytes? x)) (->int (->string x))] - [(char? x) (char->integer x)] - [else (len x)]))) ; covers Lengthable types - - -(define+provide+safe (->string x) - (any/c . -> . string?) - (if (string? x) - x ; fast exit for strings - (with-handlers ([exn:fail? (make-coercion-error-handler 'string x)]) - (cond - [(or (equal? '() x) (void? x)) ""] - [(symbol? x) (symbol->string x)] - [(number? x) (number->string x)] - [(path? x) (path->string x)] - [(or (char? x) (bytes? x)) (format "~a" x)] - [(url? x) (url->string x)] - [else (error 'bad-type)])))) - - -;; ->symbol, ->path, and ->url are just variants on ->string -;; two advantages: return correct type, and more accurate error - -;; no need for "Symbolable" type - same as Stringable -(define+provide+safe (->symbol x) - (any/c . -> . symbol?) - (if (symbol? x) - x - (with-handlers ([exn:fail? (make-coercion-error-handler 'symbol x)]) - (string->symbol (->string x))))) - - -(define+provide+safe (->path x) - (any/c . -> . path?) - (if (path? x) - x - (with-handlers ([exn:fail? (make-coercion-error-handler 'path x)]) - (cond - [(url? x) (apply build-path (map path/param-path (url-path x)))] - [else (string->path (->string x))])))) - - -(define+provide+safe (->url x) - (any/c . -> . url?) - (with-handlers ([exn:fail? (make-coercion-error-handler 'url x)]) - (string->url (->string x)))) - - -(define+provide+safe (->complete-path x) - (any/c . -> . complete-path?) - (with-handlers ([exn:fail? (make-coercion-error-handler 'complete-path x)]) - (path->complete-path (->path x)))) - - -(define+provide+safe (->list x) - (any/c . -> . list?) - (if (list? x) - x - (with-handlers ([exn:fail? (make-coercion-error-handler 'list x)]) - (cond - [(string? x) (list x)] - [(vector? x) (for/list ([i (in-vector x)]) - i)] - [(set? x) (set->list x)] - ;; conditional sequencing relevant because hash also tests true for `sequence?` - [(hash? x) (hash->list x)] - [(integer? x) (list x)] ; because an integer tests #t for sequence? - [(sequence? x) (sequence->list x)] - ;[(stream? x) (stream->list x)] ;; no support for streams in TR - [else (list x)])))) - - -(define+provide+safe (->vector x) - (any/c . -> . vector?) - (if (vector? x) - x - (with-handlers ([exn:fail? (make-coercion-error-handler 'vector x)]) - (list->vector (->list x))))) - - -(define+provide+safe (->boolean x) - (any/c . -> . boolean?) - (and x #t)) - - -;; coercion contracts & *ish predicates -;; only make sense in untyped code -;; thus they are here. -(define-syntax-rule (make-blame-handler try-proc expected-sym) - (λ(b) - (λ(x) - (with-handlers ([exn:fail? (λ(e) - (raise-blame-error - b x - '(expected: "~a" given: "~e") - expected-sym x))]) - (try-proc x))))) - - -(provide+safe make-coercion-contract) -(define-syntax (make-coercion-contract stx) - (syntax-case stx () - [(_ stem coerce-proc) - (with-syntax ([coerce/stem? (format-id stx "coerce/~a?" #'stem)] - [can-be-stem? (format-id stx "can-be-~a?" #'stem)]) - #'(make-contract - #:name 'coerce/stem? - #:projection (make-blame-handler coerce-proc 'can-be-stem?)))] - [(_ stem) - (with-syntax ([->stem (format-id stx "->~a" #'stem)]) - #'(make-coercion-contract stem ->stem))])) - - -(define-syntax (define+provide-coercion-contract stx) - (syntax-case stx () - [(_ stem) - (with-syntax ([coerce/stem? (format-id stx "coerce/~a?" #'stem)]) - #'(begin - (provide+safe coerce/stem?) - (define coerce/stem? (make-coercion-contract stem))))])) - - -(define+provide-coercion-contract int) -(define+provide-coercion-contract string) -(define+provide-coercion-contract symbol) -(define+provide-coercion-contract path) -(define+provide-coercion-contract boolean) -(define+provide-coercion-contract list) - - -(define-syntax (make-*ish-predicate stx) - (syntax-case stx () - [(_ stem) - (with-syntax ([stemish? (format-id stx "~aish?" #'stem)] - [->stem (format-id stx "->~a" #'stem)]) - #`(begin - (provide+safe stemish?) - (define (stemish? x) - (with-handlers ([exn:fail? (λ(e) #f)]) (and (->stem x) #t)))))])) - - -(make-*ish-predicate int) -(make-*ish-predicate string) -(make-*ish-predicate symbol) -(make-*ish-predicate url) -(make-*ish-predicate complete-path) -(make-*ish-predicate path) -(make-*ish-predicate list) -(make-*ish-predicate vector) \ No newline at end of file +(r+p "coerce/base.rkt" "coerce/contract.rkt") \ No newline at end of file diff --git a/coerce/base.rkt b/coerce/base.rkt new file mode 100644 index 0000000..4dccdb8 --- /dev/null +++ b/coerce/base.rkt @@ -0,0 +1,119 @@ +#lang racket/base +(require (for-syntax racket/base racket/syntax)) +(require net/url racket/sequence "../unstable/len.rkt" "../define.rkt") + +(define-syntax-rule (make-coercion-error-handler target-format x) + (λ(e) (error (string->symbol (format "->~a" target-format)) (format "Can't convert ~s to ~a" x target-format)))) + + +(define+provide+safe (->int x) + (any/c . -> . integer?) + (with-handlers ([exn:fail? (make-coercion-error-handler 'int x)]) + (cond + [(or (integer? x) (real? x)) (inexact->exact (floor x))] + [(complex? x) (->int (real-part x))] + [(string? x) (let ([strnum (string->number x)]) + (if (real? strnum) (->int strnum) (error 'ineligible-string)))] + [(or (symbol? x) (path? x) (bytes? x)) (->int (->string x))] + [(char? x) (char->integer x)] + [else (len x)]))) ; covers Lengthable types + + +(define+provide+safe (->string x) + (any/c . -> . string?) + (if (string? x) + x ; fast exit for strings + (with-handlers ([exn:fail? (make-coercion-error-handler 'string x)]) + (cond + [(or (null? x) (void? x)) ""] + [(symbol? x) (symbol->string x)] + [(number? x) (number->string x)] + [(path? x) (path->string x)] + [(or (char? x) (bytes? x)) (format "~a" x)] + [(url? x) (url->string x)] + [else (error 'bad-type)])))) + + +;; ->symbol, ->path, and ->url are just variants on ->string +;; two advantages: return correct type, and more accurate error + +;; no need for "Symbolable" type - same as Stringable +(define+provide+safe (->symbol x) + (any/c . -> . symbol?) + (if (symbol? x) + x + (with-handlers ([exn:fail? (make-coercion-error-handler 'symbol x)]) + (string->symbol (->string x))))) + + +(define+provide+safe (->path x) + (any/c . -> . path?) + (if (path? x) + x + (with-handlers ([exn:fail? (make-coercion-error-handler 'path x)]) + (cond + [(url? x) (apply build-path (map path/param-path (url-path x)))] + [else (string->path (->string x))])))) + + +(define+provide+safe (->url x) + (any/c . -> . url?) + (with-handlers ([exn:fail? (make-coercion-error-handler 'url x)]) + (string->url (->string x)))) + + +(define+provide+safe (->complete-path x) + (any/c . -> . complete-path?) + (with-handlers ([exn:fail? (make-coercion-error-handler 'complete-path x)]) + (path->complete-path (->path x)))) + + +(define+provide+safe (->list x) + (any/c . -> . list?) + (if (list? x) + x + (with-handlers ([exn:fail? (make-coercion-error-handler 'list x)]) + (cond + [(string? x) (list x)] + [(vector? x) (for/list ([i (in-vector x)]) + i)] + ;; conditional sequencing relevant because hash also tests true for `sequence?` + [(hash? x) (hash->list x)] + [(integer? x) (list x)] ; because an integer tests #t for sequence? + [(sequence? x) (sequence->list x)] + ;[(stream? x) (stream->list x)] ;; no support for streams in TR + [else (list x)])))) + + +(define+provide+safe (->vector x) + (any/c . -> . vector?) + (if (vector? x) + x + (with-handlers ([exn:fail? (make-coercion-error-handler 'vector x)]) + (list->vector (->list x))))) + + +(define+provide+safe (->boolean x) + (any/c . -> . boolean?) + (and x #t)) + + +(define-syntax (make-*ish-predicate stx) + (syntax-case stx () + [(_ stem) + (with-syntax ([stemish? (format-id stx "~aish?" #'stem)] + [->stem (format-id stx "->~a" #'stem)]) + #`(begin + (provide+safe stemish?) + (define (stemish? x) + (with-handlers ([exn:fail? (λ(e) #f)]) (and (->stem x) #t)))))])) + + +(make-*ish-predicate int) +(make-*ish-predicate string) +(make-*ish-predicate symbol) +(make-*ish-predicate url) +(make-*ish-predicate complete-path) +(make-*ish-predicate path) +(make-*ish-predicate list) +(make-*ish-predicate vector) \ No newline at end of file diff --git a/coerce/contract.rkt b/coerce/contract.rkt new file mode 100644 index 0000000..d956491 --- /dev/null +++ b/coerce/contract.rkt @@ -0,0 +1,44 @@ +#lang racket/base +(require (for-syntax racket/base racket/syntax) racket/contract "../define.rkt" "base.rkt") + + +(define-syntax-rule (make-blame-handler try-proc expected-sym) + (λ(b) + (λ(x) + (with-handlers ([exn:fail? (λ(e) + (raise-blame-error + b x + '(expected: "~a" given: "~e") + expected-sym x))]) + (try-proc x))))) + + +(provide+safe make-coercion-contract) +(define-syntax (make-coercion-contract stx) + (syntax-case stx () + [(_ stem coerce-proc) + (with-syntax ([coerce/stem? (format-id stx "coerce/~a?" #'stem)] + [can-be-stem? (format-id stx "can-be-~a?" #'stem)]) + #'(make-contract + #:name 'coerce/stem? + #:projection (make-blame-handler coerce-proc 'can-be-stem?)))] + [(_ stem) + (with-syntax ([->stem (format-id stx "->~a" #'stem)]) + #'(make-coercion-contract stem ->stem))])) + + +(define-syntax (define+provide-coercion-contract stx) + (syntax-case stx () + [(_ stem) + (with-syntax ([coerce/stem? (format-id stx "coerce/~a?" #'stem)]) + #'(begin + (provide+safe coerce/stem?) + (define coerce/stem? (make-coercion-contract stem))))])) + + +(define+provide-coercion-contract int) +(define+provide-coercion-contract string) +(define+provide-coercion-contract symbol) +(define+provide-coercion-contract path) +(define+provide-coercion-contract boolean) +(define+provide-coercion-contract list) diff --git a/define.rkt b/define.rkt index 3c15665..fa7036a 100644 --- a/define.rkt +++ b/define.rkt @@ -1,96 +1,92 @@ #lang racket/base -(require (for-syntax racket/base)) -(require racket/contract) +(require (for-syntax racket/base racket/syntax syntax/strip-context) racket/contract) -(provide (all-from-out racket/contract)) -;; get gets of typed source file, recompile it without typing in a submodule, -;; then require those identifiers into the current level. -(define-syntax (require-via-wormhole stx) +(define-syntax (make-safe-module stx) (syntax-case stx () - [(_ path-spec) - (let ([mod-name (gensym)]) - ;; need to use stx as context to get correct require behavior - (datum->syntax stx `(begin - (module mod-name typed/racket/base/no-check - (require sugar/unstable/include) - (include-without-lang-line ,(syntax->datum #'path-spec))) - (require (quote mod-name)))))])) - -;; each define macro recursively converts any form of define -;; into its lambda form (define name body ...) and then operates on that. + [(_ [id contract]) + ;; need to put `racket/contract` inside calling location's context + (with-syntax ([require-racket-contract (datum->syntax #'id '(require racket/contract))]) + #'(module+ safe + require-racket-contract + (provide (contract-out [id contract]))))] + [(_ id) + #'(module+ safe + (provide id))])) -(define-syntax (make-safe-module stx) + +;; convert calling pattern to form (id contract body-exp) +(define-for-syntax (lambdafy-with-contract stx) (syntax-case stx () - [(_ name contract) - #'(module+ safe - (require racket/contract) - (provide (contract-out [name contract])))] - [(_ name) - #'(module+ safe - (provide name))])) + [(_ (id arg ... . rest-arg) contract body ...) + (replace-context #'id #'(id contract (λ (arg ... . rest-arg) body ...)))] + [(_ id contract lambda-exp) + (replace-context #'id #'(id contract lambda-exp))])) -(define-syntax (define+provide+safe stx) + +;; convert calling pattern to form (id body-exp) +(define-for-syntax (lambdafy stx) (syntax-case stx () - [(_ (proc arg ... . rest-arg) contract body ...) - #'(define+provide+safe proc contract - (λ(arg ... . rest-arg) body ...))] - [(_ name contract body ...) - #'(begin - (define name body ...) - (provide name) - (make-safe-module name contract))])) + [(_ (id arg ... . rest-arg) body ...) + (replace-context #'id #'(id (λ (arg ... . rest-arg) body ...)))] + [(_ id lambda-exp) + (replace-context #'id #'(id lambda-exp))])) + + +(define-syntax (define+provide+safe stx) + (with-syntax ([(id contract lambda-exp) (lambdafy-with-contract stx)]) + #'(begin + (define id lambda-exp) + (provide id) + (make-safe-module [id contract])))) + ;; for previously defined identifiers -;; takes args like (provide+safe [ident contract]) or just (provide+safe ident) +;; takes args like (provide+safe [id contract]) or just (provide+safe id) ;; any number of args. -(define-syntax (provide+safe stx) - (syntax-case stx () - [(_ items ...) - (datum->syntax stx - `(begin - ,@(for/list ([item (in-list (syntax->datum #'(items ...)))]) - (define-values (name contract) (if (pair? item) - (values (car item) (cadr item)) - (values item #f))) - `(begin - (provide ,name) - (make-safe-module ,name ,@(if contract (list contract) null))))))])) +(define-syntax-rule (provide+safe thing ...) + (begin + (provide+safe/once thing) ...)) + + +;; `provide+safe` might have interleaved ids or [id contract] args so handle them individually. +(define-syntax (provide+safe/once stx) + (with-syntax ([(id msm-arg) (syntax-case stx () + [(_ [id contract]) + #'(id [id contract])] + [(_ id) + #'(id id)])]) + #'(begin + (provide id) + (make-safe-module msm-arg)))) + (define-syntax (define+provide/contract stx) - (syntax-case stx () - [(_ (proc arg ... . rest-arg) contract body ...) - #'(define+provide/contract proc contract - (λ(arg ... . rest-arg) body ...))] - [(_ name contract body ...) - #'(begin - (provide (contract-out [name contract])) - (define name body ...))])) + (with-syntax* ([(id contract lambda-exp) (lambdafy-with-contract stx)] + [require-racket-contract (datum->syntax #'id '(require racket/contract))]) + #'(begin + require-racket-contract + (provide (contract-out [id contract])) + (define id lambda-exp)))) (define-syntax (define/contract+provide stx) - (syntax-case stx () - [(_ (proc arg ... . rest-arg) contract body ...) - #'(define/contract+provide proc contract - (λ(arg ... . rest-arg) body ...))] - [(_ name contract body ...) - #'(begin - (provide name) - (define/contract name contract body ...))])) + (with-syntax* ([(id contract lambda-exp) (lambdafy-with-contract stx)] + [require-racket-contract (datum->syntax #'id '(require racket/contract))]) + #'(begin + require-racket-contract + (provide id) + (define/contract id contract lambda-exp)))) (define-syntax (define+provide stx) - (syntax-case stx () - [(_ (proc arg ... . rest-arg) body ...) - #'(define+provide proc - (λ(arg ... . rest-arg) body ...))] - [(_ name body ...) - #'(begin - (provide name) - (define name body ...))])) - -(provide+safe require-via-wormhole - make-safe-module + (with-syntax ([(id lambda-exp) (lambdafy stx)]) + #'(begin + (provide id) + (define id lambda-exp)))) + + +(provide+safe make-safe-module define+provide+safe provide+safe define+provide/contract diff --git a/file.rkt b/file.rkt index 5bfd899..9a37eae 100644 --- a/file.rkt +++ b/file.rkt @@ -1,10 +1,10 @@ #lang racket/base -(require "define.rkt" racket/set "coerce.rkt" racket/path "unstable/string.rkt") +(require "define.rkt" "coerce/base.rkt" racket/path) ;; does path have a certain extension (define+provide+safe (has-ext? x ext) - (coerce/path? coerce/string? . -> . coerce/boolean?) + (pathish? stringish? . -> . boolean?) (define ext-of-path (filename-extension (->path x))) (->boolean (and ext-of-path (equal? (string-downcase (bytes->string/utf-8 ext-of-path)) (string-downcase (->string ext)))))) @@ -12,7 +12,7 @@ ;; get file extension as a string, or return #f ;; (consistent with filename-extension behavior) (define+provide+safe (get-ext x) - (coerce/path? . -> . (or/c #f string?)) + (pathish? . -> . (or/c #f string?)) (let ([fe-result (filename-extension (->path x))]) (and fe-result (bytes->string/utf-8 fe-result)))) @@ -24,20 +24,26 @@ (define+provide+safe (has-binary-ext? x) - (coerce/path? . -> . coerce/boolean?) + (pathish? . -> . boolean?) (let ([x (->path x)]) - (ormap (λ(ext) (has-ext? x ext)) binary-extensions))) + (and (ormap (λ(ext) (has-ext? x ext)) binary-extensions) #t))) ;; put extension on path ;; use local contract here because this function is used within module (define+provide+safe (add-ext x ext) - (coerce/string? coerce/string? . -> . coerce/path?) + (stringish? stringish? . -> . pathish?) (->path (string-append (->string x) "." (->string ext)))) + +(define (starts-with? str starter) + (define pat (regexp (format "^~a" (regexp-quote starter)))) + (and (regexp-match pat str) #t)) + + ;; take one extension off path (define+provide+safe (remove-ext x) - (coerce/path? . -> . path?) + (pathish? . -> . path?) ;; pass through hidden files (those starting with a dot) (let ([x (->path x)]) (if ((->string x) . starts-with? . ".") @@ -47,7 +53,7 @@ ;; take all extensions off path (define+provide+safe (remove-ext* x) - (coerce/path? . -> . path?) + (pathish? . -> . path?) ;; pass through hidden files (those starting with a dot) (let ([x (->path x)]) (if ((->string x) . starts-with? . ".") diff --git a/info.rkt b/info.rkt index 826d7b4..0b1dc1d 100644 --- a/info.rkt +++ b/info.rkt @@ -1,7 +1,7 @@ #lang info (define collection "sugar") -(define version "0.1") -(define deps '("base" "rackunit-lib")) +(define version "0.2") +(define deps '("base")) (define build-deps '("scribble-lib" "racket-doc")) (define scribblings '(("scribblings/sugar.scrbl" ()))) (define compile-omit-paths '("test")) \ No newline at end of file diff --git a/list.rkt b/list.rkt index ed135a5..3e3456c 100644 --- a/list.rkt +++ b/list.rkt @@ -1,12 +1,11 @@ #lang racket/base -(require (for-syntax racket/base) racket/list racket/set racket/function) -(require "unstable/len.rkt" "coerce.rkt" "define.rkt") +(require (for-syntax racket/base) racket/list "define.rkt") (define (list-of-lists? xs) (and (list? xs) (andmap list? xs))) (define (index? x) (and (integer? x) (not (negative? x)))) -(define increasing-nonnegative? (λ(xs) (apply < -1 xs))) -(define increasing-nonnegative-list? (and/c list? increasing-nonnegative?)) +(define increasing-nonnegative-list? (λ(x) (and (list? x) (or (empty? x) + (apply < -1 x))))) (define (integers? x) (and (list? x) (andmap integer? x))) @@ -65,7 +64,6 @@ (define+provide+safe (slice-at xs len [force? #f]) - ;; with polymorphic function, use cased typing to simulate optional position arguments ((list? (and/c integer? positive?)) (boolean?) . ->* . list-of-lists?) (define-values (last-list list-of-lists) (for/fold ([current-list empty][list-of-lists empty]) @@ -100,14 +98,20 @@ (hash-update! counter item (λ(v) (add1 v)) (λ _ 0))) counter) +(define (->list x) + (cond + [(list? x) x] + [(vector? x) (vector->list x)] + [(string? x) (string->list x)] + [else (error '->list)])) + (define+provide+safe (members-unique? x) - ((or/c list? vector? string?) . -> . boolean?) - (cond - [(list? x) (= (len (remove-duplicates x)) (len x))] - [(vector? x) (members-unique? (->list x))] - [(string? x) (members-unique? (string->list x))] - [else (error (format "members-unique? cannot be determined for ~a" x))])) + ((or/c list? vector? string?) . -> . boolean?) + (let ([x (->list x)]) + (cond + [(list? x) (= (length (remove-duplicates x)) (length x))] + [else (error (format "members-unique? cannot be determined for ~a" x))]))) (define+provide+safe (members-unique?/error x) @@ -116,7 +120,7 @@ (if (not result) (let* ([duplicate-keys (filter-not empty? (hash-map (frequency-hash (->list x)) (λ(element freq) (if (> freq 1) element '()))))]) - (error (string-append "members-unique? failed because " (if (= (len duplicate-keys) 1) + (error (string-append "members-unique? failed because " (if (= (length duplicate-keys) 1) "item isn't" "items aren't") " unique:") duplicate-keys)) result)) @@ -137,10 +141,12 @@ (define+provide+safe (break-at xs bps) - (list? (and/c coerce/list? (or/c empty? increasing-nonnegative-list?)) . -> . list-of-lists?) + (list? any/c . -> . list-of-lists?) (let ([bps (if (list? bps) bps (list bps))]) ; coerce bps to list (when (ormap (λ(bp) (>= bp (length xs))) bps) (error 'break-at (format "breakpoint in ~v is greater than or equal to input list length = ~a" bps (length xs)))) + (when (not (increasing-nonnegative-list? bps)) + (raise-argument-error 'break-at "increasing-nonnegative-list?" bps)) ;; easier to do back to front, because then the list index for each item won't change during the recursion ;; cons a zero onto bps (which may already start with zero) and then use that as the terminating condition ;; because breaking at zero means we've reached the start of the list diff --git a/main.rkt b/main.rkt index 404fe9f..75a659d 100644 --- a/main.rkt +++ b/main.rkt @@ -1,18 +1,19 @@ #lang racket/base -(define-syntax-rule (r+p modname) +(define-syntax-rule (r+p modname ...) (begin - (require modname) - (provide (all-from-out modname)) - (module+ safe - (require (submod modname safe)) - (provide (all-from-out (submod modname safe)))))) + (begin + (require modname) + (provide (all-from-out modname)) + (module+ safe + (require (submod modname safe)) + (provide (all-from-out (submod modname safe))))) ...)) -(r+p "cache.rkt") -(r+p "coerce.rkt") -(r+p "debug.rkt") -(r+p "define.rkt") -(r+p "file.rkt") -(r+p "list.rkt") -(r+p "test.rkt") -(r+p "xml.rkt") \ No newline at end of file +(r+p "cache.rkt" + "coerce.rkt" + "debug.rkt" + "define.rkt" + "file.rkt" + "list.rkt" + "test.rkt" + "xml.rkt") \ No newline at end of file diff --git a/unstable/len.rkt b/unstable/len.rkt index 1d948c4..516e178 100644 --- a/unstable/len.rkt +++ b/unstable/len.rkt @@ -1,8 +1,8 @@ #lang racket/base -(require "../define.rkt" racket/set racket/sequence) +(require "../define.rkt" racket/sequence) (define+provide+safe (len x) - ((or/c list? vector? set? sequence? string? symbol? path? hash?) . -> . integer?) + ((or/c list? vector? sequence? string? symbol? path? hash?) . -> . integer?) (cond [(list? x) (length x)] [(string? x) (string-length x)] @@ -10,13 +10,12 @@ [(path? x) (len (path->string x))] [(vector? x) (vector-length x)] [(hash? x) (len (hash-keys x))] - [(set? x) (len (set->list x))] [(and (sequence? x) (not (integer? x))) (len (sequence->list x))] [else (error "len: can't calculate length of" x)])) (module+ test - (require rackunit) + (require rackunit racket/set) (check-equal? (len '(1 2 3)) 3) (check-not-equal? (len '(1 2)) 3) ; len 2 (check-equal? (len "foo") 3) diff --git a/xml.rkt b/xml.rkt index 4ed4a5f..22dfeef 100644 --- a/xml.rkt +++ b/xml.rkt @@ -4,12 +4,15 @@ (define+provide+safe (xml-string->xexprs str) (string? . -> . (values xexpr? xexpr?)) - (define xml-doc (with-input-from-string str (λ _ (permissive-xexprs #t) (read-xml)))) + (define xml-doc (with-input-from-string str + (λ () (permissive-xexprs #t) (read-xml)))) (values (xml->xexpr (document-prolog xml-doc)) (xml->xexpr (document-element xml-doc)))) + (define+provide+safe (xexprs->xml-string prolog-xexpr root-xexpr) (xexpr? xexpr? . -> . string?) - (with-output-to-string (λ _ (write-xml (document (xexpr->xml prolog-xexpr) (xexpr->xml root-xexpr) null))))) + (with-output-to-string (λ () (write-xml (document (xexpr->xml prolog-xexpr) (xexpr->xml root-xexpr) null))))) + (module+ test (require rackunit) @@ -18,4 +21,4 @@ (define-values (str-prolog str-doc) (xml-string->xexprs str)) (check-equal? str-prolog (prolog (list (p-i (location 1 0 1) (location 1 38 39) 'xml "version=\"1.0\" encoding=\"utf-8\"")) #f null)) (check-equal? str-doc '(root () "hello world")) - (check-equal? (xexprs->xml-string str-prolog str-doc) str)) \ No newline at end of file + (check-equal? (xexprs->xml-string str-prolog str-doc) str))