Reorg to separate out files.
svn: r11857
This commit is contained in:
Sam Tobin-Hochstadt
parent
9b6a8d2e5a
commit
15e7be91f5
|
|
@ -1,10 +1,12 @@
|
|||
#lang s-exp "minimal.ss"
|
||||
|
||||
|
||||
|
||||
(providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app)
|
||||
(except "private/prims.ss"))
|
||||
(basics #%module-begin
|
||||
#%top-interaction
|
||||
lambda
|
||||
#%app))
|
||||
|
||||
(require "private/base-env.ss" "private/base-special-env.ss")
|
||||
(provide (rename-out [with-handlers: with-handlers]))
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
|
||||
(require (for-syntax scheme/base))
|
||||
|
||||
(define-for-syntax ts-mod "typed-scheme.ss")
|
||||
(define-for-syntax ts-mod 'typed-scheme/typed-scheme)
|
||||
|
||||
(define-syntax (providing stx)
|
||||
(syntax-case stx (libs from basics except)
|
||||
|
|
|
|||
|
|
@ -1,154 +1,72 @@
|
|||
#lang scheme/base
|
||||
#lang s-exp "env-lang.ss"
|
||||
|
||||
;; these are libraries providing functions we add types to that are not in scheme/base
|
||||
(require
|
||||
"extra-procs.ss"
|
||||
"../utils/utils.ss"
|
||||
(only-in scheme/list cons? take drop add-between last filter-map)
|
||||
(only-in rnrs/lists-6 fold-left)
|
||||
'#%paramz
|
||||
(only-in scheme/match/runtime match:error)
|
||||
scheme/promise
|
||||
string-constants/string-constant)
|
||||
(only-in scheme/match/runtime match:error))
|
||||
|
||||
[raise (Univ . -> . (Un))]
|
||||
|
||||
|
||||
;; these are all for constructing the types given to variables
|
||||
(require (for-syntax
|
||||
scheme/base
|
||||
(env init-envs)
|
||||
(except-in (rep effect-rep type-rep) make-arr)
|
||||
"type-effect-convenience.ss"
|
||||
(only-in "type-effect-convenience.ss" [make-arr* make-arr])
|
||||
"union.ss"
|
||||
(typecheck tc-structs)))
|
||||
|
||||
(define-for-syntax (initialize-others)
|
||||
(d-s date
|
||||
([second : N] [minute : N] [hour : N] [day : N] [month : N]
|
||||
[year : N] [weekday : N] [year-day : N] [dst? : B] [time-zone-offset : N])
|
||||
())
|
||||
(d-s exn ([message : -String] [continuation-marks : Univ]) ())
|
||||
(d-s (exn:fail exn) () (-String Univ))
|
||||
(d-s (exn:fail:read exn:fail) ([srclocs : (-lst Univ)]) (-String Univ))
|
||||
)
|
||||
|
||||
(provide (for-syntax initial-env initialize-others))
|
||||
|
||||
(define-syntax (define-initial-env stx)
|
||||
(syntax-case stx ()
|
||||
[(_ initial-env make-promise-ty language-ty qq-append-ty [id ty] ...)
|
||||
(with-syntax ([(_ make-promise . _)
|
||||
(local-expand #'(delay 3)
|
||||
'expression
|
||||
null)]
|
||||
[language
|
||||
(local-expand #'(this-language)
|
||||
'expression
|
||||
null)]
|
||||
[(_ qq-append . _)
|
||||
(local-expand #'`(,@'() 1)
|
||||
'expression
|
||||
null)])
|
||||
#`(define-for-syntax initial-env
|
||||
(make-env
|
||||
[make-promise make-promise-ty]
|
||||
[language language-ty]
|
||||
[qq-append qq-append-ty]
|
||||
[id ty] ...)))]))
|
||||
|
||||
(define-for-syntax (one-of/c . args)
|
||||
(apply Un (map -val args)))
|
||||
|
||||
|
||||
(define-initial-env initial-env
|
||||
;; make-promise
|
||||
(-poly (a) (-> (-> a) (-Promise a)))
|
||||
;; language
|
||||
Sym
|
||||
;; qq-append
|
||||
(-poly (a b)
|
||||
(cl->*
|
||||
(-> (-lst a) (-val '()) (-lst a))
|
||||
(-> (-lst a) (-lst b) (-lst (*Un a b)))))
|
||||
#|;; language
|
||||
[(expand '(this-language))
|
||||
Sym
|
||||
string-constants/string-constant]
|
||||
;; make-promise
|
||||
[(cadr (syntax->list (expand '(delay 3))))
|
||||
(-poly (a) (-> (-> a) (-Promise a)))
|
||||
scheme/promise]
|
||||
;; qq-append
|
||||
[(cadr (syntax->list (expand '`(,@'() 1))))
|
||||
(-poly (a b)
|
||||
(cl->*
|
||||
(-> (-lst a) (-val '()) (-lst a))
|
||||
(-> (-lst a) (-lst b) (-lst (*Un a b)))))]
|
||||
|#
|
||||
|
||||
|
||||
|
||||
[raise (Univ . -> . (Un))]
|
||||
|
||||
(car (make-Poly (list 'a 'b) (cl-> [((-pair (-v a) (-v b))) (-v a)]
|
||||
[((make-Listof (-v a))) (-v a)])))
|
||||
[first (make-Poly (list 'a 'b) (cl-> [((-pair (-v a) (-v b))) (-v a)]
|
||||
[((make-Listof (-v a))) (-v a)]))]
|
||||
[second (-poly (a b c)
|
||||
(car (-poly (a b) (cl-> [((-pair a b)) a]
|
||||
[((make-Listof a)) a])))
|
||||
[first (-poly (a b) (cl-> [((-pair a b)) a]
|
||||
[((make-Listof a)) a]))]
|
||||
[second (-poly (a b c)
|
||||
(cl->
|
||||
[((-pair a (-pair b c))) b]
|
||||
[((-lst a)) a]))]
|
||||
[third (-poly (a b c d)
|
||||
[third (-poly (a b c d)
|
||||
(cl->
|
||||
[((-pair a (-pair b (-pair c d)))) c]
|
||||
[((-lst a)) a]))]
|
||||
[fourth (-poly (a) ((-lst a) . -> . a))]
|
||||
[fifth (-poly (a) ((-lst a) . -> . a))]
|
||||
[sixth (-poly (a) ((-lst a) . -> . a))]
|
||||
[rest (-poly (a) ((-lst a) . -> . (-lst a)))]
|
||||
(cadr
|
||||
[fourth (-poly (a) ((-lst a) . -> . a))]
|
||||
[fifth (-poly (a) ((-lst a) . -> . a))]
|
||||
[sixth (-poly (a) ((-lst a) . -> . a))]
|
||||
[rest (-poly (a) ((-lst a) . -> . (-lst a)))]
|
||||
(cadr
|
||||
(-poly (a b c)
|
||||
(cl->
|
||||
[((-pair a (-pair b c))) b]
|
||||
[((-lst a)) a])))
|
||||
(caddr (-poly (a) (-> (-lst a) a)))
|
||||
(cadddr (-poly (a) (-> (-lst a) a)))
|
||||
(cdr (make-Poly (list 'a 'b) (cl-> [((-pair (-v a) (-v b))) (-v b)]
|
||||
[((make-Listof (-v a))) (make-Listof (-v a))])))
|
||||
(cddr (make-Poly (list 'a) (-> (make-Listof (-v a)) (make-Listof (-v a)))))
|
||||
(cdddr (make-Poly (list 'a) (-> (make-Listof (-v a)) (make-Listof (-v a)))))
|
||||
(cons (-poly (a b)
|
||||
(caddr (-poly (a) (-> (-lst a) a)))
|
||||
(cadddr (-poly (a) (-> (-lst a) a)))
|
||||
(cdr (-poly (a b) (cl-> [((-pair a b)) b]
|
||||
[((make-Listof a)) (make-Listof a)])))
|
||||
(cddr (-poly (a) (-> (make-Listof a) (make-Listof a))))
|
||||
(cdddr (-poly (a) (-> (make-Listof a) (make-Listof a))))
|
||||
(cons (-poly (a b)
|
||||
(cl-> [(a (-lst a)) (-lst a)]
|
||||
[(a b) (-pair a b)])))
|
||||
[*cons (-poly (a b) (cl->
|
||||
[*cons (-poly (a b) (cl->
|
||||
[(a b) (-pair a b)]
|
||||
[(a (-lst a)) (-lst a)]))]
|
||||
[*list? (make-pred-ty (-lst Univ))]
|
||||
[*list? (make-pred-ty (-lst Univ))]
|
||||
|
||||
(null? (make-pred-ty (-val null)))
|
||||
(eof-object? (make-pred-ty (-val eof)))
|
||||
[null (-val null)]
|
||||
(number? (make-pred-ty N))
|
||||
[char? (make-pred-ty -Char)]
|
||||
(integer? (make-pred-ty -Integer))
|
||||
(boolean? (make-pred-ty B))
|
||||
(add1 (cl->*
|
||||
(null? (make-pred-ty (-val null)))
|
||||
(eof-object? (make-pred-ty (-val eof)))
|
||||
[null (-val null)]
|
||||
(number? (make-pred-ty N))
|
||||
[char? (make-pred-ty -Char)]
|
||||
(integer? (make-pred-ty -Integer))
|
||||
(boolean? (make-pred-ty B))
|
||||
(add1 (cl->*
|
||||
(-> -Integer -Integer)
|
||||
(-> N N)))
|
||||
(sub1 (cl->*
|
||||
(sub1 (cl->*
|
||||
#;(-> -Integer -Integer)
|
||||
(-> N N)))
|
||||
(eq? (-> Univ Univ B))
|
||||
(eqv? (-> Univ Univ B))
|
||||
(equal? (-> Univ Univ B))
|
||||
(even? (-> N B))
|
||||
[assert (-poly (a) (-> (*Un a (-val #f)) a))]
|
||||
[gensym (cl-> [(Sym) Sym]
|
||||
(eq? (-> Univ Univ B))
|
||||
(eqv? (-> Univ Univ B))
|
||||
(equal? (-> Univ Univ B))
|
||||
(even? (-> N B))
|
||||
[assert (-poly (a) (-> (*Un a (-val #f)) a))]
|
||||
[gensym (cl-> [(Sym) Sym]
|
||||
[() Sym])]
|
||||
[string-append (->* null -String -String)]
|
||||
[open-input-string (-> -String -Input-Port)]
|
||||
[open-output-file
|
||||
[string-append (->* null -String -String)]
|
||||
[open-input-string (-> -String -Input-Port)]
|
||||
[open-output-file
|
||||
(->key -Pathlike
|
||||
#:mode (one-of/c 'binary 'text) #f
|
||||
#:exists (one-of/c 'error 'append 'update 'can-update
|
||||
|
|
@ -156,43 +74,43 @@
|
|||
'must-truncate 'truncate/replace)
|
||||
#f
|
||||
-Output-Port)]
|
||||
[read (cl->
|
||||
[read (cl->
|
||||
[(-Port) -Sexp]
|
||||
[() -Sexp])]
|
||||
[ormap (-polydots (a c b) (->... (list (->... (list a) (b b) c) (-lst a)) ((-lst b) b) c))]
|
||||
[andmap (-polydots (a c b) (->... (list (->... (list a) (b b) c) (-lst a)) ((-lst b) b) c))]
|
||||
[newline (cl-> [() -Void]
|
||||
[ormap (-polydots (a c b) (->... (list (->... (list a) (b b) c) (-lst a)) ((-lst b) b) c))]
|
||||
[andmap (-polydots (a c b) (->... (list (->... (list a) (b b) c) (-lst a)) ((-lst b) b) c))]
|
||||
[newline (cl-> [() -Void]
|
||||
[(-Port) -Void])]
|
||||
[not (-> Univ B)]
|
||||
[floor (-> N N)]
|
||||
[box (-poly (a) (a . -> . (make-Box a)))]
|
||||
[unbox (-poly (a) ((make-Box a) . -> . a))]
|
||||
[set-box! (-poly (a) ((make-Box a) a . -> . -Void))]
|
||||
[box? (make-pred-ty (make-Box Univ))]
|
||||
[cons? (make-pred-ty (-pair Univ Univ))]
|
||||
[pair? (make-pred-ty (-pair Univ Univ)) #;(-poly (a b) (make-pred-ty (-pair a b)))]
|
||||
[empty? (make-pred-ty (-val null))]
|
||||
[empty (-val null)]
|
||||
[string? (make-pred-ty -String)]
|
||||
[string (->* '() -Char -String)]
|
||||
[symbol? (make-pred-ty Sym)]
|
||||
[list? (make-pred-ty (-lst Univ))]
|
||||
[list (-poly (a) (->* '() a (-lst a)))]
|
||||
[procedure? (make-pred-ty (make-Function (list (make-top-arr))))]
|
||||
[map (-polydots (c a b) ((list ((list a) (b b) . ->... . c) (-lst a))
|
||||
[not (-> Univ B)]
|
||||
[floor (-> N N)]
|
||||
[box (-poly (a) (a . -> . (-box a)))]
|
||||
[unbox (-poly (a) ((-box a) . -> . a))]
|
||||
[set-box! (-poly (a) ((-box a) a . -> . -Void))]
|
||||
[box? (make-pred-ty (-box Univ))]
|
||||
[cons? (make-pred-ty (-pair Univ Univ))]
|
||||
[pair? (make-pred-ty (-pair Univ Univ)) #;(-poly (a b) (make-pred-ty (-pair a b)))]
|
||||
[empty? (make-pred-ty (-val null))]
|
||||
[empty (-val null)]
|
||||
[string? (make-pred-ty -String)]
|
||||
[string (->* '() -Char -String)]
|
||||
[symbol? (make-pred-ty Sym)]
|
||||
[list? (make-pred-ty (-lst Univ))]
|
||||
[list (-poly (a) (->* '() a (-lst a)))]
|
||||
[procedure? (make-pred-ty (make-Function (list (make-top-arr))))]
|
||||
[map (-polydots (c a b) ((list ((list a) (b b) . ->... . c) (-lst a))
|
||||
((-lst b) b) . ->... .(-lst c)))]
|
||||
[for-each (-polydots (c a b) ((list ((list a) (b b) . ->... . Univ) (-lst a))
|
||||
[for-each (-polydots (c a b) ((list ((list a) (b b) . ->... . Univ) (-lst a))
|
||||
((-lst b) b) . ->... . -Void))]
|
||||
[fold-left (-polydots (c a b) ((list ((list c a) (b b) . ->... . c) c (-lst a))
|
||||
[fold-left (-polydots (c a b) ((list ((list c a) (b b) . ->... . c) c (-lst a))
|
||||
((-lst b) b) . ->... . c))]
|
||||
[fold-right (-polydots (c a b) ((list ((list c a) (b b) . ->... . c) c (-lst a))
|
||||
[fold-right (-polydots (c a b) ((list ((list c a) (b b) . ->... . c) c (-lst a))
|
||||
((-lst b) b) . ->... . c))]
|
||||
[foldl
|
||||
[foldl
|
||||
(-poly (a b c)
|
||||
(cl-> [((a b . -> . b) b (make-Listof a)) b]
|
||||
[((a b c . -> . c) c (make-Listof a) (make-Listof b)) c]))]
|
||||
[foldr (-poly (a b c) ((a b . -> . b) b (-lst a) . -> . b))]
|
||||
[filter (-poly (a b) (cl->*
|
||||
[foldr (-poly (a b c) ((a b . -> . b) b (-lst a) . -> . b))]
|
||||
[filter (-poly (a b) (cl->*
|
||||
((a . -> . B
|
||||
:
|
||||
(list (make-Latent-Restrict-Effect b))
|
||||
|
|
@ -201,20 +119,20 @@
|
|||
. -> .
|
||||
(-lst b))
|
||||
((a . -> . B) (-lst a) . -> . (-lst a))))]
|
||||
[filter-map (-polydots (c a b)
|
||||
[filter-map (-polydots (c a b)
|
||||
((list
|
||||
((list a) (b b) . ->... . (-opt c))
|
||||
(-lst a))
|
||||
((-lst b) b) . ->... . (-lst c)))]
|
||||
[take (-poly (a) ((-lst a) -Integer . -> . (-lst a)))]
|
||||
[drop (-poly (a) ((-lst a) -Integer . -> . (-lst a)))]
|
||||
[last (-poly (a) ((-lst a) . -> . a))]
|
||||
[add-between (-poly (a b) ((-lst a) b . -> . (-lst (Un a b))))]
|
||||
[remove* (-poly (a b)
|
||||
[take (-poly (a) ((-lst a) -Integer . -> . (-lst a)))]
|
||||
[drop (-poly (a) ((-lst a) -Integer . -> . (-lst a)))]
|
||||
[last (-poly (a) ((-lst a) . -> . a))]
|
||||
[add-between (-poly (a b) ((-lst a) b . -> . (-lst (Un a b))))]
|
||||
[remove* (-poly (a b)
|
||||
(cl-> [((-lst a) (-lst a)) (-lst a)]
|
||||
[((-lst a) (-lst b) (a b . -> . B)) (-lst b)]))]
|
||||
|
||||
(error
|
||||
(error
|
||||
(make-Function (list
|
||||
(make-arr null (Un))
|
||||
(make-arr (list Sym -String) (Un) Univ)
|
||||
|
|
@ -222,142 +140,142 @@
|
|||
(make-arr (list Sym) (Un)))))
|
||||
|
||||
|
||||
[namespace-variable-value
|
||||
[namespace-variable-value
|
||||
(cl->
|
||||
[(Sym) Univ]
|
||||
[(Sym B -Namespace (-> Univ)) Univ])]
|
||||
|
||||
(match:error (Univ . -> . (Un)))
|
||||
(display
|
||||
(match:error (Univ . -> . (Un)))
|
||||
(display
|
||||
(cl->
|
||||
[(Univ) -Void]
|
||||
[(Univ -Port) -Void]))
|
||||
[void (->* '() Univ -Void)]
|
||||
[void? (make-pred-ty -Void)]
|
||||
[printf (->* (list -String) Univ -Void)]
|
||||
[fprintf (->* (list -Output-Port -String) Univ -Void)]
|
||||
[format (->* (list -String) Univ -String)]
|
||||
(fst (make-Poly (list 'a 'b) (-> (-pair (-v a) (-v b)) (-v a))))
|
||||
(snd (make-Poly (list 'a 'b) (-> (-pair (-v a) (-v b)) (-v b))))
|
||||
[void (->* '() Univ -Void)]
|
||||
[void? (make-pred-ty -Void)]
|
||||
[printf (->* (list -String) Univ -Void)]
|
||||
[fprintf (->* (list -Output-Port -String) Univ -Void)]
|
||||
[format (->* (list -String) Univ -String)]
|
||||
(fst (-poly (a b) (-> (-pair a b) a)))
|
||||
(snd (-poly (a b) (-> (-pair a b) b)))
|
||||
|
||||
(= (->* (list N N) N B))
|
||||
(>= (->* (list N N) N B))
|
||||
(< (->* (list N N) N B))
|
||||
(<= (->* (list N N) N B))
|
||||
[> (->* (list N) N B)]
|
||||
(zero? (N . -> . B))
|
||||
(* (cl->* (->* '() -Integer -Integer) (->* '() N N)))
|
||||
(/ (cl->* (->* (list N) N N)))
|
||||
(+ (cl->* (->* '() -Integer -Integer) (->* '() N N)))
|
||||
(- (cl->* (->* (list -Integer) -Integer -Integer) (->* (list N) N N)))
|
||||
(max (->* (list N) N N))
|
||||
(min (->* (list N) N N))
|
||||
[vector-ref
|
||||
(make-Poly (list 'a) ((make-Vector (-v a)) N . -> . (-v a)))]
|
||||
[build-vector (-poly (a) (-Integer (-Integer . -> . a) . -> . (make-Vector a)))]
|
||||
[build-list (-poly (a) (-Integer (-Integer . -> . a) . -> . (-lst a)))]
|
||||
[reverse (make-Poly '(a) (-> (make-Listof (-v a)) (make-Listof (-v a))))]
|
||||
[append (-poly (a) (->* (list) (-lst a) (-lst a)))]
|
||||
[length (make-Poly '(a) (-> (make-Listof (-v a)) -Integer))]
|
||||
[memq (make-Poly (list 'a) (-> (-v a) (make-Listof (-v a)) (-opt (make-Listof (-v a)))))]
|
||||
[memv (make-Poly (list 'a) (-> (-v a) (make-Listof (-v a)) (-opt (make-Listof (-v a)))))]
|
||||
[memf (-poly (a) ((a . -> . B) (-lst a) . -> . (-opt (-lst a))))]
|
||||
[member
|
||||
(= (->* (list N N) N B))
|
||||
(>= (->* (list N N) N B))
|
||||
(< (->* (list N N) N B))
|
||||
(<= (->* (list N N) N B))
|
||||
[> (->* (list N) N B)]
|
||||
(zero? (N . -> . B))
|
||||
(* (cl->* (->* '() -Integer -Integer) (->* '() N N)))
|
||||
(/ (cl->* (->* (list N) N N)))
|
||||
(+ (cl->* (->* '() -Integer -Integer) (->* '() N N)))
|
||||
(- (cl->* (->* (list -Integer) -Integer -Integer) (->* (list N) N N)))
|
||||
(max (->* (list N) N N))
|
||||
(min (->* (list N) N N))
|
||||
[vector-ref
|
||||
(-poly (a) ((-vec a) N . -> . a))]
|
||||
[build-vector (-poly (a) (-Integer (-Integer . -> . a) . -> . (-vec a)))]
|
||||
[build-list (-poly (a) (-Integer (-Integer . -> . a) . -> . (-lst a)))]
|
||||
[reverse (-poly (a) (-> (make-Listof a) (make-Listof a)))]
|
||||
[append (-poly (a) (->* (list) (-lst a) (-lst a)))]
|
||||
[length (-poly (a) (-> (make-Listof a) -Integer))]
|
||||
[memq (-poly (a) (-> a (make-Listof a) (-opt (make-Listof a))))]
|
||||
[memv (-poly (a) (-> a (make-Listof a) (-opt (make-Listof a))))]
|
||||
[memf (-poly (a) ((a . -> . B) (-lst a) . -> . (-opt (-lst a))))]
|
||||
[member
|
||||
(-poly (a) (a (-lst a) . -> . (-opt (-lst a))))]
|
||||
[findf (-poly (a) ((a . -> . B) (-lst a) . -> . (-opt a)))]
|
||||
[findf (-poly (a) ((a . -> . B) (-lst a) . -> . (-opt a)))]
|
||||
|
||||
[string<? (->* (list -String -String) -String B)]
|
||||
[string>? (->* (list -String -String) -String B)]
|
||||
[string=? (->* (list -String -String) -String B)]
|
||||
[char=? (->* (list -Char -Char) -Char B)]
|
||||
[char<=? (->* (list -Char -Char) -Char B)]
|
||||
[char>=? (->* (list -Char -Char) -Char B)]
|
||||
[char<? (->* (list -Char -Char) -Char B)]
|
||||
[char>? (->* (list -Char -Char) -Char B)]
|
||||
[char-ci=? (->* (list -Char -Char) -Char B)]
|
||||
[char-ci<=? (->* (list -Char -Char) -Char B)]
|
||||
[char-ci>=? (->* (list -Char -Char) -Char B)]
|
||||
[char-ci>? (->* (list -Char -Char) -Char B)]
|
||||
[char-ci<? (->* (list -Char -Char) -Char B)]
|
||||
[string<=? (->* (list -String -String) -String B)]
|
||||
[string>=? (->* (list -String -String) -String B)]
|
||||
[string<? (->* (list -String -String) -String B)]
|
||||
[string>? (->* (list -String -String) -String B)]
|
||||
[string=? (->* (list -String -String) -String B)]
|
||||
[char=? (->* (list -Char -Char) -Char B)]
|
||||
[char<=? (->* (list -Char -Char) -Char B)]
|
||||
[char>=? (->* (list -Char -Char) -Char B)]
|
||||
[char<? (->* (list -Char -Char) -Char B)]
|
||||
[char>? (->* (list -Char -Char) -Char B)]
|
||||
[char-ci=? (->* (list -Char -Char) -Char B)]
|
||||
[char-ci<=? (->* (list -Char -Char) -Char B)]
|
||||
[char-ci>=? (->* (list -Char -Char) -Char B)]
|
||||
[char-ci>? (->* (list -Char -Char) -Char B)]
|
||||
[char-ci<? (->* (list -Char -Char) -Char B)]
|
||||
[string<=? (->* (list -String -String) -String B)]
|
||||
[string>=? (->* (list -String -String) -String B)]
|
||||
|
||||
[string-ci<? (->* (list -String -String) -String B)]
|
||||
[string-ci>? (->* (list -String -String) -String B)]
|
||||
[string-ci=? (->* (list -String -String) -String B)]
|
||||
[string-ci<=? (->* (list -String -String) -String B)]
|
||||
[string-ci>=? (->* (list -String -String) -String B)]
|
||||
[string-ci<? (->* (list -String -String) -String B)]
|
||||
[string-ci>? (->* (list -String -String) -String B)]
|
||||
[string-ci=? (->* (list -String -String) -String B)]
|
||||
[string-ci<=? (->* (list -String -String) -String B)]
|
||||
[string-ci>=? (->* (list -String -String) -String B)]
|
||||
|
||||
[string-upcase (-> -String -String)]
|
||||
[string-downcase (-> -String -String)]
|
||||
[string-titlecase (-> -String -String)]
|
||||
[string-foldcase (-> -String -String)]
|
||||
[string-upcase (-> -String -String)]
|
||||
[string-downcase (-> -String -String)]
|
||||
[string-titlecase (-> -String -String)]
|
||||
[string-foldcase (-> -String -String)]
|
||||
|
||||
[string-normalize-nfd (-> -String -String)]
|
||||
[string-normalize-nfkd (-> -String -String)]
|
||||
[string-normalize-nfc (-> -String -String)]
|
||||
[string-normalize-nfkc (-> -String -String)]
|
||||
[string-normalize-nfd (-> -String -String)]
|
||||
[string-normalize-nfkd (-> -String -String)]
|
||||
[string-normalize-nfc (-> -String -String)]
|
||||
[string-normalize-nfkc (-> -String -String)]
|
||||
|
||||
[string-ref (-> -String N -Char)]
|
||||
[substring (cl->*
|
||||
[string-ref (-> -String N -Char)]
|
||||
[substring (cl->*
|
||||
(-> -String N -String)
|
||||
(-> -String N N -String))]
|
||||
[string->path (-> -String -Path)]
|
||||
[file-exists? (-> -Pathlike B)]
|
||||
[string->path (-> -String -Path)]
|
||||
[file-exists? (-> -Pathlike B)]
|
||||
|
||||
[assq (-poly (a) (-> Univ (-lst (-pair Univ a)) a))]
|
||||
[assq (-poly (a) (-> Univ (-lst (-pair Univ a)) a))]
|
||||
|
||||
[build-path ((list -Pathlike*) -Pathlike* . ->* . -Path)]
|
||||
[string->number (-> -String (-opt N))]
|
||||
[with-input-from-file
|
||||
[build-path ((list -Pathlike*) -Pathlike* . ->* . -Path)]
|
||||
[string->number (-> -String (-opt N))]
|
||||
[with-input-from-file
|
||||
(-poly (a)
|
||||
(cl->
|
||||
[(-Pathlike (-> a)) a]
|
||||
[(-Pathlike (-> a) Sym) a]))]
|
||||
[with-output-to-file
|
||||
[with-output-to-file
|
||||
(-poly (a)
|
||||
(cl->
|
||||
[(-Pathlike (-> a)) a]
|
||||
[(-Pathlike (-> a) Sym) a]))]
|
||||
|
||||
[random (cl->
|
||||
[random (cl->
|
||||
[(-Integer) -Integer]
|
||||
[() -Integer])]
|
||||
|
||||
[assoc (-poly (a b) (a (-lst (-pair a b)) . -> . (-opt (-pair a b))))]
|
||||
[assf (-poly (a b)
|
||||
[assoc (-poly (a b) (a (-lst (-pair a b)) . -> . (-opt (-pair a b))))]
|
||||
[assf (-poly (a b)
|
||||
((a . -> . B) (-lst (-pair a b)) . -> . (-opt (-pair a b))))]
|
||||
|
||||
[list-ref (-poly (a) ((-lst a) -Integer . -> . a))]
|
||||
[positive? (-> N B)]
|
||||
[negative? (-> N B)]
|
||||
[odd? (-> N B)]
|
||||
[even? (-> N B)]
|
||||
[list-ref (-poly (a) ((-lst a) -Integer . -> . a))]
|
||||
[positive? (-> N B)]
|
||||
[negative? (-> N B)]
|
||||
[odd? (-> N B)]
|
||||
[even? (-> N B)]
|
||||
|
||||
[apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))]
|
||||
[apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))]
|
||||
|
||||
[call/cc (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (*Un a b)))]
|
||||
[call/ec (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (*Un a b)))]
|
||||
[call/cc (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (*Un a b)))]
|
||||
[call/ec (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (*Un a b)))]
|
||||
|
||||
[quotient (-Integer -Integer . -> . -Integer)]
|
||||
[remainder (-Integer -Integer . -> . -Integer)]
|
||||
[quotient/remainder (-Integer -Integer . -> . (-values (list -Integer -Integer)))]
|
||||
[quotient (-Integer -Integer . -> . -Integer)]
|
||||
[remainder (-Integer -Integer . -> . -Integer)]
|
||||
[quotient/remainder (-Integer -Integer . -> . (-values (list -Integer -Integer)))]
|
||||
|
||||
;; parameter stuff
|
||||
;; parameter stuff
|
||||
|
||||
[parameterization-key Sym]
|
||||
[extend-parameterization (-poly (a b) (-> Univ (-Param a b) a Univ))]
|
||||
[continuation-mark-set-first (-> (-opt -Cont-Mark-Set) Univ Univ)]
|
||||
[make-parameter (-poly (a b) (cl-> [(a) (-Param a a)]
|
||||
[parameterization-key Sym]
|
||||
[extend-parameterization (-poly (a b) (-> Univ (-Param a b) a Univ))]
|
||||
[continuation-mark-set-first (-> (-opt -Cont-Mark-Set) Univ Univ)]
|
||||
[make-parameter (-poly (a b) (cl-> [(a) (-Param a a)]
|
||||
[(b (a . -> . b)) (-Param a b)]))]
|
||||
[current-directory (-Param -Pathlike -Path)]
|
||||
[current-namespace (-Param -Namespace -Namespace)]
|
||||
[print-struct (-Param B B)]
|
||||
[read-decimal-as-inexact (-Param B B)]
|
||||
[current-command-line-arguments (-Param (make-Vector -String) (make-Vector -String))]
|
||||
[current-directory (-Param -Pathlike -Path)]
|
||||
[current-namespace (-Param -Namespace -Namespace)]
|
||||
[print-struct (-Param B B)]
|
||||
[read-decimal-as-inexact (-Param B B)]
|
||||
[current-command-line-arguments (-Param (-vec -String) (-vec -String))]
|
||||
|
||||
;; regexp stuff
|
||||
[regexp-match
|
||||
;; regexp stuff
|
||||
[regexp-match
|
||||
(cl->
|
||||
[((*Un -String -Regexp) -String) (-opt (-lst (-opt -String)))]
|
||||
[(-Pattern -String) (-opt (-lst (-opt (*Un -Bytes -String))))]
|
||||
|
|
@ -373,142 +291,142 @@
|
|||
[(-Pattern (*Un -Input-Port -Bytes) N (-opt N) (-opt -Output-Port)) (-lst (-opt -Bytes))])]
|
||||
|
||||
|
||||
[number->string (N . -> . -String)]
|
||||
[number->string (N . -> . -String)]
|
||||
|
||||
[current-milliseconds (-> -Integer)]
|
||||
[modulo (cl->* (-Integer -Integer . -> . -Integer))]
|
||||
[current-milliseconds (-> -Integer)]
|
||||
[modulo (cl->* (-Integer -Integer . -> . -Integer))]
|
||||
|
||||
;; errors
|
||||
;; errors
|
||||
|
||||
[raise-type-error
|
||||
[raise-type-error
|
||||
(cl->
|
||||
[(Sym -String Univ) (Un)]
|
||||
[(Sym -String N (-lst Univ)) (Un)])]
|
||||
|
||||
;; this is a hack
|
||||
;; this is a hack
|
||||
|
||||
[match:error ((list) Univ . ->* . (Un))]
|
||||
[match:error ((list) Univ . ->* . (Un))]
|
||||
|
||||
[vector-set! (-poly (a) (-> (make-Vector a) N a -Void))]
|
||||
[vector-set! (-poly (a) (-> (-vec a) N a -Void))]
|
||||
|
||||
[vector->list (-poly (a) (-> (make-Vector a) (-lst a)))]
|
||||
[list->vector (-poly (a) (-> (-lst a) (make-Vector a)))]
|
||||
[exact? (N . -> . B)]
|
||||
[inexact? (N . -> . B)]
|
||||
[expt (cl->* (-Integer -Integer . -> . -Integer) (N N . -> . N))]
|
||||
[vector (-poly (a) (->* (list) a (make-Vector a)))]
|
||||
[real? (Univ . -> . B)]
|
||||
[real-part (N . -> . N)]
|
||||
[imag-part (N . -> . N)]
|
||||
[magnitude (N . -> . N)]
|
||||
[angle (N . -> . N)]
|
||||
[numerator (N . -> . -Integer)]
|
||||
[denominator (N . -> . -Integer)]
|
||||
[exact->inexact (N . -> . N)]
|
||||
[inexact->exact (N . -> . N)]
|
||||
[make-string
|
||||
[vector->list (-poly (a) (-> (-vec a) (-lst a)))]
|
||||
[list->vector (-poly (a) (-> (-lst a) (-vec a)))]
|
||||
[exact? (N . -> . B)]
|
||||
[inexact? (N . -> . B)]
|
||||
[expt (cl->* (-Integer -Integer . -> . -Integer) (N N . -> . N))]
|
||||
[vector (-poly (a) (->* (list) a (-vec a)))]
|
||||
[real? (Univ . -> . B)]
|
||||
[real-part (N . -> . N)]
|
||||
[imag-part (N . -> . N)]
|
||||
[magnitude (N . -> . N)]
|
||||
[angle (N . -> . N)]
|
||||
[numerator (N . -> . -Integer)]
|
||||
[denominator (N . -> . -Integer)]
|
||||
[exact->inexact (N . -> . N)]
|
||||
[inexact->exact (N . -> . N)]
|
||||
[make-string
|
||||
(cl->
|
||||
[(N) -String]
|
||||
[(N -Char) -String])]
|
||||
[arithmetic-shift (-Integer -Integer . -> . -Integer)]
|
||||
[abs (N . -> . N)]
|
||||
[substring (cl-> [(-String N) -String]
|
||||
[arithmetic-shift (-Integer -Integer . -> . -Integer)]
|
||||
[abs (N . -> . N)]
|
||||
[substring (cl-> [(-String N) -String]
|
||||
[(-String N N) -String])]
|
||||
[string-length (-String . -> . N)]
|
||||
[string-set! (-String N -Char . -> . -Void)]
|
||||
[make-vector
|
||||
[string-length (-String . -> . N)]
|
||||
[string-set! (-String N -Char . -> . -Void)]
|
||||
[make-vector
|
||||
(-poly (a)
|
||||
(cl->
|
||||
[(N) (make-Vector N)]
|
||||
[(N a) (make-Vector a)]))]
|
||||
[(N) (-vec N)]
|
||||
[(N a) (-vec a)]))]
|
||||
|
||||
[file-exists? (-Pathlike . -> . B)]
|
||||
[string->symbol (-String . -> . Sym)]
|
||||
[symbol->string (Sym . -> . -String)]
|
||||
[vector-length (-poly (a) ((make-Vector a) . -> . N))]
|
||||
[file-exists? (-Pathlike . -> . B)]
|
||||
[string->symbol (-String . -> . Sym)]
|
||||
[symbol->string (Sym . -> . -String)]
|
||||
[vector-length (-poly (a) ((-vec a) . -> . N))]
|
||||
|
||||
[call-with-input-file (-poly (a)
|
||||
[call-with-input-file (-poly (a)
|
||||
(cl->
|
||||
[(-String (-Port . -> . a)) a]
|
||||
[(-String (-Port . -> . a) Sym) a]))]
|
||||
|
||||
[call-with-output-file (-poly (a)
|
||||
[call-with-output-file (-poly (a)
|
||||
(cl->
|
||||
[(-String (-Port . -> . a)) a]
|
||||
[(-String (-Port . -> . a) Sym) a]))]
|
||||
[current-output-port (-Param -Output-Port -Output-Port)]
|
||||
[current-error-port (-Param -Output-Port -Output-Port)]
|
||||
[current-input-port (-Param -Input-Port -Input-Port)]
|
||||
[round (N . -> . N)]
|
||||
[seconds->date (N . -> . (make-Name #'date))]
|
||||
[current-seconds (-> N)]
|
||||
[sqrt (-> N N)]
|
||||
[path->string (-> -Path -String)]
|
||||
[current-output-port (-Param -Output-Port -Output-Port)]
|
||||
[current-error-port (-Param -Output-Port -Output-Port)]
|
||||
[current-input-port (-Param -Input-Port -Input-Port)]
|
||||
[round (N . -> . N)]
|
||||
[seconds->date (N . -> . (make-Name #'date))]
|
||||
[current-seconds (-> N)]
|
||||
[sqrt (-> N N)]
|
||||
[path->string (-> -Path -String)]
|
||||
|
||||
[link-exists? (-> -Pathlike B)]
|
||||
[directory-exists? (-> -Pathlike B)]
|
||||
[file-exists? (-> -Pathlike B)]
|
||||
[directory-list (cl-> [() (-lst -Path)]
|
||||
[link-exists? (-> -Pathlike B)]
|
||||
[directory-exists? (-> -Pathlike B)]
|
||||
[file-exists? (-> -Pathlike B)]
|
||||
[directory-list (cl-> [() (-lst -Path)]
|
||||
[(-Path) (-lst -Path)])]
|
||||
|
||||
[make-hash (-poly (a b) (-> (-HT a b)))]
|
||||
[make-hasheq (-poly (a b) (-> (-HT a b)))]
|
||||
[make-weak-hash (-poly (a b) (-> (-HT a b)))]
|
||||
[make-weak-hasheq (-poly (a b) (-> (-HT a b)))]
|
||||
[make-hash (-poly (a b) (-> (-HT a b)))]
|
||||
[make-hasheq (-poly (a b) (-> (-HT a b)))]
|
||||
[make-weak-hash (-poly (a b) (-> (-HT a b)))]
|
||||
[make-weak-hasheq (-poly (a b) (-> (-HT a b)))]
|
||||
|
||||
[hash-set! (-poly (a b) ((-HT a b) a b . -> . -Void))]
|
||||
[hash-map (-poly (a b c) ((-HT a b) (a b . -> . c) . -> . (-lst c)))]
|
||||
[hash-ref (-poly (a b c)
|
||||
[hash-set! (-poly (a b) ((-HT a b) a b . -> . -Void))]
|
||||
[hash-map (-poly (a b c) ((-HT a b) (a b . -> . c) . -> . (-lst c)))]
|
||||
[hash-ref (-poly (a b c)
|
||||
(cl->
|
||||
(((-HT a b) a) b)
|
||||
(((-HT a b) a (-> c)) (*Un b c))
|
||||
(((-HT a b) a c) (*Un b c))))]
|
||||
#;[hash-table-index (-poly (a b) ((-HT a b) a b . -> . -Void))]
|
||||
#;[hash-table-index (-poly (a b) ((-HT a b) a b . -> . -Void))]
|
||||
|
||||
[bytes (->* (list) N -Bytes)]
|
||||
[bytes-ref (-> -Bytes N N)]
|
||||
[bytes-append (->* (list -Bytes) -Bytes -Bytes)]
|
||||
[subbytes (cl->
|
||||
[bytes (->* (list) N -Bytes)]
|
||||
[bytes-ref (-> -Bytes N N)]
|
||||
[bytes-append (->* (list -Bytes) -Bytes -Bytes)]
|
||||
[subbytes (cl->
|
||||
[(-Bytes N) -Bytes]
|
||||
[(-Bytes N N) -Bytes])]
|
||||
[bytes-length (-> -Bytes N)]
|
||||
[open-input-file (->key -Pathlike #:mode (Un (-val 'binary) (-val 'text)) #f -Input-Port)]
|
||||
[close-input-port (-> -Input-Port -Void)]
|
||||
[close-output-port (-> -Output-Port -Void)]
|
||||
[read-line (cl->
|
||||
[bytes-length (-> -Bytes N)]
|
||||
[open-input-file (->key -Pathlike #:mode (Un (-val 'binary) (-val 'text)) #f -Input-Port)]
|
||||
[close-input-port (-> -Input-Port -Void)]
|
||||
[close-output-port (-> -Output-Port -Void)]
|
||||
[read-line (cl->
|
||||
[() -String]
|
||||
[(-Input-Port) -String]
|
||||
[(-Input-Port Sym) -String])]
|
||||
[copy-file (-> -Pathlike -Pathlike -Void)]
|
||||
[bytes->string/utf-8 (-> -Bytes -String)]
|
||||
[copy-file (-> -Pathlike -Pathlike -Void)]
|
||||
[bytes->string/utf-8 (-> -Bytes -String)]
|
||||
|
||||
[force (-poly (a) (-> (-Promise a) a))]
|
||||
[bytes<? (->* (list -Bytes) -Bytes B)]
|
||||
[regexp-replace*
|
||||
[force (-poly (a) (-> (-Promise a) a))]
|
||||
[bytes<? (->* (list -Bytes) -Bytes B)]
|
||||
[regexp-replace*
|
||||
(cl->*
|
||||
(-Pattern (*Un -Bytes -String) (*Un -Bytes -String) . -> . -Bytes)
|
||||
(-Pattern -String -String . -> . -String))]
|
||||
[peek-char
|
||||
[peek-char
|
||||
(cl->*
|
||||
[-> -Char]
|
||||
[-Input-Port . -> . -Char]
|
||||
[-Input-Port N . -> . -Char]
|
||||
[N . -> . -Char])]
|
||||
[peek-byte
|
||||
[peek-byte
|
||||
(cl->*
|
||||
[-> -Byte]
|
||||
[-Input-Port . -> . -Byte]
|
||||
[-Input-Port N . -> . -Byte]
|
||||
[N . -> . -Byte])]
|
||||
[make-pipe
|
||||
[make-pipe
|
||||
(cl->*
|
||||
[-> (-values (list -Input-Port -Output-Port))]
|
||||
[N . -> . (-values (list -Input-Port -Output-Port))])]
|
||||
[open-output-bytes
|
||||
[open-output-bytes
|
||||
(cl->*
|
||||
[-> -Output-Port]
|
||||
[Univ . -> . -Output-Port])]
|
||||
[get-output-bytes
|
||||
[get-output-bytes
|
||||
(cl->*
|
||||
[-Output-Port . -> . -Bytes]
|
||||
[-Output-Port Univ . -> . -Bytes]
|
||||
|
|
@ -516,59 +434,50 @@
|
|||
[-Output-Port Univ N N . -> . -Bytes]
|
||||
[-Output-Port N . -> . -Bytes]
|
||||
[-Output-Port N N . -> . -Bytes])]
|
||||
#;[exn:fail? (-> Univ B)]
|
||||
#;[exn:fail:read? (-> Univ B)]
|
||||
#;[exn:fail? (-> Univ B)]
|
||||
#;[exn:fail:read? (-> Univ B)]
|
||||
|
||||
[write (-> -Sexp -Void)]
|
||||
[open-output-string (-> -Output-Port)]
|
||||
;; FIXME - wrong
|
||||
[get-output-string (-> -Output-Port -String)]
|
||||
[write (-> -Sexp -Void)]
|
||||
[open-output-string (-> -Output-Port)]
|
||||
;; FIXME - wrong
|
||||
[get-output-string (-> -Output-Port -String)]
|
||||
|
||||
[make-directory (-> -Path -Void)]
|
||||
[make-directory (-> -Path -Void)]
|
||||
|
||||
[hash-for-each (-poly (a b c)
|
||||
[hash-for-each (-poly (a b c)
|
||||
(-> (-HT a b) (-> a b c) -Void))]
|
||||
|
||||
[delete-file (-> -Pathlike -Void)]
|
||||
[make-namespace (cl->* (-> -Namespace)
|
||||
[delete-file (-> -Pathlike -Void)]
|
||||
[make-namespace (cl->* (-> -Namespace)
|
||||
(-> (*Un (-val 'empty) (-val 'initial)) -Namespace))]
|
||||
[make-base-namespace (-> -Namespace)]
|
||||
[eval (-> -Sexp Univ)]
|
||||
[make-base-namespace (-> -Namespace)]
|
||||
[eval (-> -Sexp Univ)]
|
||||
|
||||
[exit (-> (Un))]
|
||||
[exit (-> (Un))]
|
||||
|
||||
[module->namespace (-> -Sexp -Namespace)]
|
||||
[current-namespace (-Param -Namespace -Namespace)]
|
||||
[module->namespace (-> -Sexp -Namespace)]
|
||||
[current-namespace (-Param -Namespace -Namespace)]
|
||||
|
||||
;; syntax operations
|
||||
;; syntax operations
|
||||
|
||||
[expand (-> (-Syntax Univ) (-Syntax Univ))]
|
||||
[expand-once (-> (-Syntax Univ) (-Syntax Univ))]
|
||||
[expand (-> (-Syntax Univ) (-Syntax Univ))]
|
||||
[expand-once (-> (-Syntax Univ) (-Syntax Univ))]
|
||||
|
||||
[syntax-source (-poly (a) (-> (-Syntax a) Univ))]
|
||||
[syntax-position (-poly (a) (-> (-Syntax a) (-opt N)))]
|
||||
[datum->syntax (cl->*
|
||||
[syntax-source (-poly (a) (-> (-Syntax a) Univ))]
|
||||
[syntax-position (-poly (a) (-> (-Syntax a) (-opt N)))]
|
||||
[datum->syntax (cl->*
|
||||
(-> (-opt (-Syntax Univ)) Sym (-Syntax Sym))
|
||||
(-> (-opt (-Syntax Univ)) Univ (-Syntax Univ)))]
|
||||
[syntax->datum (-poly (a) (-> (-Syntax a) Univ))]
|
||||
[syntax-e (-poly (a) (-> (-Syntax a) a))]
|
||||
[syntax-original? (-poly (a) (-> (-Syntax a) B))]
|
||||
[identifier? (make-pred-ty (-Syntax Sym))]
|
||||
[syntax? (make-pred-ty (-Syntax Univ))]
|
||||
[syntax-property (-poly (a) (cl->* (-> (-Syntax a) Univ Univ (-Syntax a))
|
||||
[syntax->datum (-poly (a) (-> (-Syntax a) Univ))]
|
||||
[syntax-e (-poly (a) (-> (-Syntax a) a))]
|
||||
[syntax-original? (-poly (a) (-> (-Syntax a) B))]
|
||||
[identifier? (make-pred-ty (-Syntax Sym))]
|
||||
[syntax? (make-pred-ty (-Syntax Univ))]
|
||||
[syntax-property (-poly (a) (cl->* (-> (-Syntax a) Univ Univ (-Syntax a))
|
||||
(-> (-Syntax Univ) Univ Univ)))]
|
||||
|
||||
[values (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))]
|
||||
[call-with-values (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b))]
|
||||
|
||||
[eof (-val eof)]
|
||||
[read-accept-reader (-Param B B)]
|
||||
)
|
||||
|
||||
(begin-for-syntax
|
||||
#;(printf "running base-env~n")
|
||||
(initialize-type-env initial-env)
|
||||
(initialize-others))
|
||||
|
||||
|
||||
[values (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))]
|
||||
[call-with-values (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b))]
|
||||
|
||||
[eof (-val eof)]
|
||||
[read-accept-reader (-Param B B)]
|
||||
83
collects/typed-scheme/private/base-special-env.ss
Normal file
83
collects/typed-scheme/private/base-special-env.ss
Normal file
|
|
@ -0,0 +1,83 @@
|
|||
#lang scheme/base
|
||||
|
||||
;; these are libraries providing functions we add types to that are not in scheme/base
|
||||
(require
|
||||
"extra-procs.ss"
|
||||
"../utils/utils.ss"
|
||||
(only-in scheme/list cons? take drop add-between last filter-map)
|
||||
(only-in rnrs/lists-6 fold-left)
|
||||
'#%paramz
|
||||
(only-in scheme/match/runtime match:error)
|
||||
scheme/promise
|
||||
string-constants/string-constant)
|
||||
|
||||
|
||||
|
||||
;; these are all for constructing the types given to variables
|
||||
(require (for-syntax
|
||||
scheme/base
|
||||
(env init-envs)
|
||||
(except-in (rep effect-rep type-rep) make-arr)
|
||||
"type-effect-convenience.ss"
|
||||
(only-in "type-effect-convenience.ss" [make-arr* make-arr])
|
||||
"union.ss"
|
||||
(typecheck tc-structs)))
|
||||
|
||||
(define-for-syntax (initialize-others)
|
||||
(d-s date
|
||||
([second : N] [minute : N] [hour : N] [day : N] [month : N]
|
||||
[year : N] [weekday : N] [year-day : N] [dst? : B] [time-zone-offset : N])
|
||||
())
|
||||
(d-s exn ([message : -String] [continuation-marks : Univ]) ())
|
||||
(d-s (exn:fail exn) () (-String Univ))
|
||||
(d-s (exn:fail:read exn:fail) ([srclocs : (-lst Univ)]) (-String Univ))
|
||||
)
|
||||
|
||||
(provide (for-syntax initial-env/special-case initialize-others initialize-type-env)
|
||||
define-initial-env)
|
||||
|
||||
(define-syntax (define-initial-env stx)
|
||||
(syntax-case stx ()
|
||||
[(_ initial-env make-promise-ty language-ty qq-append-ty [id ty] ...)
|
||||
(with-syntax ([(_ make-promise . _)
|
||||
(local-expand #'(delay 3)
|
||||
'expression
|
||||
null)]
|
||||
[language
|
||||
(local-expand #'(this-language)
|
||||
'expression
|
||||
null)]
|
||||
[(_ qq-append . _)
|
||||
(local-expand #'`(,@'() 1)
|
||||
'expression
|
||||
null)])
|
||||
#`(define-for-syntax initial-env
|
||||
(make-env
|
||||
[make-promise make-promise-ty]
|
||||
[language language-ty]
|
||||
[qq-append qq-append-ty]
|
||||
[id ty] ...)))]))
|
||||
|
||||
|
||||
|
||||
|
||||
(define-initial-env initial-env/special-case
|
||||
;; make-promise
|
||||
(-poly (a) (-> (-> a) (-Promise a)))
|
||||
;; language
|
||||
Sym
|
||||
;; qq-append
|
||||
(-poly (a b)
|
||||
(cl->*
|
||||
(-> (-lst a) (-val '()) (-lst a))
|
||||
(-> (-lst a) (-lst b) (-lst (*Un a b))))))
|
||||
|
||||
|
||||
|
||||
|
||||
(begin-for-syntax
|
||||
(initialize-type-env initial-env/special-case)
|
||||
(initialize-others))
|
||||
|
||||
|
||||
|
||||
34
collects/typed-scheme/private/env-lang.ss
Normal file
34
collects/typed-scheme/private/env-lang.ss
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require "../utils/utils.ss")
|
||||
|
||||
(require (for-syntax (private type-effect-convenience)
|
||||
(env init-envs)
|
||||
scheme/base
|
||||
(except-in (rep effect-rep type-rep) make-arr)
|
||||
"type-effect-convenience.ss"
|
||||
(only-in "type-effect-convenience.ss" [make-arr* make-arr])
|
||||
"union.ss"))
|
||||
(define-syntax (#%module-begin stx)
|
||||
(syntax-case stx (require)
|
||||
[(mb (require . args) [id ty] ...)
|
||||
(begin
|
||||
(unless (andmap identifier? (syntax->list #'(id ...)))
|
||||
(raise-syntax-error #f "not all ids"))
|
||||
#'(#%plain-module-begin
|
||||
(begin
|
||||
(require . args)
|
||||
(define-for-syntax e
|
||||
(make-env [id ty] ...))
|
||||
(begin-for-syntax
|
||||
(initialize-type-env e)))))]
|
||||
[(mb . rest)
|
||||
#'(mb (require) . rest)]))
|
||||
|
||||
(provide #%module-begin
|
||||
require
|
||||
(all-from-out scheme/base)
|
||||
(for-syntax
|
||||
(all-from-out scheme/base
|
||||
"type-effect-convenience.ss"
|
||||
"union.ss")))
|
||||
|
|
@ -13,7 +13,12 @@
|
|||
(for-syntax macro-debugger/stxclass/stxclass)
|
||||
(for-syntax scheme/base))
|
||||
|
||||
(provide (all-defined-out))
|
||||
(provide (all-defined-out)
|
||||
;; these should all eventually go away
|
||||
make-Name make-ValuesDots make-Function make-top-arr make-Latent-Restrict-Effect make-Latent-Remove-Effect)
|
||||
|
||||
(define (one-of/c . args)
|
||||
(apply Un (map -val args)))
|
||||
|
||||
(define (-vet id) (make-Var-True-Effect id))
|
||||
(define (-vef id) (make-Var-False-Effect id))
|
||||
|
|
@ -206,6 +211,8 @@
|
|||
|
||||
(define (-Tuple l)
|
||||
(foldr -pair (-val '()) l))
|
||||
(define -box make-Box)
|
||||
(define -vec make-Vector)
|
||||
|
||||
(define Any-Syntax
|
||||
(-mu x
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
(require (rename-in "utils/utils.ss" [infer r:infer]))
|
||||
|
||||
(require (private base-env base-types)
|
||||
(require (private #;base-env base-types)
|
||||
(for-syntax
|
||||
scheme/base
|
||||
(private type-utils type-contract type-effect-convenience)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user