From d19a3ff923e08bae32472ed43acb6adaeaabaf18 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Thu, 29 Jul 2010 19:11:20 -0400 Subject: [PATCH] Added some reflection functions to Typed Racket. original commit: c4ba6b60388a2d65fcb44a726d12373f9ca17eee --- collects/typed-scheme/private/base-env.rkt | 70 +++++++++++++++++++- collects/typed-scheme/private/base-types.rkt | 4 ++ collects/typed-scheme/types/abbrev.rkt | 4 ++ 3 files changed, 77 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index 0ce98a90..3e45706d 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -18,7 +18,9 @@ (only-in mzscheme make-namespace) (only-in racket/match/runtime match:error matchable? match-equality-test) (for-syntax (only-in (types abbrev) [-Number N] [-Boolean B] [-Symbol Sym]) - (only-in (rep type-rep) make-HashtableTop make-MPairTop make-BoxTop make-ChannelTop make-VectorTop))) + (only-in (rep type-rep) make-HashtableTop make-MPairTop + make-BoxTop make-ChannelTop make-VectorTop + make-HeterogenousVector))) [raise (Univ . -> . (Un))] [raise-syntax-error (cl->* @@ -933,3 +935,69 @@ [mlength (-poly (a) (-> (-mlst a) -NonnegativeFixnum))] [mreverse! (-poly (a) (-> (-mlst a) (-mlst a)))] [mappend (-poly (a) (->* (list) (-mlst a) (-mlst a)))] + +;; module names and loading +[resolved-module-path? (make-pred-ty -Resolved-Module-Path)] +[make-resolved-module-path (-> (Un -Symbol -Path) -Resolved-Module-Path)] +[resolved-module-path-name (-> -Resolved-Module-Path (Un -Path -Symbol))] +[module-path? (make-pred-ty -Module-Path)] +[current-module-name-resolver (-Param (cl->* (-Resolved-Module-Path . -> . Univ) + ((Un -Module-Path -Path) + (-opt -Resolved-Module-Path) + (-opt (-Syntax Univ)) + -Boolean + . -> . -Resolved-Module-Path)) + (cl->* (-Resolved-Module-Path . -> . Univ) + ((Un -Module-Path -Path) + (-opt -Resolved-Module-Path) + (-opt (-Syntax Univ)) + -Boolean + . -> . -Resolved-Module-Path)))] +[current-module-declare-name (-Param (-opt -Resolved-Module-Path) + (-opt -Resolved-Module-Path))] +[current-module-declare-source (-Param (-opt (Un -Symbol -Path)) + (-opt (Un -Symbol -Path)))] +[module-path-index? (make-pred-ty -Module-Path-Index)] +[module-path-index-resolve (-> -Module-Path-Index -Resolved-Module-Path)] +[module-path-index-split (-> -Module-Path-Index + (-values + (list (-opt -Module-Path) + (-opt (Un -Module-Path-Index + -Resolved-Module-Path)))))] +[module-path-index-join (-> (-opt -Module-Path) + (-opt (Un -Module-Path-Index -Resolved-Module-Path)) + -Module-Path-Index)] +[compiled-module-expression? (make-pred-ty -Compiled-Module-Expression)] +[module-compiled-name (-> -Compiled-Module-Expression -Symbol)] +[module-compiled-imports (-> -Compiled-Module-Expression + (-lst (-pair (-opt -Integer) + (-lst -Module-Path-Index))))] +[module-compiled-exports + (-> -Compiled-Module-Expression + (-values + (list + (-lst (-pair (-opt -Integer) + (-lst (-pair -Symbol + (-pair + (-lst + (Un -Module-Path-Index + (-pair -Module-Path-Index + (-pair (-opt -Integer) + (-pair -Symbol + (-pair (-opt -Integer) + (-val null))))))) + (-val null)))))) + (-lst (-pair (-opt -Integer) + (-lst (-pair -Symbol + (-pair + (-lst + (Un -Module-Path-Index + (-pair -Module-Path-Index + (-pair (-opt -Integer) + (-pair -Symbol + (-pair (-opt -Integer) + (-val null))))))) + (-val null)))))))))] +[module-compiled-language-info + (-> -Compiled-Module-Expression + (-opt (make-HeterogenousVector (list -Module-Path -Symbol Univ))))] diff --git a/collects/typed-scheme/private/base-types.rkt b/collects/typed-scheme/private/base-types.rkt index 5b51c829..ad6104da 100644 --- a/collects/typed-scheme/private/base-types.rkt +++ b/collects/typed-scheme/private/base-types.rkt @@ -44,6 +44,10 @@ [Procedure top-func] [Keyword -Keyword] [Thread -Thread] +[Resolved-Module-Path -Resolved-Module-Path] +[Module-Path -Module-Path] +[Module-Path-Index -Module-Path-Index] +[Compiled-Module-Expression -Compiled-Module-Expression] [Listof -Listof] [Vectorof (-poly (a) (make-Vector a))] [FlVector -FlVector] diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index 5ce0ce8a..fca12fa8 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -107,6 +107,10 @@ (define -Keyword (make-Base 'Keyword #'keyword?)) (define -Char (make-Base 'Char #'char?)) (define -Thread (make-Base 'Thread #'thread?)) +(define -Resolved-Module-Path (make-Base 'Resolved-Module-Path #'resolved-module-path?)) +(define -Module-Path (make-Base 'Module-Path #'module-path?)) +(define -Module-Path-Index (make-Base 'Module-Path-Index #'module-path-index?)) +(define -Compiled-Module-Expression (make-Base 'Compiled-Module-Expression #'compiled-module-expression?)) (define -Prompt-Tag (make-Base 'Prompt-Tag #'continuation-prompt-tag?)) (define -Cont-Mark-Set (make-Base 'Continuation-Mark-Set #'continuation-mark-set?)) (define -Path (make-Base 'Path #'path?))