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

More refactoring and reduction of runtime dependencies.

Browse Source 
original commit: 20e95f8d8e5ae3ea9106cff5b271c88e9e66cda1
This commit is contained in:
Sam Tobin-Hochstadt 2012-06-28 11:11:39 -04:00
parent 88460e98dd
commit 39f778a891
17 changed files with 64 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/tests/typed-racket/unit-tests/parse-type-tests.rkt
View File

@ -3,7 +3,7 @@
(utils tc-utils)
(env type-alias-env type-env-structs tvar-env type-name-env init-envs)
(rep type-rep)
(rename-in (types comparison subtype union utils convenience)
(rename-in (types subtype union utils convenience)
[Un t:Un] [-> t:->] [->* t:->*])
(base-env base-types base-types-extra colon)
(for-template (base-env base-types base-types-extra base-env colon))

2
collects/tests/typed-racket/unit-tests/type-equal-tests.rkt
View File

@ -2,7 +2,7 @@
(require "test-utils.rkt" (for-syntax scheme/base)
(rep type-rep)
(types comparison abbrev numeric-tower union)
(types abbrev numeric-tower union)
rackunit)
(provide type-equal-tests)

5
collects/tests/typed-racket/unit-tests/typecheck-tests.rkt
View File

@ -1,5 +1,8 @@
#lang racket/base
(require (for-syntax typed-racket/env/global-env) typed-racket/env/global-env
(for-template typed-racket/env/global-env)
(for-meta 2 typed-racket/env/global-env))
(require "test-utils.rkt"
(for-syntax racket/base)
(for-template racket/base))
@ -27,6 +30,8 @@
(env global-env)
(base-env base-env-indexing))
racket/file racket/port racket/flonum
(env global-env)
(for-meta 2 (env global-env))
(for-template
racket/file racket/port
(base-env base-types base-types-extra base-env-indexing))

7
collects/typed-racket/base-env/base-types.rkt
View File

@ -1,5 +1,12 @@
#lang s-exp "type-env-lang.rkt"
;; This require is necessary, otherwise a somewhat random
;; selection of unit tests fail.
;;
;; I don't understand this at all. :(
;; -- STH, 6/26/12
(require (for-syntax "../env/global-env.rkt"))
[Complex -Number]
[Number -Number]
[Inexact-Complex -InexactComplex]

4
collects/typed-racket/base-env/prims.rkt
View File

@ -52,7 +52,6 @@ This file defines two sorts of primitives. All of them are provided into any mod
"annotate-classes.rkt"
"internal.rkt"
"../utils/tc-utils.rkt"
"../env/type-name-env.rkt"
"for-clauses.rkt")
"../types/numeric-predicates.rkt")
(provide index?) ; useful for assert, and racket doesn't have it
@ -207,7 +206,8 @@ This file defines two sorts of primitives. All of them are provided into any mod
(pattern #:name-exists))
(syntax-parse stx
[(_ ty:id pred:id lib (~optional ne:name-exists-kw) ...)
(register-type-name #'ty (make-Opaque #'pred (syntax-local-certifier)))
((dynamic-require 'typed-racket/env/type-name-env 'register-type-name)
#'ty (make-Opaque #'pred (syntax-local-certifier)))
(with-syntax ([hidden (generate-temporary #'pred)])
(quasisyntax/loc stx
(begin

5
collects/typed-racket/base-env/type-env-lang.rkt
View File

@ -1,8 +1,7 @@
#lang racket/base
(require "../utils/utils.rkt"
(for-syntax "../env/global-env.rkt"
racket/base syntax/parse
(for-syntax racket/base syntax/parse
(except-in (rep filter-rep type-rep) make-arr)
(rename-in (types numeric-tower abbrev convenience))))
@ -23,7 +22,7 @@
(list (list #'nm ty) ...)))))]))
(provide #%module-begin
require
require provide
(all-from-out racket/base)
(for-syntax
(rep-out type-rep)

5
collects/typed-racket/env/global-env.rkt vendored
View File

@ -4,11 +4,10 @@
;; maps identifiers to their types, updated by mutation
(require "../utils/utils.rkt"
"../types/tc-error.rkt"
syntax/id-table
(rep type-rep)
(utils tc-utils)
(types utils comparison))
(utils tc-utils))
(provide register-type register-type-if-undefined
finish-register-type
maybe-finish-register-type

2
collects/typed-racket/private/type-annotation.rkt
View File

@ -4,7 +4,7 @@
(rep type-rep)
(utils tc-utils)
(env global-env)
(except-in (types subtype union convenience resolve utils generalize comparison) -> ->* one-of/c)
(except-in (types subtype union convenience resolve utils generalize) -> ->* one-of/c)
(private parse-type)
(contract-req)
racket/match)

3
collects/typed-racket/rep/rep-utils.rkt
View File

@ -3,8 +3,7 @@
racket/match
(contract-req)
"free-variance.rkt"
"interning.rkt"
unstable/match unstable/struct
"interning.rkt" unstable/struct
racket/stxparam
(for-syntax
racket/match

1
collects/typed-racket/typecheck/tc-app-helper.rkt
View File

@ -336,3 +336,4 @@
(if (not (for/and ([t (apply append (map fv/list msg-doms))]) (memq t msg-vars)))
(string-append "Type Variables: " (stringify msg-vars) "\n")
""))))))]))

2
collects/typed-racket/typecheck/tc-if.rkt
View File

@ -2,7 +2,7 @@
(require (rename-in "../utils/utils.rkt" [infer r:infer])
"signatures.rkt" "check-below.rkt"
(rep type-rep filter-rep object-rep)
(rename-in (types convenience subtype union utils comparison remove-intersect abbrev filter-ops)
(rename-in (types convenience subtype union utils remove-intersect abbrev filter-ops)
[remove *remove])
(env lexical-env type-env-structs)
(r:infer infer)

5
collects/typed-racket/types/abbrev.rkt
View File

@ -3,7 +3,6 @@
(require "../utils/utils.rkt")
(require (rename-in (rep type-rep object-rep filter-rep rep-utils) [make-Base make-Base*])
"resolve.rkt"
(utils tc-utils)
racket/list
racket/match
@ -13,6 +12,7 @@
'#%place
unstable/function
racket/udp
unstable/lazy-require
(except-in racket/contract/base ->* ->)
(prefix-in c: racket/contract/base)
(for-syntax racket/base syntax/parse racket/list)
@ -21,6 +21,8 @@
;; for base type predicates
racket/promise racket/tcp racket/flonum)
(lazy-require ["resolve.rkt" (resolve)])
(provide (except-out (all-defined-out) Promise make-Base)
(rename-out [make-Listof -lst]
[make-MListof -mlst]))
@ -74,7 +76,6 @@
(foldr -pair b l))
(define (untuple t)
;; FIXME - do we really need resolution here?
(match (resolve t)
[(Value: '()) null]
[(Pair: a b) (cond [(untuple b) => (lambda (l) (cons a l))]

2
collects/typed-racket/types/filter-ops.rkt
View File

@ -4,7 +4,7 @@
(rep type-rep filter-rep object-rep rep-utils)
(utils tc-utils) (only-in (infer infer) restrict)
"abbrev.rkt" (only-in racket/contract current-blame-format [-> -->] listof)
(types comparison printer union subtype utils remove-intersect)
(types printer union subtype utils remove-intersect)
racket/list racket/match
(for-syntax syntax/parse racket/base)
syntax/id-table racket/dict

2
collects/typed-racket/types/subtype.rkt
View File

@ -2,7 +2,7 @@
(require "../utils/utils.rkt"
(rep type-rep filter-rep object-rep rep-utils)
(utils tc-utils)
(types utils comparison resolve abbrev numeric-tower substitute)
(types utils resolve abbrev numeric-tower substitute)
(env type-name-env)
(only-in (infer infer-dummy) unify)
racket/match unstable/match

31
collects/typed-racket/types/tc-error.rkt Normal file
View File

@ -0,0 +1,31 @@
#lang racket/base
(require "../utils/utils.rkt"
(rep type-rep filter-rep object-rep rep-utils)
(utils tc-utils)
racket/match)
(provide tc-error/expr lookup-type-fail lookup-fail)
(define (tc-error/expr msg
#:return [return (make-Union null)]
#:stx [stx (current-orig-stx)]
. rest)
(apply tc-error/delayed #:stx stx msg rest)
return)
;; error for unbound variables
(define (lookup-fail e)
(match (identifier-binding e)
['lexical (tc-error/expr "untyped identifier ~a" (syntax-e e))]
[#f (tc-error/expr "untyped top-level identifier ~a" (syntax-e e))]
[(list _ _ nominal-source-mod nominal-source-id _ _ _)
(let-values ([(x y) (module-path-index-split nominal-source-mod)])
(cond [(and (not x) (not y))
(tc-error/expr "untyped identifier ~a" (syntax-e e))]
[else
(tc-error/expr "untyped identifier ~a imported from module <~a>"
(syntax-e e) x)]))]))
(define (lookup-type-fail i)
(tc-error/expr "~a is not bound as a type" (syntax-e i)))

2
collects/typed-racket/types/union.rkt
View File

@ -4,7 +4,7 @@
(rep type-rep rep-utils)
(utils tc-utils)
(prefix-in c: (contract-req))
(types utils subtype abbrev comparison)
(types utils subtype abbrev)
racket/match)

28
collects/typed-racket/types/utils.rkt
View File

@ -8,10 +8,11 @@
(env index-env tvar-env)
racket/match
racket/list
racket/contract)
(contract-req)
"tc-error.rkt")
(provide (all-from-out "tc-result.rkt"))
(provide (all-from-out "tc-result.rkt" "tc-error.rkt"))
;; unfold : Type -> Type
@ -62,29 +63,6 @@
(define (fv/list ts)
(hash-map (combine-frees (map free-vars* ts)) (lambda (k v) k)))
(define (tc-error/expr msg
#:return [return (make-Union null)]
#:stx [stx (current-orig-stx)]
. rest)
(apply tc-error/delayed #:stx stx msg rest)
return)
;; error for unbound variables
(define (lookup-fail e)
(match (identifier-binding e)
['lexical (tc-error/expr "untyped identifier ~a" (syntax-e e))]
[#f (tc-error/expr "untyped top-level identifier ~a" (syntax-e e))]
[(list _ _ nominal-source-mod nominal-source-id _ _ _)
(let-values ([(x y) (module-path-index-split nominal-source-mod)])
(cond [(and (not x) (not y))
(tc-error/expr "untyped identifier ~a" (syntax-e e))]
[else
(tc-error/expr "untyped identifier ~a imported from module <~a>"
(syntax-e e) x)]))]))
(define (lookup-type-fail i)
(tc-error/expr "~a is not bound as a type" (syntax-e i)))
;; a parameter for the current polymorphic structure being defined
;; to allow us to prevent non-regular datatypes
(define-struct poly (name vars) #:prefab)