Reorganize initial type definitions to use DSL.
Split special type names into base-types-extra.ss Fix test require. Base types are now require in main.ss svn: r12203
This commit is contained in:
Sam Tobin-Hochstadt
parent
9851b3ab78
commit
e69f6e126a
|
|
@ -8,7 +8,7 @@
|
|||
(schemeunit))
|
||||
|
||||
(require (rename-in (private type-effect-convenience) [-> t:->])
|
||||
(except-in (private base-types) Un)
|
||||
(private base-types)
|
||||
(for-template (private base-types)))
|
||||
|
||||
(provide parse-type-tests)
|
||||
|
|
|
|||
|
|
@ -3,7 +3,9 @@
|
|||
|
||||
|
||||
(providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app)
|
||||
(except "private/prims.ss"))
|
||||
(except "private/prims.ss")
|
||||
(except "private/base-types.ss")
|
||||
(except "private/base-types-extra.ss"))
|
||||
(basics #%module-begin
|
||||
#%top-interaction
|
||||
lambda
|
||||
|
|
|
|||
19
collects/typed-scheme/private/base-types-extra.ss
Normal file
19
collects/typed-scheme/private/base-types-extra.ss
Normal file
|
|
@ -0,0 +1,19 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (for-syntax scheme/base))
|
||||
|
||||
(define-syntax (define-other-types stx)
|
||||
(syntax-case stx ()
|
||||
[(_ nm ...)
|
||||
#'(begin (define-syntax nm (lambda (stx) (raise-syntax-error 'type-check "type name used out of context" stx))) ...
|
||||
(provide nm) ...)]))
|
||||
|
||||
;; special types names that are not bound to particular types
|
||||
|
||||
(define-other-types
|
||||
-> U mu Un All Opaque Vectorof
|
||||
Parameter Tuple Class Values)
|
||||
|
||||
(provide (rename-out [All ∀]
|
||||
[mu Rec]))
|
||||
|
||||
|
|
@ -1,90 +1,31 @@
|
|||
#lang scheme/base
|
||||
#lang s-exp "type-env-lang.ss"
|
||||
|
||||
(require (except-in "../utils/utils.ss" extend))
|
||||
(require (for-syntax
|
||||
scheme/base
|
||||
(env init-envs)
|
||||
(except-in (rep type-rep) make-arr)
|
||||
"type-effect-convenience.ss"
|
||||
(only-in "type-effect-convenience.ss" [make-arr* make-arr])
|
||||
"union.ss"))
|
||||
[Number N]
|
||||
[Integer -Integer]
|
||||
[Void -Void]
|
||||
[Boolean B]
|
||||
[Symbol Sym]
|
||||
[String -String]
|
||||
[Any Univ]
|
||||
[Port -Port]
|
||||
[Path -Path]
|
||||
[Regexp -Regexp]
|
||||
[PRegexp -PRegexp]
|
||||
[Char -Char]
|
||||
[Option (-poly (a) (-opt a))]
|
||||
[List (-lst Univ)]
|
||||
[Listof -Listof]
|
||||
[Namespace -Namespace]
|
||||
[Input-Port -Input-Port]
|
||||
[Output-Port -Output-Port]
|
||||
[Bytes -Bytes]
|
||||
[EOF (-val eof)]
|
||||
[Keyword -Keyword]
|
||||
[HashTable (-poly (a b) (-HT a b))]
|
||||
[Promise (-poly (a) (-Promise a))]
|
||||
[Pair (-poly (a b) (-pair a b))]
|
||||
[Boxof (-poly (a) (make-Box a))]
|
||||
[Syntax Any-Syntax]
|
||||
[Identifier Ident]
|
||||
[Procedure (make-Function (list (make-top-arr)))]
|
||||
|
||||
;; the initial type name environment - just the base types
|
||||
(define-syntax (define-tname-env stx)
|
||||
(syntax-case stx ()
|
||||
[(_ var provider initer [nm ty] ...)
|
||||
#`(begin
|
||||
(define-syntax nm (lambda (stx) (raise-syntax-error 'type-check "type name used out of context" stx))) ...
|
||||
(provide nm) ...
|
||||
(define-syntax provider (lambda (stx) #'(begin (provide nm) ...)))
|
||||
(provide provider)
|
||||
(define-for-syntax (initer)
|
||||
(initialize-type-name-env
|
||||
(list (list #'nm ty) ...)))
|
||||
(begin-for-syntax
|
||||
;(printf "running base-types~n")
|
||||
(initer)))]))
|
||||
|
||||
(define-syntax (define-other-types stx)
|
||||
(syntax-case stx ()
|
||||
[(_ provider requirer nm ...)
|
||||
(with-syntax ([(nms ...) (generate-temporaries #'(nm ...))])
|
||||
(let ([body-maker (lambda (stx)
|
||||
(map (lambda (nm nms) (datum->syntax stx `(rename ,#'mod ,nm ,nms)))
|
||||
(syntax->list #'(nm ...))
|
||||
(syntax->list #'(nms ...))))])
|
||||
#'(begin (define-syntax nms (lambda (stx) (raise-syntax-error 'type-check "type name used out of context" stx))) ...
|
||||
(provide nms) ...
|
||||
(define-syntax (requirer stx)
|
||||
(syntax-case stx ()
|
||||
[(_ mod)
|
||||
(datum->syntax
|
||||
stx
|
||||
`(require . ,(map (lambda (nm* nms*) (datum->syntax stx `(rename-in ,#'mod [,nm* ,nms*])))
|
||||
(list 'nm ...)
|
||||
(list #'nms ...))))]))
|
||||
(define-syntax provider (lambda (stx) #'(begin (provide (rename-out [nms nm])) ...)))
|
||||
(provide provider requirer))))]))
|
||||
|
||||
;; the initial set of available type names
|
||||
(define-tname-env initial-type-names provide-tnames init-tnames
|
||||
[Number N]
|
||||
[Integer -Integer]
|
||||
[Void -Void]
|
||||
[Boolean B]
|
||||
[Symbol Sym]
|
||||
[String -String]
|
||||
[Any Univ]
|
||||
[Port -Port]
|
||||
[Path -Path]
|
||||
[Regexp -Regexp]
|
||||
[PRegexp -PRegexp]
|
||||
[Char -Char]
|
||||
[Option (-poly (a) (-opt a))]
|
||||
[List (-lst Univ)]
|
||||
[Listof -Listof]
|
||||
[Namespace -Namespace]
|
||||
[Input-Port -Input-Port]
|
||||
[Output-Port -Output-Port]
|
||||
[Bytes -Bytes]
|
||||
[EOF (-val eof)]
|
||||
[Keyword -Keyword]
|
||||
[HashTable (-poly (a b) (-HT a b))]
|
||||
[Promise (-poly (a) (-Promise a))]
|
||||
[Pair (-poly (a b) (-pair a b))]
|
||||
[Boxof (-poly (a) (make-Box a))]
|
||||
[Syntax Any-Syntax]
|
||||
[Identifier Ident]
|
||||
[Procedure (make-Function (list (make-top-arr)))]
|
||||
)
|
||||
|
||||
(define-other-types
|
||||
provide-extra-tnames
|
||||
require-extra-tnames
|
||||
|
||||
|
||||
-> U mu Un All Opaque Vectorof
|
||||
Parameter Tuple Class Values
|
||||
)
|
||||
|
||||
(provide-extra-tnames)
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@
|
|||
"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] ...)
|
||||
|
|
|
|||
41
collects/typed-scheme/private/type-env-lang.ss
Normal file
41
collects/typed-scheme/private/type-env-lang.ss
Normal file
|
|
@ -0,0 +1,41 @@
|
|||
#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)
|
||||
(except-in "../rep/type-rep.ss" 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) [nm ty] ...)
|
||||
(begin
|
||||
(unless (andmap identifier? (syntax->list #'(nm ...)))
|
||||
(raise-syntax-error #f "not all ids"))
|
||||
#'(#%plain-module-begin
|
||||
(begin
|
||||
(require . args)
|
||||
(define-syntax nm (lambda (stx) (raise-syntax-error 'type-check "type name used out of context" stx))) ...
|
||||
(provide nm) ...
|
||||
;(define-syntax provider (lambda (stx) #'(begin (provide nm) ...)))
|
||||
;(provide provider)
|
||||
(begin-for-syntax
|
||||
;(printf "running base-types~n")
|
||||
(initialize-type-name-env
|
||||
(list (list #'nm ty) ...))))))]
|
||||
[(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"
|
||||
"../rep/type-rep.ss"
|
||||
"union.ss")))
|
||||
|
|
@ -17,11 +17,7 @@
|
|||
syntax/kerncase
|
||||
scheme/match))
|
||||
|
||||
(provide-tnames)
|
||||
(provide-extra-tnames)
|
||||
(require-extra-tnames "private/base-types.ss")
|
||||
(provide (rename-out [All ∀]
|
||||
[mu Rec]))
|
||||
|
||||
|
||||
|
||||
(provide (rename-out [module-begin #%module-begin]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user