add typed/sugar
parent
9136e061b6
commit
e34c67adc2
@ -1,16 +0,0 @@
|
|||||||
#lang racket/base
|
|
||||||
(require (for-syntax racket/base) racket/contract)
|
|
||||||
(provide (all-defined-out))
|
|
||||||
|
|
||||||
(define/contract (make-caching-proc base-proc)
|
|
||||||
(procedure? . -> . procedure?)
|
|
||||||
(let ([cache (make-hash)])
|
|
||||||
(λ args
|
|
||||||
(hash-ref! cache args (λ () (apply base-proc args))))))
|
|
||||||
|
|
||||||
(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 ...))]))
|
|
@ -1,52 +0,0 @@
|
|||||||
#lang racket/base
|
|
||||||
(require (for-syntax racket/base))
|
|
||||||
(require racket/contract)
|
|
||||||
|
|
||||||
(provide (all-defined-out) (all-from-out racket/contract))
|
|
||||||
|
|
||||||
;; each define macro recursively converts any form of define
|
|
||||||
;; into its lambda form (define name body ...) and then operates on that.
|
|
||||||
|
|
||||||
(define-syntax (define+provide+safe 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)
|
|
||||||
(module+ safe
|
|
||||||
(provide (contract-out [name contract]))))]))
|
|
||||||
|
|
||||||
(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 ...))]))
|
|
||||||
|
|
||||||
|
|
||||||
(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 ...))]))
|
|
||||||
|
|
||||||
|
|
||||||
(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 ...))]))
|
|
@ -1,55 +0,0 @@
|
|||||||
#lang racket/base
|
|
||||||
(require "define.rkt" "coerce.rkt" "string.rkt" racket/path)
|
|
||||||
|
|
||||||
(define+provide/contract (get-enclosing-dir p)
|
|
||||||
(coerce/path? . -> . path?)
|
|
||||||
(simplify-path (build-path p 'up)))
|
|
||||||
|
|
||||||
;; does path have a certain extension
|
|
||||||
(define+provide/contract (has-ext? x ext)
|
|
||||||
(coerce/path? coerce/string? . -> . coerce/boolean?)
|
|
||||||
(define ext-of-path (filename-extension x))
|
|
||||||
(and ext-of-path (equal? (string-downcase (bytes->string/utf-8 ext-of-path)) (string-downcase ext))))
|
|
||||||
|
|
||||||
;; get file extension as a string, or return #f
|
|
||||||
;; (consistent with filename-extension behavior)
|
|
||||||
(define+provide/contract (get-ext x)
|
|
||||||
(coerce/path? . -> . (or/c #f string?))
|
|
||||||
(let ([fe-result (filename-extension x)])
|
|
||||||
(and fe-result (bytes->string/utf-8 fe-result))))
|
|
||||||
|
|
||||||
|
|
||||||
;; todo: add extensions
|
|
||||||
(define binary-extensions
|
|
||||||
(map ->string '(gif jpg jpeg mp3 png zip pdf ico tar ai eps exe)))
|
|
||||||
|
|
||||||
(define+provide/contract (has-binary-ext? x)
|
|
||||||
(coerce/path? . -> . coerce/boolean?)
|
|
||||||
(ormap (λ(ext) (has-ext? x ext)) binary-extensions))
|
|
||||||
|
|
||||||
;; put extension on path
|
|
||||||
;; use local contract here because this function is used within module
|
|
||||||
(define/contract+provide (add-ext x ext)
|
|
||||||
(coerce/string? coerce/string? . -> . coerce/path?)
|
|
||||||
(string-append x "." ext))
|
|
||||||
|
|
||||||
;; take one extension off path
|
|
||||||
(define+provide/contract (remove-ext x)
|
|
||||||
(coerce/path? . -> . path?)
|
|
||||||
;; pass through hidden files (those starting with a dot)
|
|
||||||
(if (x . starts-with? . ".")
|
|
||||||
x
|
|
||||||
(path-replace-suffix x "")))
|
|
||||||
|
|
||||||
|
|
||||||
;; take all extensions off path
|
|
||||||
(define+provide/contract (remove-ext* x)
|
|
||||||
(coerce/path? . -> . path?)
|
|
||||||
;; pass through hidden files (those starting with a dot)
|
|
||||||
(if (x . starts-with? . ".")
|
|
||||||
x
|
|
||||||
(let ([path-with-removed-ext (remove-ext x)])
|
|
||||||
(if (equal? x path-with-removed-ext)
|
|
||||||
x
|
|
||||||
(remove-ext* path-with-removed-ext)))))
|
|
||||||
|
|
@ -1,6 +1,6 @@
|
|||||||
#lang info
|
#lang info
|
||||||
(define collection "sugar")
|
(define collection 'multi)
|
||||||
(define deps '("base"))
|
(define deps '("base"
|
||||||
(define build-deps '("scribble-lib"))
|
"typed-racket-lib"
|
||||||
(define scribblings '(("scribblings/sugar.scrbl" ())))
|
"typed-racket-more"))
|
||||||
(define compile-omit-paths '("test"))
|
(define build-deps '("scribble-lib"))
|
@ -1,16 +0,0 @@
|
|||||||
#lang racket/base
|
|
||||||
(require "define.rkt" "coerce.rkt")
|
|
||||||
|
|
||||||
(define+provide/contract (starts-with? str starter)
|
|
||||||
(coerce/string? coerce/string? . -> . coerce/boolean?)
|
|
||||||
(and (<= (string-length starter) (string-length str))
|
|
||||||
(equal? (substring str 0 (string-length starter)) starter)))
|
|
||||||
|
|
||||||
(define+provide/contract (ends-with? str ender)
|
|
||||||
(coerce/string? coerce/string? . -> . coerce/boolean?)
|
|
||||||
(and (<= (string-length ender) (string-length str))
|
|
||||||
(equal? (substring str (- (string-length str) (string-length ender)) (string-length str)) ender)))
|
|
||||||
|
|
||||||
(define+provide/contract (capitalized? str)
|
|
||||||
(coerce/string? . -> . coerce/boolean?)
|
|
||||||
(char-upper-case? (car (string->list str))))
|
|
@ -0,0 +1,6 @@
|
|||||||
|
#lang racket/base
|
||||||
|
(require sugar/define)
|
||||||
|
(require-via-wormhole "../typed/sugar/cache.rkt")
|
||||||
|
|
||||||
|
(provide+safe [make-caching-proc (procedure? . -> . procedure?)]
|
||||||
|
define/caching)
|
@ -0,0 +1,78 @@
|
|||||||
|
#lang racket/base
|
||||||
|
(require (for-syntax racket/base racket/syntax) sugar/define net/url)
|
||||||
|
|
||||||
|
(require-via-wormhole "../typed/sugar/coerce.rkt")
|
||||||
|
|
||||||
|
|
||||||
|
(provide+safe [->int (any/c . -> . integer?)]
|
||||||
|
[->string (any/c . -> . string?)]
|
||||||
|
[->symbol (any/c . -> . symbol?)]
|
||||||
|
[->path (any/c . -> . path?)]
|
||||||
|
[->complete-path (any/c . -> . complete-path?)]
|
||||||
|
[->url (any/c . -> . url?)]
|
||||||
|
[->list (any/c . -> . list?)]
|
||||||
|
[->vector (any/c . -> . vector?)]
|
||||||
|
[->boolean (any/c . -> . boolean?)])
|
||||||
|
|
||||||
|
|
||||||
|
;; 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)
|
@ -0,0 +1,5 @@
|
|||||||
|
#lang racket/base
|
||||||
|
(require sugar/define)
|
||||||
|
(require-via-wormhole "../typed/sugar/debug.rkt")
|
||||||
|
|
||||||
|
(provide+safe report report-apply report* repeat time-repeat time-repeat* compare)
|
@ -0,0 +1,98 @@
|
|||||||
|
#lang racket/base
|
||||||
|
(require (for-syntax racket/base))
|
||||||
|
(require 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)
|
||||||
|
(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/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.
|
||||||
|
|
||||||
|
(define-syntax (make-safe-module stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ name contract)
|
||||||
|
#'(module+ safe
|
||||||
|
(require racket/contract)
|
||||||
|
(provide (contract-out [name contract])))]
|
||||||
|
[(_ name)
|
||||||
|
#'(module+ safe
|
||||||
|
(provide name))]))
|
||||||
|
|
||||||
|
(define-syntax (define+provide+safe 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))]))
|
||||||
|
|
||||||
|
;; for previously defined identifiers
|
||||||
|
;; takes args like (provide+safe [ident contract]) or just (provide+safe ident)
|
||||||
|
;; 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 (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 ...))]))
|
||||||
|
|
||||||
|
|
||||||
|
(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 ...))]))
|
||||||
|
|
||||||
|
|
||||||
|
(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
|
||||||
|
define+provide+safe
|
||||||
|
provide+safe
|
||||||
|
define+provide/contract
|
||||||
|
define/contract+provide
|
||||||
|
define+provide)
|
@ -0,0 +1,14 @@
|
|||||||
|
#lang racket/base
|
||||||
|
(require sugar/define racket/set sugar/coerce)
|
||||||
|
(require-via-wormhole "../typed/sugar/file.rkt")
|
||||||
|
|
||||||
|
(provide+safe
|
||||||
|
[get-enclosing-dir (coerce/path? . -> . path?)]
|
||||||
|
[has-ext? (coerce/path? coerce/string? . -> . coerce/boolean?)]
|
||||||
|
[get-ext (coerce/path? . -> . (or/c #f string?))]
|
||||||
|
binary-extensions
|
||||||
|
[has-binary-ext? (coerce/path? . -> . coerce/boolean?)]
|
||||||
|
[add-ext (coerce/string? coerce/string? . -> . coerce/path?)]
|
||||||
|
[remove-ext (coerce/path? . -> . path?)]
|
||||||
|
[remove-ext* (coerce/path? . -> . path?)])
|
||||||
|
|
@ -0,0 +1,4 @@
|
|||||||
|
#lang info
|
||||||
|
(define scribblings '(("scribblings/sugar.scrbl" ())))
|
||||||
|
|
||||||
|
(define compile-omit-paths '("test"))
|
@ -0,0 +1,5 @@
|
|||||||
|
#lang racket/base
|
||||||
|
(require sugar/define racket/set)
|
||||||
|
(require-via-wormhole "../typed/sugar/len.rkt")
|
||||||
|
|
||||||
|
(provide+safe [len ((or/c list? vector? set? sequence? string? symbol? path? hash?) . -> . integer?)])
|
@ -0,0 +1,39 @@
|
|||||||
|
#lang racket/base
|
||||||
|
(require (for-syntax racket/base)
|
||||||
|
racket/list racket/set racket/function sugar/define)
|
||||||
|
(require "len.rkt" "coerce.rkt")
|
||||||
|
|
||||||
|
(require-via-wormhole "../typed/sugar/list.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 (integers? x) (and (list? x) (andmap integer? x)))
|
||||||
|
|
||||||
|
(provide+safe [trimf (list? procedure? . -> . list?)]
|
||||||
|
[slicef-at ((list? procedure?) (boolean?) . ->* . list-of-lists?)]
|
||||||
|
[slicef-after (list? procedure? . -> . list-of-lists?)]
|
||||||
|
[slice-at ((list? (and/c integer? positive?)) (boolean?) . ->* . list-of-lists?)]
|
||||||
|
[filter-split (list? predicate/c . -> . list-of-lists?)]
|
||||||
|
[frequency-hash (list? . -> . hash?)]
|
||||||
|
[members-unique? ((or/c list? vector? string?) . -> . boolean?)]
|
||||||
|
[members-unique?/error ((or/c list? vector? string?) . -> . boolean?)]
|
||||||
|
when/splice
|
||||||
|
values->list
|
||||||
|
[sublist (list? index? index? . -> . list?)]
|
||||||
|
[break-at (list? (and/c coerce/list? (or/c empty? increasing-nonnegative-list?)) . -> . list-of-lists?)]
|
||||||
|
[shift ((list? (or/c integer? integers?)) (any/c boolean?) . ->* . list?)]
|
||||||
|
[shift/values ((list? (or/c integer? integers?)) (any/c) . ->* . any)])
|
||||||
|
|
||||||
|
|
||||||
|
;; todo: can this work in typed context? couldn't figure out how to polymorphically `apply values`
|
||||||
|
;; macro doesn't work either
|
||||||
|
(define (shift/values xs shift-amount-or-amounts [fill-item #f])
|
||||||
|
(apply (if (list? shift-amount-or-amounts)
|
||||||
|
values
|
||||||
|
(λ xs xs))
|
||||||
|
(shift xs shift-amount-or-amounts fill-item)))
|
||||||
|
|
@ -0,0 +1,5 @@
|
|||||||
|
#lang racket/base
|
||||||
|
(require sugar/define racket/set sugar/coerce)
|
||||||
|
(require-via-wormhole "../typed/sugar/misc.rkt")
|
||||||
|
|
||||||
|
(provide+safe [bytecount->string (integer? . -> . string?)])
|
@ -0,0 +1,7 @@
|
|||||||
|
#lang racket/base
|
||||||
|
(require sugar/define racket/set sugar/coerce)
|
||||||
|
(require-via-wormhole "../typed/sugar/string.rkt")
|
||||||
|
|
||||||
|
(provide+safe [starts-with? (coerce/string? coerce/string? . -> . coerce/boolean?)]
|
||||||
|
[ends-with? (coerce/string? coerce/string? . -> . coerce/boolean?)]
|
||||||
|
[capitalized? (coerce/string? . -> . coerce/boolean?)])
|
@ -0,0 +1,29 @@
|
|||||||
|
#lang racket/base
|
||||||
|
(require rackunit)
|
||||||
|
|
||||||
|
(module trb typed/racket/base
|
||||||
|
(require typed/sugar/list typed/rackunit)
|
||||||
|
(provide (all-defined-out))
|
||||||
|
;; (trimf odd? '(1 2 3)) ; type error
|
||||||
|
(define foo (trimf '(1 2 3) odd?))
|
||||||
|
(check-equal? foo '(2)))
|
||||||
|
|
||||||
|
(module rb racket/base
|
||||||
|
(require (submod sugar/list safe) rackunit)
|
||||||
|
(provide (all-defined-out))
|
||||||
|
(check-exn exn:fail:contract? (λ _ (trimf odd? '(1 2 3)))) ; fails at trimf
|
||||||
|
(define foo (trimf '(1 2 3) odd?))
|
||||||
|
(check-equal? foo '(2)))
|
||||||
|
|
||||||
|
(module rbu racket/base
|
||||||
|
(require sugar/list rackunit)
|
||||||
|
(provide (all-defined-out))
|
||||||
|
(check-exn exn:fail:contract? (λ _ (trimf odd? '(1 2 3)))) ; fails at dropf
|
||||||
|
(define foo (trimf '(1 2 3) odd?))
|
||||||
|
(check-equal? foo '(2)))
|
||||||
|
|
||||||
|
(require (prefix-in trb: 'trb))
|
||||||
|
(require (prefix-in rb: 'rb))
|
||||||
|
(require (prefix-in rbu: 'rbu))
|
||||||
|
|
||||||
|
(check-true (andmap (λ(val) (equal? val '(2))) (list trb:foo rb:foo rbu:foo)))
|
@ -0,0 +1,17 @@
|
|||||||
|
#lang typed/racket/base
|
||||||
|
|
||||||
|
(define-syntax-rule (r/p name)
|
||||||
|
(begin
|
||||||
|
(require name)
|
||||||
|
(provide (all-from-out name))))
|
||||||
|
|
||||||
|
(r/p "sugar/cache.rkt")
|
||||||
|
(r/p "sugar/coerce.rkt")
|
||||||
|
(r/p "sugar/debug.rkt")
|
||||||
|
(r/p "sugar/define.rkt")
|
||||||
|
(r/p "sugar/file.rkt")
|
||||||
|
(r/p "sugar/len.rkt")
|
||||||
|
(r/p "sugar/list.rkt")
|
||||||
|
(r/p "sugar/misc.rkt")
|
||||||
|
(r/p "sugar/string.rkt")
|
||||||
|
(r/p "sugar/test.rkt")
|
@ -0,0 +1,16 @@
|
|||||||
|
#lang typed/racket/base
|
||||||
|
(require (for-syntax typed/racket/base) typed/sugar/define)
|
||||||
|
|
||||||
|
(define/typed+provide (make-caching-proc base-proc)
|
||||||
|
(All (A B) (A * -> B) -> (A * -> B))
|
||||||
|
(let ([cache ((inst make-hash (Listof A) B))])
|
||||||
|
(λ args
|
||||||
|
(hash-ref! cache args (λ () (apply base-proc args))))))
|
||||||
|
|
||||||
|
(provide 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 ...))]))
|
@ -1,4 +1,4 @@
|
|||||||
#lang racket/base
|
#lang typed/racket/base
|
||||||
(require (for-syntax racket/base racket/syntax))
|
(require (for-syntax racket/base racket/syntax))
|
||||||
|
|
||||||
(provide (all-defined-out))
|
(provide (all-defined-out))
|
@ -0,0 +1,39 @@
|
|||||||
|
#lang typed/racket/base/no-check
|
||||||
|
;; use of no-check is deliberate here.
|
||||||
|
;; these helper macros don't do any type checking, just rearranging
|
||||||
|
;; they can't be combined with the untyped define macros, however
|
||||||
|
;; because the -> symbol is defined differently here
|
||||||
|
(require (for-syntax typed/racket/base racket/syntax))
|
||||||
|
(provide (all-defined-out))
|
||||||
|
|
||||||
|
(define-syntax (define/typed stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ (proc-name arg ... . rest-arg) type-expr body ...)
|
||||||
|
#'(define/typed proc-name type-expr
|
||||||
|
(λ(arg ... . rest-arg) body ...))]
|
||||||
|
[(_ proc-name type-expr body ...)
|
||||||
|
#'(begin
|
||||||
|
(: proc-name type-expr)
|
||||||
|
(define proc-name body ...))]))
|
||||||
|
|
||||||
|
(define-syntax (define/typed+provide stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ (proc-name arg ... . rest-arg) type-expr body ...)
|
||||||
|
#'(begin
|
||||||
|
(provide proc-name)
|
||||||
|
(define/typed proc-name type-expr
|
||||||
|
(λ(arg ... . rest-arg) body ...)))]
|
||||||
|
[(_ proc-name type-expr body ...)
|
||||||
|
#'(begin
|
||||||
|
(provide proc-name)
|
||||||
|
(begin
|
||||||
|
(: proc-name : type-expr)
|
||||||
|
(define proc-name body ...)))]))
|
||||||
|
|
||||||
|
(define-syntax (define-type+predicate stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ id basetype)
|
||||||
|
(with-syntax ([id? (format-id stx "~a?" #'id)])
|
||||||
|
#'(begin
|
||||||
|
(define-type id basetype)
|
||||||
|
(define-predicate id? id)))]))
|
@ -0,0 +1,59 @@
|
|||||||
|
#lang typed/racket/base
|
||||||
|
(require typed/sugar/define typed/sugar/coerce typed/sugar/string racket/path)
|
||||||
|
|
||||||
|
(define/typed+provide (get-enclosing-dir p)
|
||||||
|
(Pathish -> Path)
|
||||||
|
(simplify-path (build-path (->path p) 'up)))
|
||||||
|
|
||||||
|
;; does path have a certain extension
|
||||||
|
(define/typed+provide (has-ext? x ext)
|
||||||
|
(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))))))
|
||||||
|
|
||||||
|
;; get file extension as a string, or return #f
|
||||||
|
;; (consistent with filename-extension behavior)
|
||||||
|
(define/typed+provide (get-ext x)
|
||||||
|
(Pathish -> (Option String))
|
||||||
|
(let ([fe-result (filename-extension (->path x))])
|
||||||
|
(and fe-result (bytes->string/utf-8 fe-result))))
|
||||||
|
|
||||||
|
|
||||||
|
;; todo: add extensions
|
||||||
|
(define/typed+provide binary-extensions
|
||||||
|
(Listof String)
|
||||||
|
(map symbol->string '(gif jpg jpeg mp3 png zip pdf ico tar ai eps exe)))
|
||||||
|
|
||||||
|
(define/typed+provide (has-binary-ext? x)
|
||||||
|
(Pathish -> Boolean)
|
||||||
|
(let ([x (->path x)])
|
||||||
|
(ormap (λ:([ext : String]) (has-ext? x ext)) binary-extensions)))
|
||||||
|
|
||||||
|
;; put extension on path
|
||||||
|
;; use local contract here because this function is used within module
|
||||||
|
(define/typed+provide (add-ext x ext)
|
||||||
|
(Stringish Stringish -> Path)
|
||||||
|
(->path (string-append (->string x) "." (->string ext))))
|
||||||
|
|
||||||
|
;; take one extension off path
|
||||||
|
(define/typed+provide (remove-ext x)
|
||||||
|
(Pathish -> Path)
|
||||||
|
;; pass through hidden files (those starting with a dot)
|
||||||
|
(let ([x (->path x)])
|
||||||
|
(if (x . starts-with? . ".")
|
||||||
|
x
|
||||||
|
(path-replace-suffix x ""))))
|
||||||
|
|
||||||
|
|
||||||
|
;; take all extensions off path
|
||||||
|
(define/typed+provide (remove-ext* x)
|
||||||
|
(Pathish -> Path)
|
||||||
|
;; pass through hidden files (those starting with a dot)
|
||||||
|
(let ([x (->path x)])
|
||||||
|
(if (x . starts-with? . ".")
|
||||||
|
x
|
||||||
|
(let ([path-with-removed-ext (remove-ext x)])
|
||||||
|
(if (equal? x path-with-removed-ext)
|
||||||
|
x
|
||||||
|
(remove-ext* path-with-removed-ext))))))
|
||||||
|
|
@ -1,9 +1,12 @@
|
|||||||
#lang racket/base
|
#lang typed/racket/base
|
||||||
(require racket/set racket/sequence)
|
(require racket/set racket/sequence)
|
||||||
(require "define.rkt")
|
(require typed/sugar/define)
|
||||||
|
|
||||||
(define+provide/contract (len x)
|
(provide Lengthable)
|
||||||
((or/c list? vector? set? sequence? string? symbol? path? hash?) . -> . integer?)
|
(define-type Lengthable (U (Listof Any) String Symbol Path (Vectorof Any) HashTableTop (Setof Any) (Sequenceof Any)))
|
||||||
|
|
||||||
|
(define/typed+provide (len x)
|
||||||
|
(Lengthable -> Nonnegative-Integer)
|
||||||
(cond
|
(cond
|
||||||
[(list? x) (length x)]
|
[(list? x) (length x)]
|
||||||
[(string? x) (string-length x)]
|
[(string? x) (string-length x)]
|
@ -1,9 +1,8 @@
|
|||||||
#lang racket/base
|
#lang racket/base
|
||||||
(require (for-syntax racket/base))
|
(require typed/sugar/define)
|
||||||
(require "define.rkt")
|
|
||||||
|
|
||||||
(define+provide/contract (bytecount->string bytecount)
|
(define/typed+provide (bytecount->string bytecount)
|
||||||
(integer? . -> . string?)
|
(Nonnegative-Integer -> String)
|
||||||
(define (format-with-threshold threshold suffix)
|
(define (format-with-threshold threshold suffix)
|
||||||
;; upconvert by factor of 100 to get two digits after decimal
|
;; upconvert by factor of 100 to get two digits after decimal
|
||||||
(format "~a ~a" (exact->inexact (/ (round ((* bytecount 100) . / . threshold)) 100)) suffix))
|
(format "~a ~a" (exact->inexact (/ (round ((* bytecount 100) . / . threshold)) 100)) suffix))
|
@ -0,0 +1,21 @@
|
|||||||
|
#lang typed/racket/base
|
||||||
|
(require typed/sugar/define typed/sugar/coerce)
|
||||||
|
|
||||||
|
(define/typed+provide (starts-with? str starter)
|
||||||
|
(Stringish Stringish -> Boolean)
|
||||||
|
(let ([str (->string str)]
|
||||||
|
[starter (->string starter)])
|
||||||
|
(and (<= (string-length starter) (string-length str))
|
||||||
|
(equal? (substring str 0 (string-length starter)) starter))))
|
||||||
|
|
||||||
|
(define/typed+provide (ends-with? str ender)
|
||||||
|
(Stringish Stringish -> Boolean)
|
||||||
|
(let ([str (->string str)]
|
||||||
|
[ender (->string ender)])
|
||||||
|
(and (<= (string-length ender) (string-length str))
|
||||||
|
(equal? (substring str (- (string-length str) (string-length ender)) (string-length str)) ender))))
|
||||||
|
|
||||||
|
(define/typed+provide (capitalized? str)
|
||||||
|
(Stringish -> Boolean)
|
||||||
|
(let ([str (->string str)])
|
||||||
|
(char-upper-case? (car (string->list str)))))
|
@ -0,0 +1,22 @@
|
|||||||
|
#lang typed/racket/base/no-check
|
||||||
|
(require (for-syntax typed/racket/base) typed/rackunit)
|
||||||
|
|
||||||
|
(provide check-typing-fails check-typing)
|
||||||
|
|
||||||
|
(define-syntax (check-typing-base stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ wants-to-fail? expr)
|
||||||
|
(let* ([wants-to-fail? (syntax->datum #'wants-to-fail?)]
|
||||||
|
[λ-arg 'v]
|
||||||
|
[eval-string (if wants-to-fail? `(cons '#%top-interaction ,λ-arg) λ-arg)]
|
||||||
|
[check-string (if wants-to-fail? '(curry check-exn exn:fail:syntax?) 'check-not-exn)])
|
||||||
|
#`(begin
|
||||||
|
(define-namespace-anchor ns)
|
||||||
|
(let ([E (λ(#,λ-arg) (eval #,eval-string (namespace-anchor->namespace ns)))])
|
||||||
|
(apply #,check-string (list (λ _ (call-with-values (λ _ (E 'expr)) (λ vals (car vals)))))))))]))
|
||||||
|
|
||||||
|
(define-syntax-rule (check-typing-fails expr)
|
||||||
|
(check-typing-base #t expr))
|
||||||
|
|
||||||
|
(define-syntax-rule (check-typing expr)
|
||||||
|
(check-typing-base #f expr))
|
@ -0,0 +1,163 @@
|
|||||||
|
#lang typed/racket/base
|
||||||
|
(require racket/include typed/rackunit typed/net/url racket/set racket/list racket/match)
|
||||||
|
(require typed/sugar)
|
||||||
|
|
||||||
|
;; begin shared typed / untyped tests
|
||||||
|
|
||||||
|
(check-equal? (->int 42) 42)
|
||||||
|
(check-equal? (->int 42.1) 42)
|
||||||
|
(check-equal? (->int 42+3i) 42)
|
||||||
|
(check-equal? (->int "42") 42)
|
||||||
|
(check-equal? (->int '42) 42)
|
||||||
|
(check-equal? (->int (string->path "42")) 42)
|
||||||
|
(check-equal? (->int #\A) 65)
|
||||||
|
(check-equal? (->int (make-list 42 null)) 42)
|
||||||
|
|
||||||
|
(check-equal? (->string "foo") "foo")
|
||||||
|
(check-equal? (->string '()) "")
|
||||||
|
(check-equal? (->string (void)) "")
|
||||||
|
(check-equal? (->string 'foo) "foo")
|
||||||
|
(check-equal? (->string 123) "123")
|
||||||
|
;(check-equal? (->string (string->url "foo/bar.html")) "foo/bar.html")
|
||||||
|
(define file-name-as-text "foo.txt")
|
||||||
|
(check-equal? (->string (string->path file-name-as-text)) file-name-as-text)
|
||||||
|
(check-equal? (->string #\¶) "¶")
|
||||||
|
|
||||||
|
(check-equal? (->path "foo") (string->path "foo"))
|
||||||
|
(check-equal? (->path 'foo) (string->path "foo"))
|
||||||
|
(check-equal? (->path 123) (string->path "123"))
|
||||||
|
(check-equal? (->path (string->url "foo/bar.html")) (string->path "foo/bar.html"))
|
||||||
|
|
||||||
|
(check-equal? (->list '(1 2 3)) '(1 2 3))
|
||||||
|
(check-equal? (->list (list->vector '(1 2 3))) '(1 2 3))
|
||||||
|
(check-equal? (->list (set 1 2 3)) '(3 2 1))
|
||||||
|
(check-equal? (->list "foo") (list "foo"))
|
||||||
|
|
||||||
|
(check-true (->boolean #t))
|
||||||
|
(check-false (->boolean #f))
|
||||||
|
(check-true (->boolean "#f"))
|
||||||
|
(check-true (->boolean "foo"))
|
||||||
|
(check-true (->boolean '()))
|
||||||
|
(check-true (->boolean '(1 2 3)))
|
||||||
|
|
||||||
|
|
||||||
|
(check-equal? (len '(1 2 3)) 3)
|
||||||
|
(check-not-equal? (len '(1 2)) 3) ; len 2
|
||||||
|
(check-equal? (len "foo") 3)
|
||||||
|
(check-not-equal? (len "fo") 3) ; len 2
|
||||||
|
(check-equal? (len 'foo) 3)
|
||||||
|
(check-not-equal? (len 'fo) 3) ; len 2
|
||||||
|
(check-equal? (len (list->vector '(1 2 3))) 3)
|
||||||
|
(check-not-equal? (len (list->vector '(1 2))) 3) ; len 2
|
||||||
|
(check-equal? (len (set 1 2 3)) 3)
|
||||||
|
(check-not-equal? (len (set 1 2)) 3) ; len 2
|
||||||
|
(check-equal? (len (make-hash '((a . 1) (b . 2) (c . 3)))) 3)
|
||||||
|
(check-not-equal? (len (make-hash '((a . 1) (b . 2)))) 3) ; len 2
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(check-true ("foobar" . starts-with? . "foo"))
|
||||||
|
(check-true ("foobar" . starts-with? . "f"))
|
||||||
|
(check-true ("foobar" . starts-with? . "foobar"))
|
||||||
|
(check-false ("foobar" . starts-with? . "bar"))
|
||||||
|
(check-false ("foobar" . starts-with? . "."))
|
||||||
|
(check-true ("foobar" . ends-with? . "bar"))
|
||||||
|
(check-true ("foobar" . ends-with? . "r"))
|
||||||
|
(check-true ("foobar" . ends-with? . "foobar"))
|
||||||
|
(check-false ("foobar" . ends-with? . "foo"))
|
||||||
|
|
||||||
|
|
||||||
|
(check-true (members-unique? '(a b c)))
|
||||||
|
(check-false (members-unique? '(a b c c)))
|
||||||
|
(check-true (members-unique? "zoey"))
|
||||||
|
(check-false (members-unique? "zooey"))
|
||||||
|
|
||||||
|
(check-equal? (trimf (list 4 1 2 3 4) even?) '(1 2 3))
|
||||||
|
(check-equal? (trimf (list 1 3 2 4 5 6 8 9 13) odd?) '(2 4 5 6 8))
|
||||||
|
(check-equal? (filter-split '("foo" " " "bar" "\n" "\n" "ino") (λ:([x : String]) (< (string-length x) 3))) '(("foo")("bar")("ino")))
|
||||||
|
(check-equal? (filter-split '(1 2 3 4 5 6) even?) '((1)(3)(5)))
|
||||||
|
|
||||||
|
|
||||||
|
(define foo-path-strings '("foo" "foo.txt" "foo.bar" "foo.bar.txt"))
|
||||||
|
(match-define (list foo-path foo.txt-path foo.bar-path foo.bar.txt-path) (map ->path foo-path-strings))
|
||||||
|
;; test the sample paths before using them for other tests
|
||||||
|
(define foo-paths (list foo-path foo.txt-path foo.bar-path foo.bar.txt-path))
|
||||||
|
(for-each check-equal? (map ->string foo-paths) foo-path-strings)
|
||||||
|
|
||||||
|
|
||||||
|
(check-false (has-ext? foo-path 'txt))
|
||||||
|
(check-true (foo.txt-path . has-ext? . 'txt))
|
||||||
|
(check-true ((->path "foo.TXT") . has-ext? . 'txt))
|
||||||
|
(check-true (has-ext? foo.bar.txt-path 'txt))
|
||||||
|
(check-false (foo.bar.txt-path . has-ext? . 'doc)) ; wrong extension
|
||||||
|
|
||||||
|
|
||||||
|
(check-equal? (get-ext (->path "foo.txt")) "txt")
|
||||||
|
(check-false (get-ext "foo"))
|
||||||
|
|
||||||
|
(check-equal? (add-ext (string->path "foo") "txt") (string->path "foo.txt"))
|
||||||
|
(check-equal? (remove-ext foo-path) foo-path)
|
||||||
|
(check-equal? (remove-ext (->path ".foo.txt")) (->path ".foo.txt"))
|
||||||
|
(check-equal? (remove-ext foo.txt-path) foo-path)
|
||||||
|
(check-equal? (remove-ext foo.bar.txt-path) foo.bar-path)
|
||||||
|
(check-not-equal? (remove-ext foo.bar.txt-path) foo-path) ; does not remove all extensions
|
||||||
|
|
||||||
|
|
||||||
|
(check-equal? (remove-ext* foo-path) foo-path)
|
||||||
|
(check-equal? (remove-ext* foo.txt-path) foo-path)
|
||||||
|
(check-equal? (remove-ext* (->path ".foo.txt")) (->path ".foo.txt"))
|
||||||
|
(check-not-equal? (remove-ext* foo.bar.txt-path) foo.bar-path) ; removes more than one ext
|
||||||
|
(check-equal? (remove-ext* foo.bar.txt-path) foo-path)
|
||||||
|
|
||||||
|
|
||||||
|
(check-true (starts-with? "foobar" "foo"))
|
||||||
|
(check-true (starts-with? "foobar" "foobar"))
|
||||||
|
(check-false (starts-with? "foobar" "zam"))
|
||||||
|
(check-false (starts-with? "foobar" "foobars"))
|
||||||
|
(check-true (ends-with? "foobar" "bar"))
|
||||||
|
(check-false (ends-with? "foobar" "zam"))
|
||||||
|
(check-true (ends-with? "foobar" "foobar"))
|
||||||
|
(check-false (ends-with? "foobar" "foobars"))
|
||||||
|
(check-true (capitalized? "Brennan"))
|
||||||
|
(check-false (capitalized? "foobar"))
|
||||||
|
|
||||||
|
(check-equal? (slice-at (range 5) 1) '((0) (1) (2) (3) (4)))
|
||||||
|
(check-equal? (slice-at (range 5) 2) '((0 1) (2 3) (4)))
|
||||||
|
(check-equal? (slice-at (range 5) 2 #t) '((0 1) (2 3)))
|
||||||
|
(check-equal? (slice-at (range 5) 3) '((0 1 2) (3 4)))
|
||||||
|
(check-equal? (slice-at (range 5) 3 #t) '((0 1 2)))
|
||||||
|
|
||||||
|
(check-equal? (slicef-at (range 5) even?) '((0 1) (2 3) (4)))
|
||||||
|
(check-equal? (slicef-at (range 5) odd?) '((0) (1 2) (3 4)))
|
||||||
|
(check-equal? (slicef-at (range 5) odd? #t) '((1 2) (3 4)))
|
||||||
|
(check-equal? (slicef-at (range 5) procedure?) '((0 1 2 3 4)))
|
||||||
|
|
||||||
|
(check-equal? (slicef-at '(1 2 2 1 2) even?) '((1) (2) (2 1) (2)))
|
||||||
|
(check-equal? (slicef-at '(1 2 2 1 2) even? #t) '((2) (2 1) (2)))
|
||||||
|
|
||||||
|
(check-equal? (sublist (range 5) 0 0) '())
|
||||||
|
(check-equal? (sublist (range 5) 0 1) '(0))
|
||||||
|
(check-equal? (sublist (range 5) 0 5) '(0 1 2 3 4))
|
||||||
|
|
||||||
|
(check-equal? (break-at '(5 6 7 8) '()) '((5 6 7 8)))
|
||||||
|
(check-equal? (break-at '(5 6 7 8) '(0)) '((5 6 7 8)))
|
||||||
|
(check-equal? (break-at '(5 6 7 8) '(1 2 3)) '((5) (6) (7) (8)))
|
||||||
|
(check-equal? (break-at '(5 6 7 8) '(1 3)) '((5) (6 7) (8)))
|
||||||
|
(check-equal? (break-at '(5 6 7 8) '(1)) (break-at '(5 6 7 8) 1))
|
||||||
|
|
||||||
|
(define xs (range 5))
|
||||||
|
(check-equal? (map (λ(a b c) (list a b c)) (shift xs -1) (shift xs 0) (shift xs 1)) '((1 0 #f) (2 1 0) (3 2 1) (4 3 2) (#f 4 3)))
|
||||||
|
(check-equal? (shift xs '(-1 0 1) 'boing) `((1 2 3 4 boing) ,xs (boing 0 1 2 3)))
|
||||||
|
(check-equal? (shift xs 5 0) (make-list 5 0))
|
||||||
|
(check-exn exn:fail? (λ() (shift xs -10)))
|
||||||
|
|
||||||
|
;; end shared tests
|
||||||
|
|
||||||
|
|
||||||
|
#|
|
||||||
|
;; todo: revise `check-typing-fails` to make it compatible with 6.0
|
||||||
|
(check-typing-fails (slice-at (range 5) 0)) ; needs a positive integer as second arg
|
||||||
|
(check-typing-fails (slicef-at (range 5) 3)) ; needs a procedure as second arg
|
||||||
|
|#
|
@ -0,0 +1 @@
|
|||||||
|
(define no-lang-symbol 'bar)
|
@ -0,0 +1,3 @@
|
|||||||
|
#lang typed/racket
|
||||||
|
|
||||||
|
(define included-symbol 'bar)
|
@ -0,0 +1,29 @@
|
|||||||
|
#lang racket/base
|
||||||
|
(require rackunit)
|
||||||
|
|
||||||
|
(module trb typed/racket/base
|
||||||
|
(require typed/sugar/list typed/rackunit)
|
||||||
|
(provide (all-defined-out))
|
||||||
|
;; (trimf odd? '(1 2 3)) ; type error
|
||||||
|
(define foo (trimf '(1 2 3) odd?))
|
||||||
|
(check-equal? foo '(2)))
|
||||||
|
|
||||||
|
(module rb racket/base
|
||||||
|
(require (submod sugar/list safe) rackunit)
|
||||||
|
(provide (all-defined-out))
|
||||||
|
(check-exn exn:fail:contract? (λ _ (trimf odd? '(1 2 3)))) ; fails at trimf
|
||||||
|
(define foo (trimf '(1 2 3) odd?))
|
||||||
|
(check-equal? foo '(2)))
|
||||||
|
|
||||||
|
(module rbu racket/base
|
||||||
|
(require sugar/list rackunit)
|
||||||
|
(provide (all-defined-out))
|
||||||
|
(check-exn exn:fail:contract? (λ _ (trimf odd? '(1 2 3)))) ; fails at dropf
|
||||||
|
(define foo (trimf '(1 2 3) odd?))
|
||||||
|
(check-equal? foo '(2)))
|
||||||
|
|
||||||
|
(require (prefix-in trb: 'trb))
|
||||||
|
(require (prefix-in rb: 'rb))
|
||||||
|
(require (prefix-in rbu: 'rbu))
|
||||||
|
|
||||||
|
(check-true (andmap (λ(val) (equal? val '(2))) (list trb:foo rb:foo rbu:foo)))
|
@ -0,0 +1,45 @@
|
|||||||
|
#lang typed/racket/base
|
||||||
|
(require racket/port)
|
||||||
|
#;(provide (all-defined-out))
|
||||||
|
#;(require/typed xml [permissive-xexprs (Parameterof Boolean)]
|
||||||
|
[#:struct prolog ([misc : (Listof Misc)][dtd : (Option DTD)][misc2 : (Listof Misc)])]
|
||||||
|
[#:struct document ([prolog : Prolog][element : Element][misc : (Listof Misc)])])
|
||||||
|
|
||||||
|
#|
|
||||||
|
The following grammar describes expressions that create X-expressions:
|
||||||
|
|
||||||
|
xexpr = string
|
||||||
|
| (list symbol (list (list symbol string) ...) xexpr ...)
|
||||||
|
| (cons symbol (list xexpr ...))
|
||||||
|
| symbol
|
||||||
|
| valid-char?
|
||||||
|
| cdata
|
||||||
|
| misc
|
||||||
|
|#
|
||||||
|
|
||||||
|
(define-type Cdata String) ;; could be tighter
|
||||||
|
|
||||||
|
;; valid-char could be tighter
|
||||||
|
#|
|
||||||
|
Returns true if x is an exact-nonnegative-integer whose character interpretation under UTF-8 is from the set ([#x1-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF]),
|
||||||
|
|#
|
||||||
|
(define-type Valid-Char Char)
|
||||||
|
(define-type Xexpr (Rec X (U String
|
||||||
|
(List* Symbol (Listof (List Symbol String)) (Listof X))
|
||||||
|
(Pairof Symbol (Listof X))
|
||||||
|
Symbol
|
||||||
|
Valid-Char
|
||||||
|
Cdata)))
|
||||||
|
(define-predicate Xexpr? Xexpr)
|
||||||
|
|
||||||
|
#|
|
||||||
|
(: xml-string->xexprs (String . -> . (values Xexpr Xexpr)))
|
||||||
|
(define (xml-string->xexprs str)
|
||||||
|
(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 (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)))))
|
||||||
|
|#
|
Loading…
Reference in New Issue