diff --git a/.gitignore b/.gitignore index efb2dbf..86d9a85 100644 --- a/.gitignore +++ b/.gitignore @@ -15,7 +15,7 @@ Icon .Trashes # generated documentation -doc/* -scribblings/*.js -scribblings/*.css -scribblings/*.html +sugar/doc/* +sugar/scribblings/*.js +sugar/scribblings/*.css +sugar/scribblings/*.html diff --git a/cache.rkt b/cache.rkt deleted file mode 100644 index a698889..0000000 --- a/cache.rkt +++ /dev/null @@ -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 ...))])) \ No newline at end of file diff --git a/coerce.rkt b/coerce.rkt deleted file mode 100644 index 4177fa8..0000000 --- a/coerce.rkt +++ /dev/null @@ -1,156 +0,0 @@ -#lang racket/base -(require (for-syntax racket/base racket/syntax)) -(require net/url racket/set racket/contract racket/sequence racket/stream racket/dict) -(require "len.rkt" "define.rkt") - -(define (make-coercion-error-handler target-format x) - (λ(e) (error (format "Can’t convert ~a to ~a" x target-format)))) - - -(define+provide (->int x) - (with-handlers ([exn:fail? (make-coercion-error-handler 'integer x)]) - (cond - [(or (integer? x) (real? x)) (inexact->exact (floor x))] - [(and (string? x) (> (len x) 0)) (->int (string->number x))] - [(symbol? x) (->int (->string x))] - [(char? x) (char->integer x)] - [(path? x) (->int (->string x))] - [else (len x)]))) - - -(provide ->macrostring) -(define-syntax-rule (->macrostring x) - (if (string? x) - x ; fast exit for strings - (with-handlers ([exn:fail? (make-coercion-error-handler 'string (format "~a (result of ~a" x 'x))]) - (cond - [(or (equal? '() x) (void? x)) ""] - [(symbol? x) (symbol->string x)] - [(number? x) (number->string x)] - [(path? x) (path->string x)] - [(char? x) (format "~a" x)] - [else (error)])))) - -(define+provide (->string x) - (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)] - [(char? x) (format "~a" x)] - [else (error)])))) - - -(define+provide (->symbol x) - (if (symbol? x) - x - (with-handlers ([exn:fail? (make-coercion-error-handler 'symbol x)]) - (string->symbol (->string x))))) - - -(define+provide (->path x) - (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 (->url x) - (with-handlers ([exn:fail? (make-coercion-error-handler 'url x)]) - (string->url (->string x)))) - - -(define+provide (->complete-path x) - (with-handlers ([exn:fail? (make-coercion-error-handler 'complete-path x)]) - (path->complete-path (->path x)))) - - -(define+provide (->list x) - (if (list? x) - x - (with-handlers ([exn:fail? (make-coercion-error-handler 'list x)]) - (cond - [(string? x) (list x)] - [(vector? x) (vector->list x)] - [(set? x) (set->list x)] - ;; location relevant because hash or dict are also sequences - [(dict? x) (dict->list x)] - [(integer? x) (list x)] ; because an integer tests #t for sequence? - [(sequence? x) (sequence->list x)] - [(stream? x) (stream->list x)] - [else (list x)])))) - - -(define+provide (->vector x) - (if (vector? x) - x - (with-handlers ([exn:fail? (make-coercion-error-handler 'vector x)]) - (list->vector (->list x))))) - - -(define+provide (->boolean x) - (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 - (define+provide (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 point to having list and vector here; they work with everything - - - -(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 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)]) - #'(define+provide 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 deleted file mode 100644 index bbd0615..0000000 --- a/define.rkt +++ /dev/null @@ -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 ...))])) diff --git a/file.rkt b/file.rkt deleted file mode 100644 index 5e72453..0000000 --- a/file.rkt +++ /dev/null @@ -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))))) - diff --git a/info.rkt b/info.rkt index 602dccf..cb33f5a 100644 --- a/info.rkt +++ b/info.rkt @@ -1,6 +1,6 @@ #lang info -(define collection "sugar") -(define deps '("base")) -(define build-deps '("scribble-lib")) -(define scribblings '(("scribblings/sugar.scrbl" ()))) -(define compile-omit-paths '("test")) +(define collection 'multi) +(define deps '("base" + "typed-racket-lib" + "typed-racket-more")) +(define build-deps '("scribble-lib")) \ No newline at end of file diff --git a/list.rkt b/list.rkt deleted file mode 100644 index 6ed4618..0000000 --- a/list.rkt +++ /dev/null @@ -1,165 +0,0 @@ -#lang racket/base -(require (for-syntax racket/base)) -(require racket/list racket/set racket/function) -(require "define.rkt" "len.rkt" "coerce.rkt") - -(define+provide/contract (trimf xs test-proc) - (list? procedure? . -> . list?) - (dropf-right (dropf xs test-proc) test-proc)) - -(define (list-of-lists? xs) (and (list? xs) (andmap list? xs))) - - -(define+provide/contract (slicef-at xs pred [force? #f]) - ((list? procedure?) (boolean?) . ->* . list-of-lists?) - (define-values (last-list list-of-lists) - (for/fold ([current-list empty][list-of-lists empty])([x (in-list xs)]) - (if (pred x) - (values (cons x null) (if (not (empty? current-list)) - (cons (reverse current-list) list-of-lists) - list-of-lists)) - (values (cons x current-list) list-of-lists)))) - (let ([list-of-lists (reverse (if (empty? last-list) - list-of-lists - (cons (reverse last-list) list-of-lists)))]) - (if (and force? (not (empty? list-of-lists)) (not (pred (caar list-of-lists)))) - (cdr list-of-lists) - list-of-lists))) - - -(define+provide/contract (slicef-after xs pred) - (list? procedure? . -> . list-of-lists?) - (define-values (last-list list-of-lists) - (for/fold ([current-list empty][list-of-lists empty])([x (in-list xs)]) - (if (pred x) - (values empty (cons (reverse (cons x current-list)) list-of-lists)) - (values (cons x current-list) list-of-lists)))) - (reverse (if (empty? last-list) - list-of-lists - (cons (reverse last-list) list-of-lists)))) - - -(define+provide/contract (slice-at xs len [force? #f]) - ((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])([(x i) (in-indexed xs)]) - (if (= (modulo (add1 i) len) 0) - (values empty (cons (reverse (cons x current-list)) list-of-lists)) - (values (cons x current-list) list-of-lists)))) - (reverse (if (or (empty? last-list) (and force? (not (= len (length last-list))))) - list-of-lists - (cons (reverse last-list) list-of-lists)))) - - -(define+provide/contract (filter-split xs pred) - (list? predicate/c . -> . list-of-lists?) - (define-values (last-list list-of-lists) - (for/fold ([current-list empty][list-of-lists empty]) - ([x (in-list xs)]) - (if (pred x) - (values empty (if (not (empty? current-list)) - (cons (reverse current-list) list-of-lists) - list-of-lists)) - (values (cons x current-list) list-of-lists)))) - (reverse (if (not (empty? last-list)) - (cons (reverse last-list) list-of-lists) - list-of-lists))) - - -(define+provide/contract (frequency-hash x) - (list? . -> . hash?) - (define counter (make-hash)) - (for ([item (in-list (flatten x))]) - (hash-set! counter item (add1 (hash-ref counter item 0)))) - counter) - - -(define+provide/contract (members-unique? x) - ((or/c list? vector? string?) . -> . boolean?) - (cond - [(list? x) (= (len (remove-duplicates x)) (len x))] - [(vector? x) (->list x)] - [(string? x) (string->list x)] - [else (error (format "members-unique? cannot be determined for ~a" x))])) - - -(define+provide/contract (members-unique?/error x) - (any/c . -> . boolean?) - (define result (members-unique? x)) - (if (not result) - (let* ([duplicate-keys (filter-not empty? (hash-map (frequency-hash x) - (λ(k v) (if (> v 1) k '()))))]) - (error (string-append "members-unique? failed because " (if (= (len duplicate-keys) 1) - "item isn’t" - "items aren’t") " unique:") duplicate-keys)) - result)) - - -;; for use inside quasiquote -;; instead of ,(when ...) use ,@(when/splice ...) -;; to avoid voids -(provide when/splice) -(define-syntax (when/splice stx) - (syntax-case stx () - [(_ test body) - #'(if test (list body) '())])) - - -(provide values->list) -(define-syntax (values->list stx) - (syntax-case stx () - [(_ values-expr) #'(call-with-values (λ () values-expr) list)])) - - -(define+provide/contract (sublist xs i j) - (list? (and/c integer? (not/c negative?)) (and/c integer? (not/c negative?)) . -> . list?) - (cond - [(> j (length xs)) (error 'sublist (format "ending index ~a exceeds length of list" j))] - [(>= j i) (take (drop xs i) (- j i))] - [else (error 'sublist (format "starting index ~a is larger than ending index ~a" i j))])) - -(define increasing-nonnegative? (λ(xs) (apply < -1 xs))) -(define increasing-nonnegative-list? (and/c list? increasing-nonnegative?)) - -(define+provide/contract (break-at xs bps) - (list? (and/c coerce/list? (or/c empty? increasing-nonnegative-list?)) . -> . list-of-lists?) - (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)))) - ;; 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 - (reverse (let loop ([xs xs][bps (reverse (cons 0 bps))]) - (if (= (car bps) 0) - (cons xs null) ; return whatever's left, because no more splits are possible - (let-values ([(head tail) (split-at xs (car bps))]) - (cons tail (loop head (cdr bps)))))))) - - -(define (integers? x) - (and (list? x) (andmap integer? x))) - -(define+provide/contract (shift xs shift-amount-or-amounts [fill-item #f] [cycle? #f]) - ((list? (or/c integer? integers?)) (any/c boolean?) . ->* . list?) - - (define (do-shift xs how-far) - (define abs-how-far (abs how-far)) - (cond - [(> abs-how-far (length xs)) (error 'shift "index is too large for list\nindex: ~a\nlist: ~v" how-far xs)] - [(= how-far 0) xs] - [(positive? how-far) (append (make-list abs-how-far fill-item) (drop-right xs abs-how-far))] - ;; otherwise how-far is negative - [else (append (drop xs abs-how-far) (make-list abs-how-far fill-item))])) - - (if (list? shift-amount-or-amounts) - (map (curry do-shift xs) shift-amount-or-amounts) - (do-shift xs shift-amount-or-amounts))) - - -(define+provide/contract (shift/values xs shift-amount-or-amounts [fill-item #f]) - ((list? (or/c integer? integers?)) (any/c) . ->* . any) - (apply (if (list? shift-amount-or-amounts) - values - (λ xs xs)) - (shift xs shift-amount-or-amounts fill-item))) - - diff --git a/string.rkt b/string.rkt deleted file mode 100644 index 20ad535..0000000 --- a/string.rkt +++ /dev/null @@ -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)))) diff --git a/sugar/cache.rkt b/sugar/cache.rkt new file mode 100644 index 0000000..628d5bd --- /dev/null +++ b/sugar/cache.rkt @@ -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) diff --git a/sugar/coerce.rkt b/sugar/coerce.rkt new file mode 100644 index 0000000..b8c0af4 --- /dev/null +++ b/sugar/coerce.rkt @@ -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) \ No newline at end of file diff --git a/container.rkt b/sugar/container.rkt similarity index 86% rename from container.rkt rename to sugar/container.rkt index ec2e402..11f3ef2 100644 --- a/container.rkt +++ b/sugar/container.rkt @@ -1,6 +1,5 @@ #lang racket/base -(require "define.rkt") -(require "coerce.rkt" "len.rkt" racket/list racket/set racket/sequence racket/stream racket/dict) +(require "define.rkt" "coerce.rkt" "len.rkt" racket/list racket/set racket/sequence racket/stream racket/dict) (define (sliceable-container? x) (ormap (λ(proc) (proc x)) (list list? string? symbol? vector? path? (λ(i) (and (not (dict? i)) (sequence? i)))))) @@ -9,8 +8,8 @@ (ormap (λ(proc) (proc x)) (list sliceable-container? dict?))) -(define/contract+provide (get container start [end #f]) - ((gettable-container? any/c) ((or/c (and/c integer? positive?) #f)) . ->* . any/c) +(define+provide+safe (get container start [end #f]) + ((gettable-container? any/c) ((or/c (and/c integer? positive?) #f)) . ->* . any) (define result ;; use handler to capture error & print localized error message @@ -35,13 +34,13 @@ (define (listlike-container? container) (ormap (λ(pred) (pred container)) (list vector? set? sequence?))) -(define/contract+provide (in? item container) - (any/c any/c . -> . coerce/boolean?) - (cond +(define+provide+safe (in? item container) + (any/c any/c . -> . boolean?) + (->boolean (cond [(list? container) (member item container)] [(dict? container) (dict-has-key? container item)] [(path? container) (in? (->path item) (explode-path container))] [(stringish? container) (regexp-match (->string item) (->string container))] ;; location relevant because dicts and strings are also listlike (= sequences) [(listlike-container? container) (in? item (->list container))] - [else #f])) + [else #f]))) diff --git a/sugar/debug.rkt b/sugar/debug.rkt new file mode 100644 index 0000000..9e5ac12 --- /dev/null +++ b/sugar/debug.rkt @@ -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) \ No newline at end of file diff --git a/sugar/define.rkt b/sugar/define.rkt new file mode 100644 index 0000000..715a236 --- /dev/null +++ b/sugar/define.rkt @@ -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) diff --git a/sugar/file.rkt b/sugar/file.rkt new file mode 100644 index 0000000..586013b --- /dev/null +++ b/sugar/file.rkt @@ -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?)]) + \ No newline at end of file diff --git a/include.rkt b/sugar/include.rkt similarity index 97% rename from include.rkt rename to sugar/include.rkt index b0ca636..38062b0 100644 --- a/include.rkt +++ b/sugar/include.rkt @@ -4,9 +4,10 @@ syntax/path-spec racket/private/increader compiler/cm-accomplice - racket/match racket/function)) + racket/match racket/function) + sugar/define) -(provide include-without-lang-line) +(provide+safe include-without-lang-line) (define-syntax (do-include stx) (syntax-case stx () @@ -140,4 +141,4 @@ (syntax-case stx () [(_ fn) (with-syntax ([_stx stx]) - (syntax/loc stx (do-include _stx _stx _stx fn #f)))])) \ No newline at end of file + (syntax/loc stx (do-include _stx _stx _stx fn #f)))])) diff --git a/sugar/info.rkt b/sugar/info.rkt new file mode 100644 index 0000000..039ebee --- /dev/null +++ b/sugar/info.rkt @@ -0,0 +1,4 @@ +#lang info +(define scribblings '(("scribblings/sugar.scrbl" ()))) + +(define compile-omit-paths '("test")) \ No newline at end of file diff --git a/sugar/len.rkt b/sugar/len.rkt new file mode 100644 index 0000000..ac8fd5f --- /dev/null +++ b/sugar/len.rkt @@ -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?)]) diff --git a/sugar/list.rkt b/sugar/list.rkt new file mode 100644 index 0000000..51955d1 --- /dev/null +++ b/sugar/list.rkt @@ -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))) + diff --git a/main.rkt b/sugar/main.rkt similarity index 96% rename from main.rkt rename to sugar/main.rkt index fa356d3..abc5a7d 100644 --- a/main.rkt +++ b/sugar/main.rkt @@ -8,10 +8,10 @@ "define.rkt" "file.rkt" "include.rkt" + "len.rkt" "list.rkt" "misc.rkt" "string.rkt" - "len.rkt" "xml.rkt") (provide @@ -23,8 +23,8 @@ "define.rkt" "file.rkt" "include.rkt" + "len.rkt" "list.rkt" "misc.rkt" "string.rkt" - "len.rkt" "xml.rkt")) \ No newline at end of file diff --git a/sugar/misc.rkt b/sugar/misc.rkt new file mode 100644 index 0000000..645d5f6 --- /dev/null +++ b/sugar/misc.rkt @@ -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?)]) \ No newline at end of file diff --git a/scribblings/cache.scrbl b/sugar/scribblings/cache.scrbl similarity index 96% rename from scribblings/cache.scrbl rename to sugar/scribblings/cache.scrbl index ae983a0..bf277b6 100644 --- a/scribblings/cache.scrbl +++ b/sugar/scribblings/cache.scrbl @@ -6,7 +6,7 @@ @(my-eval `(require sugar)) @title{Cache} -@defmodule[sugar/cache] +@defmodule[#:multi (sugar/cache (submod sugar/cache safe) typed/sugar/cache)] If, like Ricky Bobby and me, you want to go fast, then try using more caches. They're wicked fast. diff --git a/scribblings/coerce.scrbl b/sugar/scribblings/coerce.scrbl similarity index 93% rename from scribblings/coerce.scrbl rename to sugar/scribblings/coerce.scrbl index 5575a03..87ba842 100644 --- a/scribblings/coerce.scrbl +++ b/sugar/scribblings/coerce.scrbl @@ -6,7 +6,7 @@ @(my-eval `(require sugar)) @title{Coercion} -@defmodule[sugar/coerce] +@defmodule[#:multi (sugar/coerce (submod sugar/coerce safe) typed/sugar/coerce)] Functions that coerce the datatype of a value to another type. Racket already has type-specific conversion functions. But if you're handling values of indeterminate type — as sometimes happens in an untyped language — then handling the possible cases individually gets to be a drag. @@ -161,7 +161,7 @@ Return @racket[#t] for all @racket[_v] except @racket[#f], which remains @racket @defproc[(listish? [v any/c]) boolean?] @defproc[(vectorish? [v any/c]) boolean?] )] -Predicates that report whether @racket[_v] can be coerced to the specified type. +@bold{Untyped only.} Predicates that report whether @racket[_v] can be coerced to the specified type. @examples[#:eval my-eval (map intish? (list 3 3.5 #\A "A" + #t)) @@ -185,7 +185,7 @@ Predicates that report whether @racket[_v] can be coerced to the specified type. @defproc[(coerce/boolean? [v any/c]) boolean?] @defproc[(coerce/list? [v any/c]) list?] )] -If @racket[_v] can be coerced to the specified type, change it to that type, then return it. If not, raise the usual contract error. These contracts can be used with input or output values. +@bold{Untyped only.} If @racket[_v] can be coerced to the specified type, change it to that type, then return it. If not, raise the usual contract error. These contracts can be used with input or output values. @examples[#:eval my-eval (define/contract (add-ints x y) diff --git a/scribblings/container.scrbl b/sugar/scribblings/container.scrbl similarity index 95% rename from scribblings/container.scrbl rename to sugar/scribblings/container.scrbl index 5212166..e486472 100644 --- a/scribblings/container.scrbl +++ b/sugar/scribblings/container.scrbl @@ -6,9 +6,9 @@ @(my-eval `(require sugar)) @title{Container} -@defmodule[sugar/container] +@defmodule[#:multi (sugar/container (submod sugar/container safe))] -Type-neutral functions for getting elements out of a container, or testing membership. +Type-neutral functions for getting elements out of a container, or testing membership. @bold{This submodule is untyped only.} @defproc[ diff --git a/scribblings/debug.scrbl b/sugar/scribblings/debug.scrbl similarity index 97% rename from scribblings/debug.scrbl rename to sugar/scribblings/debug.scrbl index bb7751f..2698cd4 100644 --- a/scribblings/debug.scrbl +++ b/sugar/scribblings/debug.scrbl @@ -6,7 +6,7 @@ @(my-eval `(require sugar)) @title{Debug} -@defmodule[sugar/debug] +@defmodule[#:multi (sugar/debug (submod sugar/debug safe) typed/sugar/debug)] Debugging utilities. diff --git a/scribblings/file.scrbl b/sugar/scribblings/file.scrbl similarity index 97% rename from scribblings/file.scrbl rename to sugar/scribblings/file.scrbl index 47f9180..2eafea6 100644 --- a/scribblings/file.scrbl +++ b/sugar/scribblings/file.scrbl @@ -6,7 +6,7 @@ @(my-eval `(require sugar)) @title{File} -@defmodule[sugar/file] +@defmodule[#:multi (sugar/file (submod sugar/file safe) typed/sugar/file)] File utilities, mostly in the realm of file extensions. These functions don't access the filesystem. diff --git a/scribblings/include.scrbl b/sugar/scribblings/include.scrbl similarity index 100% rename from scribblings/include.scrbl rename to sugar/scribblings/include.scrbl diff --git a/scribblings/installation.scrbl b/sugar/scribblings/installation.scrbl similarity index 100% rename from scribblings/installation.scrbl rename to sugar/scribblings/installation.scrbl diff --git a/scribblings/len.scrbl b/sugar/scribblings/len.scrbl similarity index 89% rename from scribblings/len.scrbl rename to sugar/scribblings/len.scrbl index b0f541c..5b75290 100644 --- a/scribblings/len.scrbl +++ b/sugar/scribblings/len.scrbl @@ -6,7 +6,8 @@ @(my-eval `(require sugar)) @title{Len} -@defmodule[sugar/len] +@defmodule[#:multi (sugar/len (submod sugar/len safe) typed/sugar/len)] + @defproc[ (len diff --git a/scribblings/license.scrbl b/sugar/scribblings/license.scrbl similarity index 100% rename from scribblings/license.scrbl rename to sugar/scribblings/license.scrbl diff --git a/scribblings/list.scrbl b/sugar/scribblings/list.scrbl similarity index 96% rename from scribblings/list.scrbl rename to sugar/scribblings/list.scrbl index 5f573bb..6f4d4f0 100644 --- a/scribblings/list.scrbl +++ b/sugar/scribblings/list.scrbl @@ -6,7 +6,8 @@ @(my-eval `(require sugar racket/list)) @title{List} -@defmodule[sugar/list] +@defmodule[#:multi (sugar/list (submod sugar/list safe) typed/sugar/list)] + @defproc[ @@ -194,7 +195,7 @@ Move the items in @racket[_lst] to the right (if @racket[_how-far] is positive) [how-far (or/c integer? (listof integer?))] [fill-item any/c #f]) any] -Same as @racket[shift], except that when @racket[_how-far] is a list, the resulting lists are returned as multiple values rather than as a list of lists. +@bold{Untyped only.} Same as @racket[shift], except that when @racket[_how-far] is a list, the resulting lists are returned as multiple values rather than as a list of lists. @examples[#:eval my-eval (define xs (range 5)) diff --git a/scribblings/string.scrbl b/sugar/scribblings/string.scrbl similarity index 92% rename from scribblings/string.scrbl rename to sugar/scribblings/string.scrbl index 85054d0..17b5725 100644 --- a/scribblings/string.scrbl +++ b/sugar/scribblings/string.scrbl @@ -6,7 +6,7 @@ @(my-eval `(require sugar)) @title{String} -@defmodule[sugar/string] +@defmodule[#:multi (sugar/string (submod sugar/string safe) typed/sugar/string)] @defproc[ diff --git a/scribblings/sugar.scrbl b/sugar/scribblings/sugar.scrbl similarity index 50% rename from scribblings/sugar.scrbl rename to sugar/scribblings/sugar.scrbl index e486347..c3dafe4 100644 --- a/scribblings/sugar.scrbl +++ b/sugar/scribblings/sugar.scrbl @@ -6,14 +6,22 @@ @(my-eval `(require sugar)) -@title[#:style 'toc]{Sugar: readability & convenience library} +@title[#:style 'toc]{Sugar} @author[(author+email "Matthew Butterick" "mb@mbtype.com")] -@defmodule[sugar] +@defmodule[#:multi (sugar (submod sugar safe) typed/sugar)] A collection of small functions to help make Racket code simpler & more readable. +Sugar can be invoked three ways: as an untyped library, as an untyped library with contracts (using the @tt{safe} submodule), or as a typed library. + +A few functions are only available as untyped or typed. These exceptions are noted below. + +The typed version of Sugar is implemented ``natively'' in the sense that it is compiled separately with type annotations. It is not a @racket[require/typed] wrapper around the untyped code. This avoids the contract barrier that is otherwise automatically imposed between typed and untyped code. + +@margin-note{This cross-compiling technique relies on @racket[include-without-lang-line] in this library.} + @;local-table-of-contents[] @include-section["installation.scrbl"] diff --git a/scribblings/xml.scrbl b/sugar/scribblings/xml.scrbl similarity index 90% rename from scribblings/xml.scrbl rename to sugar/scribblings/xml.scrbl index 9d1c16e..f84a7cc 100644 --- a/scribblings/xml.scrbl +++ b/sugar/scribblings/xml.scrbl @@ -6,9 +6,10 @@ @(my-eval `(require sugar)) @title{XML} -@defmodule[sugar/xml] +@defmodule[#:multi (sugar/xml (submod sugar/xml safe))] -Making it easier to do the simplest kind of round-trip with XML: convert an XML string to X-expressions, manipulate, and then convert these X-expressions back to an XML string. + +Making it easier to do the simplest kind of round-trip with XML: convert an XML string to X-expressions, manipulate, and then convert these X-expressions back to an XML string. @bold{This submodule is untyped only.} @defproc[ (xml-string->xexprs diff --git a/sugar/string.rkt b/sugar/string.rkt new file mode 100644 index 0000000..234d5da --- /dev/null +++ b/sugar/string.rkt @@ -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?)]) \ No newline at end of file diff --git a/test/tests.rkt b/sugar/test/main.rkt similarity index 87% rename from test/tests.rkt rename to sugar/test/main.rkt index e4effef..8b32f41 100644 --- a/test/tests.rkt +++ b/sugar/test/main.rkt @@ -1,7 +1,16 @@ #lang racket/base +(require racket/include rackunit sugar racket/list net/url racket/set racket/match) -(require rackunit net/url racket/set racket/list) -(require "../main.rkt") +;; 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 '()) "") @@ -13,8 +22,6 @@ (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")) @@ -47,41 +54,7 @@ (check-not-equal? (len (make-hash '((a . 1) (b . 2)))) 3) ; len 2 -(check-equal? (get '(0 1 2 3 4 5) 2) 2) -(check-exn exn:fail? (λ() (get '(0 1 2 3 4 5) 100))) ; index too big -(check-equal? (get `(0 1 ,(list 2) 3 4 5) 2) (list 2)) -(check-equal? (get '(0 1 2 3 4 5) 0 2) '(0 1)) -(check-equal? (get (list->vector '(0 1 2 3 4 5)) 2) 2) -(check-equal? (get (list->vector'(0 1 2 3 4 5)) 0 2) (list->vector '(0 1))) -(check-equal? (get "purple" 2) "r") -(check-equal? (get "purple" 0 2) "pu") -(check-equal? (get 'purple 2) 'r) -(check-equal? (get 'purple 0 2) 'pu) -(check-equal? (get (string->path "/root/foo/bar/file.txt") 2) (string->path "foo")) -(check-equal? (get (string->path "/root/foo/bar/file.txt") 0 2) (list (string->path "/") (string->path "root"))) -(check-equal? (get (make-hash `((a . ,(list 1)) (b . ,(list 2)) (c . ,(list 3)))) 'a) (list 1)) -(check-exn exn:fail? (λ() (get (make-hash `((a . ,(list 1)) (b . ,(list 2)) (c . ,(list 3)))) 'z))) ; nonexistent key -(check-equal? (get (string->path "/root/foo/bar/file.txt") 1) (string->path "root")) -(check-equal? (get (string->path "/root/foo/bar/file.txt") 0 3) - (map string->path '("/" "root" "foo"))) - -(check-equal? (get (make-hash '((a . 1) (b . 2) (c . 3))) 'b) 2) - -(check-true (2 . in? . '(1 2 3))) -(check-false (4 . in? . '(1 2 3))) -(check-true (2 . in? . (list->vector '(1 2 3)))) -(check-false (4 . in? . (list->vector '(1 2 3)))) -(check-true ('a . in? . (make-hash '((a . 1) (b . 2) (c . 3))))) -(check-false ('x . in? . (make-hash '((a . 1) (b . 2) (c . 3))))) -(check-true ("o" . in? . "foobar")) -(check-false ("z" . in? . "foobar")) -(check-true ('o . in? . 'foobar)) -(check-false ('z . in? . 'foobar)) -(check-true ("F" . in? . #\F)) - -(check-true (in? "foo" (string->path "/root/foo/bar/file.txt"))) -(check-false (in? "zam" (string->path "/root/foo/bar/file.txt"))) (check-true ("foobar" . starts-with? . "foo")) @@ -94,15 +67,20 @@ (check-true ("foobar" . ends-with? . "foobar")) (check-false ("foobar" . ends-with? . "foo")) -; (check-equal? (trim (list "\n" " " 1 2 3 "\n") whitespace?) '(1 2 3)) + +(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") whitespace?) '(("foo")("bar")("ino"))) +(check-equal? (filter-split '("foo" " " "bar" "\n" "\n" "ino") (λ(x) (< (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")) -(define-values (foo-path foo.txt-path foo.bar-path foo.bar.txt-path) - (apply values (map ->path foo-path-strings))) +(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) @@ -149,13 +127,11 @@ (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-exn exn:fail:contract? (λ() (slice-at (range 5) 0))) (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-exn exn:fail:contract? (λ() (slicef-at (range 5) 3))) (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))) @@ -176,7 +152,49 @@ (check-equal? (shift xs 5 0) (make-list 5 0)) (check-exn exn:fail? (λ() (shift xs -10))) -(check-equal? (values->list (shift/values xs '(-1 0 1) 'boing)) `((1 2 3 4 boing) ,xs (boing 0 1 2 3))) +;;;;; end common tests + +(check-exn exn:fail? (λ _ (slice-at (range 5) 0))) ; needs a positive integer as second arg +(check-exn exn:fail? (λ _ (slicef-at (range 5) 3))) ; needs a procedure as second arg + +(check-equal? (get '(0 1 2 3 4 5) 2) 2) +(check-exn exn:fail? (λ() (get '(0 1 2 3 4 5) 100))) ; index too big +(check-equal? (get `(0 1 ,(list 2) 3 4 5) 2) (list 2)) +(check-equal? (get '(0 1 2 3 4 5) 0 2) '(0 1)) +(check-equal? (get (list->vector '(0 1 2 3 4 5)) 2) 2) +(check-equal? (get (list->vector'(0 1 2 3 4 5)) 0 2) (list->vector '(0 1))) +(check-equal? (get "purple" 2) "r") +(check-equal? (get "purple" 0 2) "pu") +(check-equal? (get 'purple 2) 'r) +(check-equal? (get 'purple 0 2) 'pu) +(check-equal? (get (string->path "/root/foo/bar/file.txt") 2) (string->path "foo")) +(check-equal? (get (string->path "/root/foo/bar/file.txt") 0 2) (list (string->path "/") (string->path "root"))) +(check-equal? (get (make-hash `((a . ,(list 1)) (b . ,(list 2)) (c . ,(list 3)))) 'a) (list 1)) +(check-exn exn:fail? (λ() (get (make-hash `((a . ,(list 1)) (b . ,(list 2)) (c . ,(list 3)))) 'z))) ; nonexistent key + +(check-equal? (get (string->path "/root/foo/bar/file.txt") 1) (string->path "root")) +(check-equal? (get (string->path "/root/foo/bar/file.txt") 0 3) + (map string->path '("/" "root" "foo"))) + +(check-equal? (get (make-hash '((a . 1) (b . 2) (c . 3))) 'b) 2) + +(check-true (2 . in? . '(1 2 3))) +(check-false (4 . in? . '(1 2 3))) +(check-true (2 . in? . (list->vector '(1 2 3)))) +(check-false (4 . in? . (list->vector '(1 2 3)))) +(check-true ('a . in? . (make-hash '((a . 1) (b . 2) (c . 3))))) +(check-false ('x . in? . (make-hash '((a . 1) (b . 2) (c . 3))))) +(check-true ("o" . in? . "foobar")) +(check-false ("z" . in? . "foobar")) +(check-true ('o . in? . 'foobar)) +(check-false ('z . in? . 'foobar)) +(check-true ("F" . in? . #\F)) + +(check-true (in? "foo" (string->path "/root/foo/bar/file.txt"))) +(check-false (in? "zam" (string->path "/root/foo/bar/file.txt"))) + +(define ys (range 5)) +(check-equal? (values->list (shift/values ys '(-1 0 1) 'boing)) `((1 2 3 4 boing) ,xs (boing 0 1 2 3))) (require xml) diff --git a/test/no-lang-line-source.txt b/sugar/test/no-lang-line-source.txt similarity index 100% rename from test/no-lang-line-source.txt rename to sugar/test/no-lang-line-source.txt diff --git a/test/source.rkt b/sugar/test/source.rkt similarity index 100% rename from test/source.rkt rename to sugar/test/source.rkt diff --git a/sugar/test/test-require-modes.rkt b/sugar/test/test-require-modes.rkt new file mode 100644 index 0000000..c33f0b9 --- /dev/null +++ b/sugar/test/test-require-modes.rkt @@ -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))) \ No newline at end of file diff --git a/xml.rkt b/sugar/xml.rkt similarity index 100% rename from xml.rkt rename to sugar/xml.rkt diff --git a/typed/sugar.rkt b/typed/sugar.rkt new file mode 100644 index 0000000..922e3d1 --- /dev/null +++ b/typed/sugar.rkt @@ -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") \ No newline at end of file diff --git a/typed/sugar/cache.rkt b/typed/sugar/cache.rkt new file mode 100644 index 0000000..6d032ee --- /dev/null +++ b/typed/sugar/cache.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 ...))])) \ No newline at end of file diff --git a/typed/sugar/coerce.rkt b/typed/sugar/coerce.rkt new file mode 100644 index 0000000..29e2d50 --- /dev/null +++ b/typed/sugar/coerce.rkt @@ -0,0 +1,109 @@ +#lang typed/racket/base +(require (for-syntax typed/racket/base racket/syntax)) +(require typed/net/url racket/set racket/sequence) +(require typed/sugar/define) +(require "len.rkt") ; want relative path-spec for bilingual conversion + +(define-syntax-rule (make-coercion-error-handler target-format x) + (λ(e) (error (format "Can’t convert ~s to ~a" x target-format)))) + + +(define-type Intable (U Lengthable Number String Symbol Char Path)) +(define/typed+provide (->int x) + (Intable -> Integer) + (with-handlers ([exn:fail? (make-coercion-error-handler 'integer x)]) + (cond + [(or (integer? x) (real? x)) (assert (inexact->exact (floor x)) integer?)] + [(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)) (->int (->string x))] + [(char? x) (char->integer x)] + [else (len x)]))) ; covers Lengthable types + + +(provide Stringish) +(define-type Stringish (U String Symbol Number Path Char Null Void)) + + +(define/typed+provide (->string x) + (Stringish -> 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)] + [(char? x) (format "~a" 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/typed+provide (->symbol x) + (Stringish -> Symbol) + (if (symbol? x) + x + (with-handlers ([exn:fail? (make-coercion-error-handler 'symbol x)]) + (string->symbol (->string x))))) + + +(define-type Pathish (U Stringish url)) +(provide Pathish) +(define/typed+provide (->path x) + (Pathish -> Path) + (if (path? x) + x + (with-handlers ([exn:fail? (make-coercion-error-handler 'path x)]) + (cond + [(url? x) (apply build-path (cast (map path/param-path (url-path x)) (List* Path-String (Listof Path-String))))] + [else (string->path (->string x))])))) + + +;; Use private name here because 'URL' identifier has been added since 6.0 +(define-type SugarURL url) +(define/typed+provide (->url x) + (Stringish -> SugarURL) + (with-handlers ([exn:fail? (make-coercion-error-handler 'url x)]) + (string->url (->string x)))) + + +(define/typed+provide (->complete-path x) + (Stringish -> Path) + (with-handlers ([exn:fail? (make-coercion-error-handler 'complete-path x)]) + (path->complete-path (->path x)))) + + +(define/typed+provide (->list x) + (Any -> (Listof Any)) + (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/typed+provide (->vector x) + (Any -> VectorTop) + (if (vector? x) + x + (with-handlers ([exn:fail? (make-coercion-error-handler 'vector x)]) + (list->vector (->list x))))) + + +(define/typed+provide (->boolean x) + (Any -> Boolean) + (and x #t)) \ No newline at end of file diff --git a/debug.rkt b/typed/sugar/debug.rkt similarity index 98% rename from debug.rkt rename to typed/sugar/debug.rkt index 7974e75..95ece24 100644 --- a/debug.rkt +++ b/typed/sugar/debug.rkt @@ -1,4 +1,4 @@ -#lang racket/base +#lang typed/racket/base (require (for-syntax racket/base racket/syntax)) (provide (all-defined-out)) diff --git a/typed/sugar/define.rkt b/typed/sugar/define.rkt new file mode 100644 index 0000000..030f738 --- /dev/null +++ b/typed/sugar/define.rkt @@ -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)))])) \ No newline at end of file diff --git a/typed/sugar/file.rkt b/typed/sugar/file.rkt new file mode 100644 index 0000000..22d325e --- /dev/null +++ b/typed/sugar/file.rkt @@ -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)))))) + diff --git a/len.rkt b/typed/sugar/len.rkt similarity index 53% rename from len.rkt rename to typed/sugar/len.rkt index e898057..7f6fa0c 100644 --- a/len.rkt +++ b/typed/sugar/len.rkt @@ -1,9 +1,12 @@ -#lang racket/base +#lang typed/racket/base (require racket/set racket/sequence) -(require "define.rkt") +(require typed/sugar/define) -(define+provide/contract (len x) - ((or/c list? vector? set? sequence? string? symbol? path? hash?) . -> . integer?) +(provide Lengthable) +(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 [(list? x) (length x)] [(string? x) (string-length x)] diff --git a/typed/sugar/list.rkt b/typed/sugar/list.rkt new file mode 100644 index 0000000..f042755 --- /dev/null +++ b/typed/sugar/list.rkt @@ -0,0 +1,174 @@ +#lang typed/racket/base +(require (for-syntax racket/base racket/syntax)) +(require (except-in racket/list flatten dropf dropf-right) typed/sugar/define "coerce.rkt" "len.rkt") +(require/typed racket/list [dropf (All (A) (Listof A) (A -> Boolean) -> (Listof A))] + [dropf-right (All (A) (Listof A) (A -> Boolean) -> (Listof A))]) +;; use fully-qualified paths in require, +;; so they'll work when this file is included elsewhere +(provide (all-defined-out)) + +(define/typed+provide (trimf xs test-proc) + (All (A) ((Listof A) (A -> Boolean) -> (Listof A))) + (dropf-right (dropf xs test-proc) test-proc)) + +(define/typed+provide slicef-at + ;; with polymorphic function, use cased typing to simulate optional position arguments + (All (A) (case-> ((Listof A) (A -> Boolean) -> (Listof (Listof A))) + ((Listof A) (A -> Boolean) Boolean -> (Listof (Listof A))))) + (case-lambda + [(xs pred) + (slicef-at xs pred #f)] + [(xs pred force?) + (define-values (last-list list-of-lists) + (for/fold: + ([current-list : (Listof A) empty][list-of-lists : (Listof (Listof A)) empty]) + ([x (in-list xs)]) + (if (pred x) + (values (cons x null) (if (not (empty? current-list)) + (cons (reverse current-list) list-of-lists) + list-of-lists)) + (values (cons x current-list) list-of-lists)))) + (let ([list-of-lists (reverse (if (empty? last-list) + list-of-lists + (cons (reverse last-list) list-of-lists)))]) + (if (and force? (not (empty? list-of-lists)) (not (pred (caar list-of-lists)))) + (cdr list-of-lists) + list-of-lists))])) + +(define/typed+provide (slicef-after xs pred) + (All (A) ((Listof A) (A -> Boolean) -> (Listof (Listof A)))) + (define-values (last-list list-of-lists) + (for/fold: ([current-list : (Listof A) empty][list-of-lists : (Listof (Listof A)) empty]) + ([x (in-list xs)]) + (if (pred x) + (values empty (cons (reverse (cons x current-list)) list-of-lists)) + (values (cons x current-list) list-of-lists)))) + (reverse (if (empty? last-list) + list-of-lists + (cons (reverse last-list) list-of-lists)))) + + +(define/typed+provide slice-at + ;; with polymorphic function, use cased typing to simulate optional position arguments + (All (A) (case-> ((Listof A) Positive-Integer -> (Listof (Listof A))) + ((Listof A) Positive-Integer Boolean -> (Listof (Listof A))))) + (case-lambda + [(xs len) + (slice-at xs len #f)] + [(xs len force?) + (define-values (last-list list-of-lists) + (for/fold: ([current-list : (Listof A) empty][list-of-lists : (Listof (Listof A)) empty]) + ([x (in-list xs)][i (in-naturals)]) + (if (= (modulo (add1 i) len) 0) + (values empty (cons (reverse (cons x current-list)) list-of-lists)) + (values (cons x current-list) list-of-lists)))) + (reverse (if (or (empty? last-list) (and force? (not (= len (length last-list))))) + list-of-lists + (cons (reverse last-list) list-of-lists)))])) + + +(define/typed+provide (filter-split xs pred) + (All (A) ((Listof A) (A -> Boolean) -> (Listof (Listof A)))) + (define-values (last-list list-of-lists) + (for/fold: ([current-list : (Listof A) empty][list-of-lists : (Listof (Listof A)) empty]) + ([x (in-list xs)]) + (if (pred x) + (values empty (if (not (empty? current-list)) + (cons (reverse current-list) list-of-lists) + list-of-lists)) + (values (cons x current-list) list-of-lists)))) + (reverse (if (not (empty? last-list)) + (cons (reverse last-list) list-of-lists) + list-of-lists))) + +(define/typed+provide (frequency-hash xs) + (All (A) ((Listof A) -> (HashTable A Integer))) + (define counter ((inst make-hash A Integer))) + (for ([item (in-list xs)]) + (hash-update! counter item (λ:([v : Integer]) (add1 v)) (λ _ 0))) + counter) + + + +(define/typed+provide (members-unique? x) + (All (A) ((U (Listof A) (Vectorof A) 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))])) + + +(define/typed+provide (members-unique?/error x) + (All (A) ((U (Listof A) (Vectorof A) String) -> Boolean)) + (define result (members-unique? x)) + (if (not result) + (let* ([duplicate-keys (filter-not empty? (hash-map (frequency-hash (->list x)) + (λ:([element : Any] [freq : Integer]) (if (> freq 1) element '()))))]) + (error (string-append "members-unique? failed because " (if (= (len duplicate-keys) 1) + "item isn’t" + "items aren’t") " unique:") duplicate-keys)) + result)) + + +;; for use inside quasiquote +;; instead of ,(when ...) use ,@(when/splice ...) +;; to avoid voids +(provide when/splice) +(define-syntax (when/splice stx) + (syntax-case stx () + [(_ test body) + #'(if test (list body) '())])) + +(provide values->list) +(define-syntax (values->list stx) + (syntax-case stx () + [(_ values-expr) #'(call-with-values (λ () values-expr) list)])) + + +(define/typed+provide (sublist xs i j) + (All (A) ((Listof A) Index Index -> (Listof A))) + (cond + [(> j (length xs)) (error 'sublist (format "ending index ~a exceeds length of list" j))] + [(>= j i) (take (drop xs i) (- j i))] + [else (error 'sublist (format "starting index ~a is larger than ending index ~a" i j))])) + + +(define/typed+provide (break-at xs bps) + (All (A) ((Listof A) (U Index (Listof Index)) -> (Listof (Listof A)))) + (let ([bps (if (list? bps) bps (list bps))]) ; coerce bps to list + (when (ormap (λ:([bp : Index]) (>= bp (length xs))) bps) + (error 'break-at (format "breakpoint in ~v is greater than or equal to input list length = ~a" bps (length xs)))) + ;; 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 + (reverse (let loop ([xs xs][bps (reverse (cons 0 bps))]) + (if (= (car bps) 0) + (cons xs null) ; return whatever's left, because no more splits are possible + (let-values ([(head tail) (split-at xs (car bps))]) + (cons tail (loop head (cdr bps))))))))) + + +(define/typed+provide shift + (case-> ((Listof Any) (U Integer (Listof Integer)) -> (Listof Any)) + ((Listof Any) (U Integer (Listof Integer)) Any -> (Listof Any)) + ((Listof Any) (U Integer (Listof Integer)) Any Boolean -> (Listof Any))) + (case-lambda + [(xs shift-amount-or-amounts) + (shift xs shift-amount-or-amounts #f #f)] + [(xs shift-amount-or-amounts fill-item) + (shift xs shift-amount-or-amounts fill-item #f)] + [(xs shift-amount-or-amounts fill-item cycle) + (define/typed (do-shift xs how-far) + ((Listof Any) Integer -> (Listof Any)) + (define abs-how-far (abs how-far)) + (cond + [(> abs-how-far (length xs)) (error 'shift "index is too large for list\nindex: ~a\nlist: ~v" how-far xs)] + [(= how-far 0) xs] + [(positive? how-far) + (append (make-list abs-how-far fill-item) (drop-right xs abs-how-far))] + ;; otherwise how-far is negative + [else (append (drop xs abs-how-far) (make-list abs-how-far fill-item))])) + (if (list? shift-amount-or-amounts) + (map (λ:([amount : Integer]) (do-shift xs amount)) shift-amount-or-amounts) + (do-shift xs shift-amount-or-amounts))])) diff --git a/misc.rkt b/typed/sugar/misc.rkt similarity index 86% rename from misc.rkt rename to typed/sugar/misc.rkt index 19a0606..c08e13d 100644 --- a/misc.rkt +++ b/typed/sugar/misc.rkt @@ -1,9 +1,8 @@ #lang racket/base -(require (for-syntax racket/base)) -(require "define.rkt") +(require typed/sugar/define) -(define+provide/contract (bytecount->string bytecount) - (integer? . -> . string?) +(define/typed+provide (bytecount->string bytecount) + (Nonnegative-Integer -> String) (define (format-with-threshold threshold suffix) ;; upconvert by factor of 100 to get two digits after decimal (format "~a ~a" (exact->inexact (/ (round ((* bytecount 100) . / . threshold)) 100)) suffix)) diff --git a/typed/sugar/string.rkt b/typed/sugar/string.rkt new file mode 100644 index 0000000..e295d9b --- /dev/null +++ b/typed/sugar/string.rkt @@ -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))))) diff --git a/typed/sugar/test.rkt b/typed/sugar/test.rkt new file mode 100644 index 0000000..63e027d --- /dev/null +++ b/typed/sugar/test.rkt @@ -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)) diff --git a/typed/sugar/test/main.rkt b/typed/sugar/test/main.rkt new file mode 100644 index 0000000..8433bbd --- /dev/null +++ b/typed/sugar/test/main.rkt @@ -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 +|# \ No newline at end of file diff --git a/typed/sugar/test/no-lang-line-source.txt b/typed/sugar/test/no-lang-line-source.txt new file mode 100644 index 0000000..56e53a3 --- /dev/null +++ b/typed/sugar/test/no-lang-line-source.txt @@ -0,0 +1 @@ +(define no-lang-symbol 'bar) \ No newline at end of file diff --git a/typed/sugar/test/source.rkt b/typed/sugar/test/source.rkt new file mode 100644 index 0000000..d82d324 --- /dev/null +++ b/typed/sugar/test/source.rkt @@ -0,0 +1,3 @@ +#lang typed/racket + +(define included-symbol 'bar) \ No newline at end of file diff --git a/typed/sugar/test/test-require-modes.rkt b/typed/sugar/test/test-require-modes.rkt new file mode 100644 index 0000000..c33f0b9 --- /dev/null +++ b/typed/sugar/test/test-require-modes.rkt @@ -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))) \ No newline at end of file diff --git a/typed/sugar/xml.rkt b/typed/sugar/xml.rkt new file mode 100644 index 0000000..9fb2f31 --- /dev/null +++ b/typed/sugar/xml.rkt @@ -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))))) +|# \ No newline at end of file