suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Move a bunch of functions from typed-scheme/utils/utils to unstable.

Browse Source 
Add convenience lib for unstable docs.
Add char support to format-{id,symbol}
Add unstable/sequence library.

svn: r16789

original commit: fb29a2498e964c6d7651ca6cc6a19c07ca28760b
This commit is contained in:
Sam Tobin-Hochstadt 2009-11-15 22:15:29 +00:00
parent 98b55a89ee
commit 2c76766c1c
22 changed files with 97 additions and 185 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/typed-scheme/env/lexical-env.ss vendored
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require (except-in "../utils/utils.ss" extend))
(require "type-environments.ss"
(require "../utils/utils.ss"
"type-environments.ss"
"type-env.ss"
unstable/mutated-vars
(only-in scheme/contract ->* ->)

4
collects/typed-scheme/env/type-alias-env.ss vendored
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require (except-in "../utils/utils.ss" extend))
(require syntax/boundmap
(require "../utils/utils.ss"
syntax/boundmap
(utils tc-utils)
mzlib/trace
scheme/match)

4
collects/typed-scheme/env/type-env.ss vendored
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require (except-in "../utils/utils.ss" extend))
(require syntax/boundmap
(require "../utils/utils.ss"
syntax/boundmap
(utils tc-utils)
(types utils))

16
collects/typed-scheme/infer/constraint-structs.ss
View File

@ -1,8 +1,6 @@
#lang scheme/base
(require (except-in "../utils/utils.ss" extend))
(require (rep type-rep)
scheme/contract)
(require "../utils/utils.ss" (rep type-rep) scheme/contract)
;; S, T types
;; X a var
@ -31,9 +29,9 @@
;; don't want to rule them out too early
(define-struct cset (maps) #:prefab)
(provide/contract (struct c ([S Type?] [X symbol?] [T Type?]))
(struct dcon ([fixed (listof c?)] [rest (or/c c? false/c)]))
(struct dcon-exact ([fixed (listof c?)] [rest c?]))
(struct dcon-dotted ([type c?] [bound symbol?]))
(struct dmap ([map (hashof symbol? (or/c dcon? dcon-exact? dcon-dotted?))]))
(struct cset ([maps (listof (cons/c (hashof symbol? c?) dmap?))])))
(p/c (struct c ([S Type?] [X symbol?] [T Type?]))
(struct dcon ([fixed (listof c?)] [rest (or/c c? false/c)]))
(struct dcon-exact ([fixed (listof c?)] [rest c?]))
(struct dcon-dotted ([type c?] [bound symbol?]))
(struct dmap ([map (hash/c symbol? (or/c dcon? dcon-exact? dcon-dotted?))]))
(struct cset ([maps (listof (cons/c (hash/c symbol? c?) dmap?))])))

5
collects/typed-scheme/infer/constraints.ss
View File

@ -1,9 +1,10 @@
#lang scheme/unit
(require (except-in "../utils/utils.ss" extend))
(require (types convenience utils union subtype)
(require "../utils/utils.ss"
(types convenience utils union subtype)
(rep type-rep)
(utils tc-utils)
unstable/sequence
"signatures.ss" "constraint-structs.ss"
scheme/match)

9
collects/typed-scheme/infer/dmap.ss
View File

@ -1,8 +1,9 @@
#lang scheme/unit
(require (except-in "../utils/utils.ss" extend))
(require "signatures.ss" "constraint-structs.ss"
(require "../utils/utils.ss"
"signatures.ss" "constraint-structs.ss"
(utils tc-utils)
unstable/sequence
scheme/match)
(import constraints^)
@ -35,7 +36,7 @@
(fail! fixed1 fixed2))
(make-dcon
(for/list ([c1 fixed1]
[c2 (in-list-forever fixed2 rest)])
[c2 (in-sequence-forever fixed2 rest)])
(c-meet c1 c2 (c-X c1)))
#f)]
[((struct dcon (fixed1 rest)) (struct dcon (fixed2 #f)))
@ -47,7 +48,7 @@
(values fixed2 fixed1 rest2 rest1))])
(make-dcon
(for/list ([c1 longer]
[c2 (in-list-forever shorter srest)])
[c2 (in-sequence-forever shorter srest)])
(c-meet c1 c2 (c-X c1)))
(c-meet lrest srest (c-X lrest))))]
[((struct dcon-dotted (c1 bound1)) (struct dcon-dotted (c2 bound2)))

5
collects/typed-scheme/infer/infer-unit.ss
View File

@ -1,7 +1,7 @@
#lang scheme/unit
(require (except-in "../utils/utils.ss"))
(require (rep free-variance type-rep filter-rep rep-utils)
(require "../utils/utils.ss"
(rep free-variance type-rep filter-rep rep-utils)
(types convenience union subtype remove-intersect resolve)
(except-in (utils tc-utils) make-env)
(env type-name-env)
@ -12,6 +12,7 @@
scheme/match
mzlib/etc
mzlib/trace
unstable/sequence unstable/list
scheme/list)
(import dmap^ constraints^ promote-demote^)

4
collects/typed-scheme/private/parse-type.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require (except-in "../utils/utils.ss" extend))
(require (except-in (rep type-rep) make-arr)
(require "../utils/utils.ss"
(except-in (rep type-rep) make-arr)
(rename-in (types convenience union utils) [make-arr* make-arr])
(utils tc-utils stxclass-util)
syntax/stx (prefix-in c: scheme/contract)

4
collects/typed-scheme/private/prims.ss
View File

@ -24,8 +24,8 @@ This file defines two sorts of primitives. All of them are provided into any mod
(rename-out [define-typed-struct define-struct:]
[define-typed-struct/exec define-struct/exec:]))
(require (except-in "../utils/utils.ss" extend))
(require (for-syntax
(require "../utils/utils.ss"
(for-syntax
syntax/parse
syntax/private/util
scheme/base

4
collects/typed-scheme/private/type-annotation.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require (except-in "../utils/utils.ss" extend))
(require (rep type-rep)
(require "../utils/utils.ss"
(rep type-rep)
(utils tc-utils)
(env type-env)
(except-in (types subtype union convenience resolve utils) -> ->*)

12
collects/typed-scheme/private/type-contract.ss
View File

@ -2,8 +2,8 @@
(provide type->contract define/fixup-contract? generate-contract-def change-contract-fixups)
(require (except-in "../utils/utils.ss" extend))
(require
"../utils/utils.ss"
(rep type-rep filter-rep object-rep)
(typecheck internal-forms)
(utils tc-utils require-contract)
@ -11,11 +11,7 @@
(types resolve utils)
(prefix-in t: (types convenience))
(private parse-type)
scheme/match
syntax/struct
syntax/stx
mzlib/trace
scheme/list
scheme/match syntax/struct syntax/stx mzlib/trace unstable/syntax scheme/list
(only-in scheme/contract -> ->* case-> cons/c flat-rec-contract provide/contract any/c)
(for-template scheme/base scheme/contract unstable/poly-c (only-in scheme/class object% is-a?/c subclass?/c)))
@ -111,8 +107,8 @@
[else (int-err "unknown var: ~a" v)])]
[(Poly: vs (and b (Function: _)))
(match-let ([(Poly-names: vs-nm _) ty])
(with-syntax ([(vs+ ...) (generate-temporaries (for/list ([v vs-nm]) (symbol-append v '+)))]
[(vs- ...) (generate-temporaries (for/list ([v vs-nm]) (symbol-append v '-)))])
(with-syntax ([(vs+ ...) (generate-temporaries (for/list ([v vs-nm]) (format-symbol "~a+" v)))]
[(vs- ...) (generate-temporaries (for/list ([v vs-nm]) (format-symbol "~a-" v)))])
(parameterize ([vars (append (map list
vs
(syntax->list #'(vs+ ...))

22
collects/typed-scheme/rep/rep-utils.ss
View File

@ -6,6 +6,7 @@
syntax/boundmap
"free-variance.ss"
"interning.ss"
unstable/syntax
mzlib/etc
scheme/contract
(for-syntax
@ -17,6 +18,7 @@
syntax/struct
syntax/stx
scheme/contract
unstable/syntax
(rename-in (except-in (utils utils stxclass-util) bytes byte-regexp regexp byte-pregexp #;pregexp)
[id* id]
[keyword* keyword])))
@ -75,13 +77,13 @@
(~optional [#:contract cnt:expr])
(~optional no-provide?:no-provide-kw)) ...)
(with-syntax*
([ex (mk-id #'nm #'nm ":")]
[fold-name (mk-id #f #'nm "-fold")]
([ex (format-id #'nm "~a:" #'nm)]
[fold-name (format-id #f "~a-fold" #'nm)]
[kw-stx (string->keyword (symbol->string (attribute nm.datum)))]
[parent par]
[(s:ty maker pred acc ...) (build-struct-names #'nm (syntax->list #'flds.fs) #f #t #'nm)]
[*maker (mk-id #'nm "*" #'nm)]
[**maker (mk-id #'nm "**" #'nm)]
[*maker (format-id #'nm "*~a" #'nm)]
[**maker (format-id #'nm "**~a" #'nm)]
[*maker-cnt (if enable-contracts?
(or (attribute cnt) #'(flds.cnt ... . -> . pred))
#'any/c)]
@ -251,12 +253,12 @@
#:with name #'i
#:with keyword (datum->syntax #f (string->keyword (symbol->string (syntax-e #'i))))
#:with tmp-rec-id (generate-temporary)
#:with case (mk-id #'i (attribute lower-s) "-case")
#:with printer (mk-id #'i "print-" (attribute lower-s) "*")
#:with ht (mk-id #'i (attribute lower-s) "-name-ht")
#:with rec-id (mk-id #'i (attribute lower-s) "-rec-id")
#:with d-id (mk-id #'i "d" (attribute first-letter))
#:with (_ _ pred? accs ...)
#:with case (format-id #'i "~a-case" (attribute lower-s))
#:with printer (format-id #'i "print-~a*" (attribute lower-s))
#:with ht (format-id #'i "~a-name-ht" (attribute lower-s))
#:with rec-id (format-id #'i "~a-rec-id" (attribute lower-s))
#:with d-id (format-id #'i "d~a" (attribute first-letter))
#:with (_ _ pred? accs ...)
(datum->syntax #f (build-struct-names #'name (syntax->list #'(fld-names ...)) #f #t #'name))))
(syntax-parse stx
[(_ i:type-name ...)

4
collects/typed-scheme/typecheck/check-subforms-unit.ss
View File

@ -1,7 +1,7 @@
#lang scheme/unit
(require (except-in "../utils/utils.ss" extend))
(require syntax/kerncase
(require "../utils/utils.ss"
syntax/kerncase
scheme/match
"signatures.ss" "tc-metafunctions.ss"
(types utils convenience union subtype)

4
collects/typed-scheme/typecheck/provide-handling.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require (except-in "../utils/utils.ss" extend))
(require (only-in srfi/1/list s:member)
(require "../utils/utils.ss"
(only-in srfi/1/list s:member)
syntax/kerncase syntax/boundmap
(env type-name-env type-alias-env)
mzlib/trace

3
collects/typed-scheme/typecheck/tc-app.ss
View File

@ -4,6 +4,7 @@
"signatures.ss" "tc-metafunctions.ss"
"tc-app-helper.ss" "find-annotation.ss"
syntax/parse scheme/match mzlib/trace scheme/list
unstable/sequence
;; fixme - don't need to be bound in this phase - only to make syntax/parse happy
scheme/bool
(only-in scheme/private/class-internal make-object do-make-object)
@ -677,7 +678,7 @@
[(and rest (< (length t-a) (length dom)))
(tc-error/expr #:return (ret t-r)
"Wrong number of arguments, expected at least ~a and got ~a" (length dom) (length t-a))])
(for ([dom-t (if rest (in-list-forever dom rest) (in-list dom))] [a (syntax->list args-stx)] [arg-t (in-list t-a)])
(for ([dom-t (if rest (in-sequence-forever dom rest) (in-list dom))] [a (syntax->list args-stx)] [arg-t (in-list t-a)])
(parameterize ([current-orig-stx a]) (check-below arg-t dom-t))))
(let* (;; Listof[Listof[LFilterSet]]
[lfs-f (for/list ([lf lf-r])

2
collects/typed-scheme/typecheck/tc-if.ss
View File

@ -1,7 +1,7 @@
#lang scheme/unit
(require (rename-in "../utils/utils.ss" [infer r:infer] [extend r:extend]))
(require (rename-in "../utils/utils.ss" [infer r:infer]))
(require "signatures.ss"
(rep type-rep filter-rep object-rep)
(rename-in (types convenience subtype union utils comparison remove-intersect)

2
collects/typed-scheme/typecheck/tc-lambda-unit.ss
View File

@ -1,6 +1,6 @@
#lang scheme/unit
(require (rename-in "../utils/utils.ss" [infer r:infer] [extend r:extend])
(require (rename-in "../utils/utils.ss" [infer r:infer])
"signatures.ss"
"tc-metafunctions.ss"
mzlib/trace

4
collects/typed-scheme/typecheck/tc-structs.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require (except-in "../utils/utils.ss" extend))
(require (rep type-rep)
(require "../utils/utils.ss"
(rep type-rep)
(private parse-type)
(types convenience utils union resolve abbrev)
(env type-env type-environments type-name-env)

1
collects/typed-scheme/typecheck/tc-toplevel.ss
View File

@ -3,6 +3,7 @@
(require (rename-in "../utils/utils.ss" [infer r:infer]))
(require syntax/kerncase
unstable/list
mzlib/etc
scheme/match
"signatures.ss"

10
collects/typed-scheme/typed-scheme.ss
View File

@ -13,7 +13,7 @@
(r:infer infer)
(utils tc-utils)
(rep type-rep)
(except-in (utils utils) infer extend)
(except-in (utils utils) infer)
(only-in (r:infer infer-dummy) infer-param)
scheme/nest
syntax/kerncase
@ -36,11 +36,7 @@
(define-syntax (module-begin stx)
(define module-name (syntax-property stx 'enclosing-module-name))
;(printf "BEGIN: ~a~n" (syntax->datum stx))
(with-logging-to-file
(build-path (find-system-path 'temp-dir) "ts-poly.log")
#;
(log-file-name (syntax-source stx) module-name)
(syntax-case stx ()
(syntax-case stx ()
[(mb forms ...)
(nest
([begin (set-box! typed-context? #t)
@ -90,7 +86,7 @@
#;(printf "tried to create ~a types~n" (all-count!))
#;(printf "created ~a union types~n" (union-count!))
;; reconstruct the module with the extra code
#'(#%module-begin transformed-body ... after-code check-syntax-help))])))
#'(#%module-begin transformed-body ... after-code check-syntax-help))]))
(define-syntax (top-interaction stx)
(syntax-case stx ()

4
collects/typed-scheme/types/remove-intersect.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require (except-in "../utils/utils.ss" extend))
(require (rep type-rep rep-utils)
(require "../utils/utils.ss"
(rep type-rep rep-utils)
(types union subtype resolve convenience utils)
scheme/match mzlib/trace)

155
collects/typed-scheme/utils/utils.ss
View File

@ -8,24 +8,23 @@ at least theoretically.
(require (for-syntax scheme/base syntax/parse scheme/string)
scheme/contract mzlib/plt-match scheme/require-syntax scheme/provide-syntax
mzlib/struct scheme/unit
(except-in syntax/parse id))
scheme/pretty mzlib/pconvert
(except-in syntax/parse id))
(provide with-syntax* syntax-map start-timing do-time reverse-begin printf/log
with-logging-to-file log-file-name ==
define-struct/printer
(rename-out [id mk-id])
filter-multiple
hash-union
in-pairs
in-list-forever
extend
debug
in-syntax
symbol-append
custom-printer
rep utils typecheck infer env private
hashof)
;; to move to unstable
(provide == hash-union debug reverse-begin)
(provide
;; timing
start-timing do-time
;; logging
printf/log
;; struct printing
custom-printer define-struct/printer
;; provide macros
rep utils typecheck infer env private)
;; fancy require syntax
(define-syntax (define-requirer stx)
(syntax-parse stx
[(_ nm:id nm-out:id)
@ -81,13 +80,7 @@ at least theoretically.
(define-requirer private private-out)
(define-requirer types types-out)
(define-sequence-syntax in-syntax
(lambda () #'syntax->list)
(lambda (stx)
(syntax-case stx ()
[[ids (_ arg)]
#'[ids (in-list (syntax->list arg))]])))
;; printf debugging convenience
(define-syntax debug
(syntax-rules ()
[(_ (f . args))
@ -106,58 +99,23 @@ at least theoretically.
(printf "result was ~a~n" e)
e))]))
(define-syntax (with-syntax* stx)
(syntax-case stx ()
[(_ (cl) body ...) #'(with-syntax (cl) body ...)]
[(_ (cl cls ...) body ...)
#'(with-syntax (cl) (with-syntax* (cls ...) body ...))]
))
;; run `h' last, but drop its return value
(define-syntax-rule (reverse-begin h . forms) (begin0 (begin . forms) h))
(define (filter-multiple l . fs)
(apply values
(map (lambda (f) (filter f l)) fs)))
(define (syntax-map f stxl)
(map f (syntax->list stxl)))
(define-syntax reverse-begin
(syntax-rules () [(_ h . forms) (begin0 (begin . forms) h)]))
#;
(define-syntax define-simple-syntax
(syntax-rules ()
[(dss (n . pattern) template)
(define-syntax n (syntax-rules () [(n . pattern) template]))]))
(define log-file (make-parameter #f))
;; conditionalized logging
;; there's some logging code in the source
;; which was used for gathering statistics about various programs
;; no longer used, probably bitrotted
(define-for-syntax logging? #f)
(require (only-in mzlib/file file-name-from-path))
(define-syntax (printf/log stx)
(if logging?
(syntax-case stx ()
[(_ fmt . args)
#'(when (log-file)
(fprintf (log-file) (string-append "~a: " fmt)
(file-name-from-path (object-name (log-file)))
. args))])
#'(log-debug (format fmt . args))])
#'(void)))
(define (log-file-name src module-name)
(if (path? src)
(path-replace-suffix src ".log")
(format "~a.log" module-name)))
(define-syntax (with-logging-to-file stx)
(syntax-case stx ()
[(_ file . body)
(if logging?
#'(parameterize ([log-file (open-output-file file #:exists 'append)])
. body)
#'(begin . body))]))
;; some macros to do some timing, only when `timing?' is #t
(define-for-syntax timing? #f)
(define last-time (make-parameter #f))
@ -184,9 +142,6 @@ at least theoretically.
(values (lambda _ #'(void)) (lambda _ #'(void)))))
(define (symbol-append . args)
(string->symbol (apply string-append (map symbol->string args))))
(define-match-expander
==
(lambda (stx)
@ -194,6 +149,11 @@ at least theoretically.
[(_ val)
#'(? (lambda (x) (equal? val x)))])))
;; custom printing
;; this requires lots of work for two reasons:
;; - 1 printers have to be defined at the same time as the structs
;; - 2 we want to support things printing corectly even when the custom printer is off
(define-for-syntax printing? #t)
(define-syntax-rule (defprinter t ...)
@ -217,8 +177,6 @@ at least theoretically.
(define custom-printer (make-parameter #t))
(require scheme/pretty mzlib/pconvert)
(define-syntax (define-struct/printer stx)
(syntax-case stx ()
[(form name (flds ...) printer)
@ -228,16 +186,6 @@ at least theoretically.
#'([prop:custom-write pseudo-printer]))
#f)]))
(define (id kw . args)
(define (f v)
(cond [(string? v) v]
[(symbol? v) (symbol->string v)]
[(char? v) (string v)]
[(identifier? v) (symbol->string (syntax-e v))]
[else (error "not coerceable:" v)]))
(datum->syntax kw (string->symbol (apply string-append (map f args)))))
;; map map (key val val -> val) -> map
(define (hash-union h1 h2 f)
(for/fold ([h* h1])
@ -249,36 +197,12 @@ at least theoretically.
(hash-set h* k new-val))))
(define (in-pairs seq)
(make-do-sequence
(lambda ()
(let-values ([(more? gen) (sequence-generate seq)])
(values (lambda (e) (let ([e (gen)]) (values (car e) (cdr e))))
(lambda (_) #t)
#t
(lambda (_) (more?))
(lambda _ #t)
(lambda _ #t))))))
(define (in-list-forever seq val)
(make-do-sequence
(lambda ()
(let-values ([(more? gen) (sequence-generate seq)])
(values (lambda (e) (let ([e (if (more?) (gen) val)]) e))
(lambda (_) #t)
#t
(lambda (_) #t)
(lambda _ #t)
(lambda _ #t))))))
;; Listof[A] Listof[B] B -> Listof[B]
;; pads out t to be as long as s
(define (extend s t extra)
(append t (build-list (- (length s) (length t)) (lambda _ extra))))
;; turn contracts on and off - off by default for performance.
(define-for-syntax enable-contracts? #f)
(provide (for-syntax enable-contracts?) p/c w/c cnt d-s/c d/c)
;; these are versions of the contract forms conditionalized by `enable-contracts?'
(define-syntax p/c
(if enable-contracts?
(make-rename-transformer #'provide/contract)
@ -286,7 +210,10 @@ at least theoretically.
(define-syntax-class clause
#:literals ()
#:attributes (i)
(pattern [rename out:id in:id cnt:expr]
(pattern [struct nm:id (flds ...)]
#:fail-unless (eq? (syntax-e #'struct) 'struct) #f
#:with i #'(struct-out nm))
(pattern [rename out:id in:id cnt:expr]
#:fail-unless (eq? (syntax-e #'rename) 'rename) #f
#:with i #'(rename-out [out in]))
(pattern [i:id cnt:expr]))
@ -323,15 +250,3 @@ at least theoretically.
(if enable-contracts?
(list #'[contracted (nm cnt)])
(list #'nm))]))
(define (hashof k/c v/c)
(flat-named-contract
(format "#<hashof ~a ~a>" k/c v/c)
(lambda (h)
(define k/c? (if (flat-contract? k/c) (flat-contract-predicate k/c) k/c))
(define v/c? (if (flat-contract? v/c) (flat-contract-predicate v/c) v/c))
(and (hash? h)
(for/and ([(k v) h])
(and (k/c? k)
(v/c? v)))))))