mbutterick
/
sugar
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

simplify

Browse Source
pull/17/head v0.2
Matthew Butterick 8 years ago
parent 90f7eef3e8
commit 2c59ab3974
11 changed files with 314 additions and 286 deletions
Show Stats Download Patch File Download Diff File

19
cache.rkt
Unescape Escape View File

@ -1,17 +1,24 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base) "define.rkt") (require (for-syntax racket/base) "define.rkt")
(define+provide+safe (make-caching-proc base-proc) (define+provide+safe (make-caching-proc base-proc)
(procedure? . -> . procedure?) (procedure? . -> . procedure?)
(let ([cache (make-hash)]) (let ([cache (make-hash)])
(make-keyword-procedure (make-keyword-procedure
(λ (kws kw-args . args) (λ (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) (provide+safe define/caching)
(define-syntax (define/caching stx) (define-syntax (define/caching stx)
(syntax-case stx () (with-syntax ([(id lambda-expr) (lambdafy stx)])
[(_ (name arg ... . rest-arg) body ...) #'(define id (make-caching-proc lambda-expr))))
#'(define/caching name (λ(arg ... . rest-arg) body ...))]
[(_ name body ...)
#'(define name (make-caching-proc body ...))]))

171
coerce.rkt
Unescape Escape View File

@ -1,165 +1,12 @@
#lang racket/base #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) (define-syntax-rule (r+p modname ...)
(λ(e) (error (string->symbol (format "->~a" target-format)) (format "Can't convert ~s to ~a" x target-format)))) (begin
(begin
(require modname)
(provide (all-from-out modname))
(module+ safe
(require (submod modname safe))
(provide (all-from-out (submod modname safe))))) ...))
(r+p "coerce/base.rkt" "coerce/contract.rkt")
(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)

119
coerce/base.rkt
Unescape Escape View File

@ -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)

44
coerce/contract.rkt
Unescape Escape View File

@ -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)

144
define.rkt
Unescape Escape View File

@ -1,96 +1,92 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base)) (require (for-syntax racket/base racket/syntax syntax/strip-context) racket/contract)
(require racket/contract)
(provide (all-from-out racket/contract))
;; get gets of typed source file, recompile it without typing in a submodule, (define-syntax (make-safe-module stx)
;; then require those identifiers into the current level.
(define-syntax (require-via-wormhole stx)
(syntax-case stx () (syntax-case stx ()
[(_ path-spec) [(_ [id contract])
(let ([mod-name (gensym)]) ;; need to put `racket/contract` inside calling location's context
;; need to use stx as context to get correct require behavior (with-syntax ([require-racket-contract (datum->syntax #'id '(require racket/contract))])
(datum->syntax stx `(begin #'(module+ safe
(module mod-name typed/racket/base/no-check require-racket-contract
(require sugar/unstable/include) (provide (contract-out [id contract]))))]
(include-without-lang-line ,(syntax->datum #'path-spec))) [(_ id)
(require (quote mod-name)))))])) #'(module+ safe
(provide id))]))
;; each define macro recursively converts any form of define
;; into its lambda form (define name body ...) and then operates on that.
(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 () (syntax-case stx ()
[(_ name contract) [(_ (id arg ... . rest-arg) contract body ...)
#'(module+ safe (replace-context #'id #'(id contract (λ (arg ... . rest-arg) body ...)))]
(require racket/contract) [(_ id contract lambda-exp)
(provide (contract-out [name contract])))] (replace-context #'id #'(id contract lambda-exp))]))
[(_ name)
#'(module+ safe
(provide name))]))
(define-syntax (define+provide+safe stx)
;; convert calling pattern to form (id body-exp)
(define-for-syntax (lambdafy stx)
(syntax-case stx () (syntax-case stx ()
[(_ (proc arg ... . rest-arg) contract body ...) [(_ (id arg ... . rest-arg) body ...)
#'(define+provide+safe proc contract (replace-context #'id #'(id (λ (arg ... . rest-arg) body ...)))]
(λ(arg ... . rest-arg) body ...))] [(_ id lambda-exp)
[(_ name contract body ...) (replace-context #'id #'(id lambda-exp))]))
#'(begin
(define name body ...)
(provide name) (define-syntax (define+provide+safe stx)
(make-safe-module name contract))])) (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 ;; 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. ;; any number of args.
(define-syntax (provide+safe stx) (define-syntax-rule (provide+safe thing ...)
(syntax-case stx () (begin
[(_ items ...) (provide+safe/once thing) ...))
(datum->syntax stx
`(begin
,@(for/list ([item (in-list (syntax->datum #'(items ...)))]) ;; `provide+safe` might have interleaved ids or [id contract] args so handle them individually.
(define-values (name contract) (if (pair? item) (define-syntax (provide+safe/once stx)
(values (car item) (cadr item)) (with-syntax ([(id msm-arg) (syntax-case stx ()
(values item #f))) [(_ [id contract])
`(begin #'(id [id contract])]
(provide ,name) [(_ id)
(make-safe-module ,name ,@(if contract (list contract) null))))))])) #'(id id)])])
#'(begin
(provide id)
(make-safe-module msm-arg))))
(define-syntax (define+provide/contract stx) (define-syntax (define+provide/contract stx)
(syntax-case stx () (with-syntax* ([(id contract lambda-exp) (lambdafy-with-contract stx)]
[(_ (proc arg ... . rest-arg) contract body ...) [require-racket-contract (datum->syntax #'id '(require racket/contract))])
#'(define+provide/contract proc contract #'(begin
(λ(arg ... . rest-arg) body ...))] require-racket-contract
[(_ name contract body ...) (provide (contract-out [id contract]))
#'(begin (define id lambda-exp))))
(provide (contract-out [name contract]))
(define name body ...))]))
(define-syntax (define/contract+provide stx) (define-syntax (define/contract+provide stx)
(syntax-case stx () (with-syntax* ([(id contract lambda-exp) (lambdafy-with-contract stx)]
[(_ (proc arg ... . rest-arg) contract body ...) [require-racket-contract (datum->syntax #'id '(require racket/contract))])
#'(define/contract+provide proc contract #'(begin
(λ(arg ... . rest-arg) body ...))] require-racket-contract
[(_ name contract body ...) (provide id)
#'(begin (define/contract id contract lambda-exp))))
(provide name)
(define/contract name contract body ...))]))
(define-syntax (define+provide stx) (define-syntax (define+provide stx)
(syntax-case stx () (with-syntax ([(id lambda-exp) (lambdafy stx)])
[(_ (proc arg ... . rest-arg) body ...) #'(begin
#'(define+provide proc (provide id)
(λ(arg ... . rest-arg) body ...))] (define id lambda-exp))))
[(_ name body ...)
#'(begin
(provide name) (provide+safe make-safe-module
(define name body ...))]))
(provide+safe require-via-wormhole
make-safe-module
define+provide+safe define+provide+safe
provide+safe provide+safe
define+provide/contract define+provide/contract

22
file.rkt
Unescape Escape View File

@ -1,10 +1,10 @@
#lang racket/base #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 ;; does path have a certain extension
(define+provide+safe (has-ext? x ext) (define+provide+safe (has-ext? x ext)
(coerce/path? coerce/string? . -> . coerce/boolean?) (pathish? stringish? . -> . boolean?)
(define ext-of-path (filename-extension (->path x))) (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)))))) (->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 ;; get file extension as a string, or return #f
;; (consistent with filename-extension behavior) ;; (consistent with filename-extension behavior)
(define+provide+safe (get-ext x) (define+provide+safe (get-ext x)
(coerce/path? . -> . (or/c #f string?)) (pathish? . -> . (or/c #f string?))
(let ([fe-result (filename-extension (->path x))]) (let ([fe-result (filename-extension (->path x))])
(and fe-result (bytes->string/utf-8 fe-result)))) (and fe-result (bytes->string/utf-8 fe-result))))
@ -24,20 +24,26 @@
(define+provide+safe (has-binary-ext? x) (define+provide+safe (has-binary-ext? x)
(coerce/path? . -> . coerce/boolean?) (pathish? . -> . boolean?)
(let ([x (->path x)]) (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 ;; put extension on path
;; use local contract here because this function is used within module ;; use local contract here because this function is used within module
(define+provide+safe (add-ext x ext) (define+provide+safe (add-ext x ext)
(coerce/string? coerce/string? . -> . coerce/path?) (stringish? stringish? . -> . pathish?)
(->path (string-append (->string x) "." (->string ext)))) (->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 ;; take one extension off path
(define+provide+safe (remove-ext x) (define+provide+safe (remove-ext x)
(coerce/path? . -> . path?) (pathish? . -> . path?)
;; pass through hidden files (those starting with a dot) ;; pass through hidden files (those starting with a dot)
(let ([x (->path x)]) (let ([x (->path x)])
(if ((->string x) . starts-with? . ".") (if ((->string x) . starts-with? . ".")
@ -47,7 +53,7 @@
;; take all extensions off path ;; take all extensions off path
(define+provide+safe (remove-ext* x) (define+provide+safe (remove-ext* x)
(coerce/path? . -> . path?) (pathish? . -> . path?)
;; pass through hidden files (those starting with a dot) ;; pass through hidden files (those starting with a dot)
(let ([x (->path x)]) (let ([x (->path x)])
(if ((->string x) . starts-with? . ".") (if ((->string x) . starts-with? . ".")

4
info.rkt
Unescape Escape View File

@ -1,7 +1,7 @@
#lang info #lang info
(define collection "sugar") (define collection "sugar")
(define version "0.1") (define version "0.2")
(define deps '("base" "rackunit-lib")) (define deps '("base"))
(define build-deps '("scribble-lib" "racket-doc")) (define build-deps '("scribble-lib" "racket-doc"))
(define scribblings '(("scribblings/sugar.scrbl" ()))) (define scribblings '(("scribblings/sugar.scrbl" ())))
(define compile-omit-paths '("test")) (define compile-omit-paths '("test"))

32
list.rkt
Unescape Escape View File

@ -1,12 +1,11 @@
#lang racket/base #lang racket/base
(require (for-syntax racket/base) racket/list racket/set racket/function) (require (for-syntax racket/base) racket/list "define.rkt")
(require "unstable/len.rkt" "coerce.rkt" "define.rkt")
(define (list-of-lists? xs) (and (list? xs) (andmap list? xs))) (define (list-of-lists? xs) (and (list? xs) (andmap list? xs)))
(define (index? x) (and (integer? x) (not (negative? x)))) (define (index? x) (and (integer? x) (not (negative? x))))
(define increasing-nonnegative? (λ(xs) (apply < -1 xs))) (define increasing-nonnegative-list? (λ(x) (and (list? x) (or (empty? x)
(define increasing-nonnegative-list? (and/c list? increasing-nonnegative?)) (apply < -1 x)))))
(define (integers? x) (and (list? x) (andmap integer? x))) (define (integers? x) (and (list? x) (andmap integer? x)))
@ -65,7 +64,6 @@
(define+provide+safe (slice-at xs len [force? #f]) (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?) ((list? (and/c integer? positive?)) (boolean?) . ->* . list-of-lists?)
(define-values (last-list list-of-lists) (define-values (last-list list-of-lists)
(for/fold ([current-list empty][list-of-lists empty]) (for/fold ([current-list empty][list-of-lists empty])
@ -100,14 +98,20 @@
(hash-update! counter item (λ(v) (add1 v)) (λ _ 0))) (hash-update! counter item (λ(v) (add1 v)) (λ _ 0)))
counter) 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) (define+provide+safe (members-unique? x)
((or/c list? vector? string?) . -> . boolean?) ((or/c list? vector? string?) . -> . boolean?)
(cond (let ([x (->list x)])
[(list? x) (= (len (remove-duplicates x)) (len x))] (cond
[(vector? x) (members-unique? (->list x))] [(list? x) (= (length (remove-duplicates x)) (length x))]
[(string? x) (members-unique? (string->list x))] [else (error (format "members-unique? cannot be determined for ~a" x))])))
[else (error (format "members-unique? cannot be determined for ~a" x))]))
(define+provide+safe (members-unique?/error x) (define+provide+safe (members-unique?/error x)
@ -116,7 +120,7 @@
(if (not result) (if (not result)
(let* ([duplicate-keys (filter-not empty? (hash-map (frequency-hash (->list x)) (let* ([duplicate-keys (filter-not empty? (hash-map (frequency-hash (->list x))
(λ(element freq) (if (> freq 1) element '()))))]) (λ(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" "item isn't"
"items aren't") " unique:") duplicate-keys)) "items aren't") " unique:") duplicate-keys))
result)) result))
@ -137,10 +141,12 @@
(define+provide+safe (break-at xs bps) (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 (let ([bps (if (list? bps) bps (list bps))]) ; coerce bps to list
(when (ormap (λ(bp) (>= bp (length xs))) bps) (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)))) (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 ;; 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 ;; 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 ;; because breaking at zero means we've reached the start of the list

29
main.rkt
Unescape Escape View File

@ -1,18 +1,19 @@
#lang racket/base #lang racket/base
(define-syntax-rule (r+p modname) (define-syntax-rule (r+p modname ...)
(begin (begin
(require modname) (begin
(provide (all-from-out modname)) (require modname)
(module+ safe (provide (all-from-out modname))
(require (submod modname safe)) (module+ safe
(provide (all-from-out (submod modname safe)))))) (require (submod modname safe))
(provide (all-from-out (submod modname safe))))) ...))
(r+p "cache.rkt") (r+p "cache.rkt"
(r+p "coerce.rkt") "coerce.rkt"
(r+p "debug.rkt") "debug.rkt"
(r+p "define.rkt") "define.rkt"
(r+p "file.rkt") "file.rkt"
(r+p "list.rkt") "list.rkt"
(r+p "test.rkt") "test.rkt"
(r+p "xml.rkt") "xml.rkt")

7
unstable/len.rkt
Unescape Escape View File

@ -1,8 +1,8 @@
#lang racket/base #lang racket/base
(require "../define.rkt" racket/set racket/sequence) (require "../define.rkt" racket/sequence)
(define+provide+safe (len x) (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 (cond
[(list? x) (length x)] [(list? x) (length x)]
[(string? x) (string-length x)] [(string? x) (string-length x)]
@ -10,13 +10,12 @@
[(path? x) (len (path->string x))] [(path? x) (len (path->string x))]
[(vector? x) (vector-length x)] [(vector? x) (vector-length x)]
[(hash? x) (len (hash-keys x))] [(hash? x) (len (hash-keys x))]
[(set? x) (len (set->list x))]
[(and (sequence? x) (not (integer? x))) (len (sequence->list x))] [(and (sequence? x) (not (integer? x))) (len (sequence->list x))]
[else (error "len: can't calculate length of" x)])) [else (error "len: can't calculate length of" x)]))
(module+ test (module+ test
(require rackunit) (require rackunit racket/set)
(check-equal? (len '(1 2 3)) 3) (check-equal? (len '(1 2 3)) 3)
(check-not-equal? (len '(1 2)) 3) ; len 2 (check-not-equal? (len '(1 2)) 3) ; len 2
(check-equal? (len "foo") 3) (check-equal? (len "foo") 3)

9
xml.rkt
Unescape Escape View File

@ -4,12 +4,15 @@
(define+provide+safe (xml-string->xexprs str) (define+provide+safe (xml-string->xexprs str)
(string? . -> . (values xexpr? xexpr?)) (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)))) (values (xml->xexpr (document-prolog xml-doc)) (xml->xexpr (document-element xml-doc))))
(define+provide+safe (xexprs->xml-string prolog-xexpr root-xexpr) (define+provide+safe (xexprs->xml-string prolog-xexpr root-xexpr)
(xexpr? xexpr? . -> . string?) (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 (module+ test
(require rackunit) (require rackunit)
@ -18,4 +21,4 @@
(define-values (str-prolog str-doc) (xml-string->xexprs str)) (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-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? str-doc '(root () "hello world"))
(check-equal? (xexprs->xml-string str-prolog str-doc) str)) (check-equal? (xexprs->xml-string str-prolog str-doc) str))

Write Preview
Loading…
Cancel
Save