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

Add typechecking for prefab structs

Browse Source 
Adds a new Prefab type constructor along with support for
the use of `struct` with the #:prefab keyword.
This commit is contained in:
Asumu Takikawa 2014-12-19 18:55:48 -05:00
parent 50f2271917
commit 5d708ab53f
19 changed files with 436 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
typed-racket-lib/typed-racket/base-env/base-types-extra.rkt
View File

@ -17,7 +17,7 @@
(define-other-types
-> ->* case-> U Rec All Opaque Vector
Parameterof List List* Class Object Values Instance Refinement
pred Struct Struct-Type Top Bot)
pred Struct Struct-Type Prefab Top Bot)
(provide (rename-out [All ∀]
[U Un]

9
typed-racket-lib/typed-racket/base-env/prims.rkt
View File

@ -605,9 +605,10 @@ This file defines two sorts of primitives. All of them are provided into any mod
(define-splicing-syntax-class struct-options
#:description "typed structure type options"
#:attributes (guard mutable? transparent? [prop 1] [prop-val 1])
#:attributes (guard mutable? transparent? prefab? [prop 1] [prop-val 1])
(pattern (~seq (~or (~optional (~seq (~and #:mutable mutable?)))
(~optional (~seq (~and #:transparent transparent?)))
(~optional (~seq (~and #:prefab prefab?)))
;; FIXME: unsound, but relied on in core libraries
;; #:guard ought to be supportable with some work
;; #:property is harder
@ -651,14 +652,16 @@ This file defines two sorts of primitives. All of them are provided into any mod
(syntax-parse stx
[(_ vars:maybe-type-vars nm:struct-name/new (fs:fld-spec ...)
opts:struct-options)
(let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())])
(let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())]
[prefab? (if (attribute opts.prefab?) #'(#:prefab) #'())])
(with-syntax ([d-s (ignore (quasisyntax/loc stx
(struct #,@(attribute nm.new-spec) (fs.fld ...)
. opts)))]
[dtsi (quasisyntax/loc stx
(dtsi* (vars.vars ...)
nm.old-spec (fs.form ...)
#,@mutable?))])
#,@mutable?
#,@prefab?))])
;; see comment above
(if (eq? (syntax-local-context) 'top-level)
#'(begin (eval (quote-syntax d-s))

14
typed-racket-lib/typed-racket/infer/infer-unit.rkt
View File

@ -13,7 +13,7 @@
(utils tc-utils)
(rep free-variance type-rep filter-rep object-rep rep-utils)
(types utils abbrev numeric-tower union subtype resolve
substitute generalize)
substitute generalize prefab)
(env index-env tvar-env))
make-env -> ->* one-of/c)
"constraint-structs.rkt"
@ -547,6 +547,18 @@
[else empty])])
(% cset-meet proc-c (cgen/flds context flds flds*)))]
;; two prefab structs with the same key
[((Prefab: k ss) (Prefab: k* ts))
#:when (and (prefab-key-subtype? k k*)
(>= (length ss) (length ts)))
(% cset-meet*
(for/list/fail ([s (in-list ss)]
[t (in-list ts)]
[mut? (in-list (prefab-key->field-mutability k*))])
(if mut?
(cgen/inv context s t)
(cgen context s t))))]
;; two struct names, need to resolve b/c one could be a parent
[((Name: n _ #t) (Name: n* _ #t))
(if (free-identifier=? n n*)

14
typed-racket-lib/typed-racket/private/parse-type.rkt
View File

@ -5,7 +5,7 @@
(require "../utils/utils.rkt"
(except-in (rep type-rep object-rep) make-arr)
(rename-in (types abbrev union utils filter-ops resolve
classes)
classes prefab)
[make-arr* make-arr])
(utils tc-utils stxclass-util literal-syntax-class)
syntax/stx (prefix-in c: (contract-req))
@ -95,6 +95,7 @@
(define-literal-syntax-class #:for-label Vector)
(define-literal-syntax-class #:for-label Struct)
(define-literal-syntax-class #:for-label Struct-Type)
(define-literal-syntax-class #:for-label Prefab)
(define-literal-syntax-class #:for-label Values)
(define-literal-syntax-class #:for-label values)
(define-literal-syntax-class #:for-label Top)
@ -341,11 +342,20 @@
[(:Struct-Type^ t)
(define v (parse-type #'t))
(match (resolve v)
[(? Struct? s) (make-StructType s)]
[(or (? Struct? s) (? Prefab? s)) (make-StructType s)]
[_ (parse-error #:delayed? #t
"expected a structure type for argument to Struct-Type"
"given" v)
(Un)])]
[(:Prefab^ key ts ...)
#:fail-unless (prefab-key? (syntax->datum #'key)) "expected a prefab key"
(define num-fields (length (syntax->list #'(ts ...))))
(define new-key (normalize-prefab-key (syntax->datum #'key) num-fields))
(unless (= (prefab-key->field-count new-key) num-fields)
(parse-error "the number of fields in the prefab key and type disagree"
"key" (prefab-key->field-count new-key)
"fields" num-fields))
(make-Prefab new-key (parse-types #'(ts ...)))]
[(:Instance^ t)
(let ([v (parse-type #'t)])
(if (not (or (F? v) (Mu? v) (Name? v) (Class? v) (Error? v)))

11
typed-racket-lib/typed-racket/rep/type-rep.rkt
View File

@ -402,9 +402,18 @@
;; This should eventually be based on understanding of struct properties.
[#:key '(struct procedure)])
;; Represents prefab structs
;; key : prefab key encoding mutability, auto-fields, etc.
;; flds : the types of all of the prefab fields
(def-type Prefab ([key prefab-key?]
[flds (listof Type/c)])
[#:frees (λ (f) (combine-frees (map f flds)))]
[#:fold-rhs (*Prefab key (map type-rec-id flds))]
[#:key 'prefab])
;; A structure type descriptor
(def-type StructTypeTop () [#:fold-rhs #:base] [#:key 'struct-type])
(def-type StructType ([s (or/c F? B? Struct?)]) [#:key 'struct-type])
(def-type StructType ([s (or/c F? B? Struct? Prefab?)]) [#:key 'struct-type])
;; the supertype of all of these values
(def-type BoxTop () [#:fold-rhs #:base] [#:key 'box])

6
typed-racket-lib/typed-racket/typecheck/internal-forms.rkt
View File

@ -46,10 +46,11 @@
;;; Helpers
(define-splicing-syntax-class dtsi-fields
#:attributes (mutable type-only maker)
#:attributes (mutable prefab type-only maker)
(pattern
(~seq
(~or (~optional (~and #:mutable (~bind (mutable #t))))
(~optional (~and #:prefab (~bind (prefab #t))))
(~optional (~and #:type-only (~bind (type-only #t))))
(~optional (~seq #:maker maker))) ...)))
@ -59,11 +60,12 @@
(define-syntax-class define-typed-struct-body
#:attributes (name mutable type-only maker nm (tvars 1) (fields 1) (types 1))
#:attributes (name mutable prefab type-only maker nm (tvars 1) (fields 1) (types 1))
(pattern ((~optional (tvars:id ...) #:defaults (((tvars 1) null)))
nm:struct-name ([fields:id : types:expr] ...) options:dtsi-fields)
#:attr name #'nm.nm
#:attr mutable (attribute options.mutable)
#:attr prefab (attribute options.prefab)
#:attr type-only (attribute options.type-only)
#:attr maker (or (attribute options.maker) #'nm.nm)))

22
typed-racket-lib/typed-racket/typecheck/tc-literal.rkt
View File

@ -3,7 +3,8 @@
(require "../utils/utils.rkt"
racket/match
(typecheck signatures check-below)
(types abbrev numeric-tower resolve subtype union generalize)
(types abbrev numeric-tower resolve subtype union generalize
prefab)
(rep type-rep)
(only-in (infer infer) restrict)
(utils stxclass-util)
@ -124,8 +125,21 @@
[ks (hash-map h (lambda (x y) (tc-literal x)))]
[vs (hash-map h (lambda (x y) (tc-literal y)))])
(make-Hashtable (generalize (apply Un ks)) (generalize (apply Un vs))))])]
[(~var i (3d prefab-struct-key))
(tc-prefab (syntax-e #'i) expected)]
[_ Univ]))
;; Typecheck a prefab struct literal
(define (tc-prefab struct-inst expected)
(define expected-ts
(match (and expected (resolve expected))
[(Prefab: _ ts) (in-sequence-forever (in-list ts) #f)]
[_ (in-cycle (in-value #f))]))
(define key (prefab-struct-key struct-inst))
(define struct-vec (struct->vector struct-inst))
(define fields
(for/list ([elem (in-vector struct-vec 1)]
[expected-t expected-ts])
(tc-literal elem expected-t)))
(make-Prefab (normalize-prefab-key key (length fields))
fields))

67
typed-racket-lib/typed-racket/typecheck/tc-structs.rkt
View File

@ -6,7 +6,7 @@
(prefix-in c: (contract-req))
(rep type-rep object-rep free-variance)
(private parse-type syntax-properties)
(types abbrev utils resolve substitute struct-table)
(types abbrev utils resolve substitute struct-table prefab)
(env global-env type-name-env type-alias-env tvar-env)
(utils tc-utils)
(typecheck def-binding internal-forms)
@ -14,7 +14,8 @@
(require-for-cond-contract racket/struct-info)
(provide tc/struct name-of-struct d-s
(provide tc/struct
name-of-struct d-s
refine-struct-variance!
register-parsed-struct-sty!
register-parsed-struct-bindings!)
@ -24,7 +25,7 @@
(pattern (name:id par:id))
(pattern name:id #:attr par #f))
;; sty : Struct?
;; sty : (U Struct? Prefab?)
;; names : Listof[Identifier]
;; desc : struct-desc
;; struct-info : struct-info?
@ -55,9 +56,9 @@
;; parse name field of struct, determining whether a parent struct was specified
;; syntax -> (values identifier Option[Name] Option[Struct])
(define/cond-contract (parse-parent nm/par)
(c:-> syntax? (values identifier? (c:or/c Name? #f) (c:or/c Mu? Poly? Struct? #f)))
;; syntax any -> (values identifier Option[Name] Option[Struct])
(define/cond-contract (parse-parent nm/par prefab?)
(c:-> syntax? (values identifier? (c:or/c Name? #f) (c:or/c Mu? Poly? Struct? Prefab? #f)))
(syntax-parse nm/par
[v:parent
(if (attribute v.par)
@ -66,7 +67,8 @@
[parent (let loop ((parent parent0))
(cond
((Name? parent) (loop (resolve-name parent)))
((or (Poly? parent) (Mu? parent) (Struct? parent))
((or (Poly? parent) (Mu? parent)
(if prefab? (Prefab? parent) (Struct? parent)))
parent)
(else
(tc-error/stx #'v.par "parent type not a valid structure name: ~a"
@ -119,14 +121,14 @@
;; identifier listof[identifier] type listof[fld] listof[Type] boolean ->
;; (values Type listof[Type] listof[Type])
(define/cond-contract (register-sty! sty names desc)
(c:-> Struct? struct-names? struct-desc? void?)
(c:-> (c:or/c Struct? Prefab?) struct-names? struct-desc? void?)
;; a type alias needs to be registered here too, to ensure
;; that parse-type will map the identifier to this Name type
(define type-name (struct-names-type-name names))
(register-resolved-type-alias
type-name
(make-Name type-name #f #t))
(make-Name type-name (struct-desc-tvars desc) (Struct? sty)))
(register-type-name type-name
(make-Poly (struct-desc-tvars desc) sty)))
@ -135,7 +137,7 @@
;; Register the approriate types to the struct bindings.
(define/cond-contract (register-struct-bindings! sty names desc si)
(c:-> Struct? struct-names? struct-desc? (c:or/c #f struct-info?) (c:listof binding?))
(c:-> (c:or/c Struct? Prefab?) struct-names? struct-desc? (c:or/c #f struct-info?) (c:listof binding?))
(define tvars (struct-desc-tvars desc))
@ -169,6 +171,7 @@
(make-def-binding (struct-names-struct-type names) (make-StructType sty))
(make-def-binding (struct-names-predicate names)
(make-pred-ty (if (not covariant?)
;; FIXME: does this make sense with prefabs?
(make-StructTop sty)
(subst-all (make-simple-substitution
tvars (map (const Univ) tvars)) poly-base))))
@ -225,7 +228,9 @@
(define (refine-struct-variance! parsed-structs)
(define stys (map parsed-struct-sty parsed-structs))
(define tvarss (map (compose struct-desc-tvars parsed-struct-desc) parsed-structs))
(define names (map Struct-name stys))
(define names
(for/list ([parsed-struct (in-list parsed-structs)])
(struct-names-type-name (parsed-struct-names parsed-struct))))
(refine-variance! names stys tvarss))
;; check and register types for a define struct
@ -236,9 +241,10 @@
#:proc-ty [proc-ty #f]
#:maker [maker #f]
#:mutable [mutable #f]
#:type-only [type-only #f])
#:type-only [type-only #f]
#:prefab? [prefab? #f])
;; parent field types can't actually be determined here
(define-values (nm parent-name parent) (parse-parent nm/par))
(define-values (nm parent-name parent) (parse-parent nm/par prefab?))
;; create type variables for the new type parameters
(define tvars (map syntax-e vars))
(define new-tvars (map make-F tvars))
@ -262,16 +268,35 @@
;; that the outside world will see
;; then register it
(define names (get-struct-names nm fld-names maker))
(define desc (struct-desc
(map fld-t (get-flds concrete-parent))
types
tvars
mutable
(and proc-ty (parse-type proc-ty))))
(define sty (mk/inner-struct-type names desc concrete-parent))
(parsed-struct sty names desc (struct-info-property nm/par) type-only))
(cond [prefab?
(define-values (parent-key parent-fields)
(match concrete-parent
[#f (values null null)]
[(Prefab: parent-key parent-fields)
(values parent-key parent-fields)]))
(define key-prefix
(if mutable
(list (syntax-e nm)
(length fld-names)
(build-vector (length fld-names) values))
(list (syntax-e nm))))
(define key
(normalize-prefab-key (append key-prefix parent-key)
(+ (length fld-names) (length parent-fields))))
(define desc (struct-desc parent-fields types tvars mutable #f))
(parsed-struct (make-Prefab key (append parent-fields types))
names desc (struct-info-property nm/par) #f)]
[else
(define desc (struct-desc
(map fld-t (get-flds concrete-parent))
types
tvars
mutable
(and proc-ty (parse-type proc-ty))))
(define sty (mk/inner-struct-type names desc concrete-parent))
(parsed-struct sty names desc (struct-info-property nm/par) type-only)]))
;; register a struct type
;; convenience function for built-in structs

3
typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -36,7 +36,8 @@
(tc/struct (attribute t.tvars) #'t.nm (syntax->list #'(t.fields ...)) (syntax->list #'(t.types ...))
#:mutable (attribute t.mutable)
#:maker (attribute t.maker)
#:type-only (attribute t.type-only))]
#:type-only (attribute t.type-only)
#:prefab? (attribute t.prefab))]
[t:typed-struct/exec
(tc/struct null #'t.nm (syntax->list #'(t.fields ...)) (syntax->list #'(t.types ...))
#:proc-ty #'t.proc-type)])))

4
typed-racket-lib/typed-racket/types/abbrev.rkt
View File

@ -14,7 +14,7 @@
(prefix-in c: (contract-req))
(rename-in (rep type-rep filter-rep object-rep)
[make-Base make-Base*])
(types union numeric-tower)
(types union numeric-tower prefab)
;; Using this form so all-from-out works
"base-abbrev.rkt" "match-expanders.rkt"
@ -66,6 +66,8 @@
(define -evt make-Evt)
(define -weak-box make-Weak-Box)
(define -inst make-Instance)
(define (-prefab key . types)
(make-Prefab (normalize-prefab-key key (length types)) types))
(define (-seq . args) (make-Sequence args))

125
typed-racket-lib/typed-racket/types/prefab.rkt Normal file
View File

@ -0,0 +1,125 @@
#lang racket/base
;; Utilities for dealing with prefab struct types
(require "../utils/utils.rkt"
(contract-req)
racket/list
racket/match)
(provide/cond-contract [normalize-prefab-key
(-> prefab-key? integer? prefab-key?)]
[prefab-key->field-count
(-> prefab-key? integer?)]
[abbreviate-prefab-key
(-> prefab-key? prefab-key?)]
[prefab-key-subtype?
(-> prefab-key? prefab-key? any)]
[prefab-key->field-mutability
(-> prefab-key? (listof boolean?))])
;; Convert a prefab key to its expanded version
(define (normalize-prefab-key key field-length)
(cond [(symbol? key) `(,key ,field-length (0 #f) #())]
[(list? key)
(define base-sym (car key))
(define-values (base-clauses rst)
(splitf-at (cdr key) (λ (x) (not (symbol? x)))))
(define parent-fragments
(let loop ([key rst] [fragments null])
(cond [(null? key) fragments]
[else
(define-values (clauses rst)
(splitf-at (cdr key) (λ (x) (not (symbol? x)))))
(loop rst (cons (cons (car key) clauses)
fragments))])))
(define-values (processed-parents remaining-length)
(for/fold ([processed null]
[field-length field-length])
([parent (in-list parent-fragments)])
(match parent
[(list _ n (and auto (list auto-n _)) _)
(values (cons parent processed)
(- field-length n auto-n))]
[(list sym (? number? n) (and auto (list auto-n _)))
(values (cons `(,sym ,n ,auto #()) processed)
(- field-length n auto-n))]
[(list sym (? number? n) (? vector? mut))
(values (cons `(,sym ,n (0 #f) ,mut) processed)
(- field-length n))]
[(list sym n)
(values (cons `(,sym ,n (0 #f) #()) processed)
(- field-length n))])))
(define processed-base
(match base-clauses
[(list n _ _) (cons base-sym base-clauses)]
[(list (? number? n) (and auto (list auto-n _)))
`(,base-sym ,n ,auto #())]
[(list (? number? n) (? vector? mut))
`(,base-sym ,n (0 #f) ,mut)]
[(list (and auto (list auto-n _)) (? vector? mut))
`(,base-sym ,(- remaining-length auto-n) ,auto ,mut)]
[(list (? number? n))
`(,base-sym ,n (0 #f) #())]
[(list (and auto (list auto-n _)))
`(,base-sym ,(- remaining-length auto-n) ,auto #())]
[(list (? vector? mut))
`(,base-sym ,remaining-length (0 #f) ,mut)]
[(list)
`(,base-sym ,remaining-length (0 #f) #())]))
(append processed-base (apply append processed-parents))]))
;; Accepts a normalized prefab key and returns the number of fields
;; a struct with this key should have
(define (prefab-key->field-count key)
(let loop ([key key] [count 0])
(cond [(null? key) count]
[else
(match-define (list _ len (list auto-len _) _ rst ...) key)
(loop rst (+ len auto-len count))])))
;; Convert a prefab key to a shortened version
(define (abbreviate-prefab-key key)
(let loop ([key key] [first? #t])
(cond [(null? key) null]
[(symbol? key) key]
[(list? key)
(define sym (car key))
(define-values (other-clauses rst)
(splitf-at (cdr key) (λ (x) (not (symbol? x)))))
(define simplified-clauses
(for/list ([elem (in-list other-clauses)]
#:unless (and first? (number? elem))
#:unless (and (list? elem)
(= (car elem) 0))
#:unless (and (vector? elem)
(= (vector-length elem) 0)))
elem))
(if (and (null? simplified-clauses)
(null? rst))
sym
(cons sym (append simplified-clauses
(loop rst #f))))])))
;; Determine if the first prefab key can be a subtype of the second
;; Invariant: the keys are fully expanded (normalized)
(define (prefab-key-subtype? key1 key2)
(or (equal? key1 key2)
(suffix? key2 key1)))
(define (suffix? l1 l2)
(for/or ([n (in-range (add1 (length l2)))])
(equal? (drop l2 n) l1)))
;; Returns a list of flags indicating the mutability of prefab struct types
;; in order from parent to the children (#t is mutable, #f is not)
;; Precondition: the key is fully expanded
(define (prefab-key->field-mutability key)
(let loop ([key key])
(cond [(null? key) null]
[else
(match-define (list sym len auto mut parents ...) key)
(define mut-list (vector->list mut))
(append (loop parents)
(for/list ([idx (in-range len)])
(and (member idx mut-list) #t)))])))

2
typed-racket-lib/typed-racket/types/printer.rkt
View File

@ -13,6 +13,7 @@
"types/kw-types.rkt"
"types/utils.rkt"
"types/resolve.rkt"
"types/prefab.rkt"
"utils/utils.rkt"
"utils/tc-utils.rkt")
(for-syntax racket/base syntax/parse))
@ -406,6 +407,7 @@
[(StructType: ty) `(Struct-Type ,(t->s ty))]
[(StructTypeTop:) 'Struct-TypeTop]
[(StructTop: (Struct: nm _ _ _ _ _)) `(Struct ,(syntax-e nm))]
[(Prefab: key fields) `(Prefab ,(abbreviate-prefab-key key) ,@fields)]
[(BoxTop:) 'BoxTop]
[(Weak-BoxTop:) 'Weak-BoxTop]
[(ChannelTop:) 'ChannelTop]

16
typed-racket-lib/typed-racket/types/subtype.rkt
View File

@ -5,7 +5,7 @@
(rep type-rep filter-rep object-rep rep-utils)
(utils tc-utils early-return)
(types utils resolve base-abbrev match-expanders
numeric-tower substitute current-seen)
numeric-tower substitute current-seen prefab)
(for-syntax racket/base syntax/parse unstable/sequence))
(lazy-require
@ -554,6 +554,20 @@
;; subtyping on structs follows the declared hierarchy
[((Struct: nm (? Type/c? parent) _ _ _ _) other)
(subtype* A0 parent other)]
[((Prefab: k1 ss) (Prefab: k2 ts))
(and (prefab-key-subtype? k1 k2)
(and (>= (length ss) (length ts))
(for/fold ([A A0])
([s (in-list ss)]
[t (in-list ts)]
[mut? (in-list (prefab-key->field-mutability k2))]
#:break (not A))
(and A
(if mut?
(subtype-seq A
(subtype* t s)
(subtype* s t))
(subtype* A s t))))))]
;; subtyping on values is pointwise, except special case for Bottom
[((Values: (list (Result: (== -Bottom) _ _))) _)
A0]

36
typed-racket-test/succeed/prefab.rkt Normal file
View File

@ -0,0 +1,36 @@
#lang typed/racket
;; Test prefab struct declarations
(struct foo ([x : Symbol]) #:prefab)
(struct bar foo ([y : String] [z : String]) #:prefab)
(: a-bar (Prefab (bar foo 1) Symbol String String))
(define a-bar (bar 'foo "bar1" "bar2"))
(foo-x (foo 'foo))
(bar-y (bar 'foo "bar1" "bar2"))
;; prefab keys may be normalized or not
(: a-bar-2 (Prefab (bar 2 foo 1 (0 #f) #()) Symbol String String))
(define a-bar-2 (bar 'foo "bar1" "bar2"))
;; prefab subtyping is computed via the key and field length
(: a-bar-3 (Prefab foo Symbol))
(define a-bar-3 (bar 'foo "bar1" "bar2"))
;; Mutable prefab structs
(struct baz ([x : String]) #:mutable #:prefab)
(define a-baz (baz "baz"))
(set-baz-x! a-baz "baz2")
(baz-x a-baz)
;; Polymorphic prefab structs
(struct (X) poly ([x : X]) #:prefab)
(poly-x (poly "foo"))
(poly-x (poly 3))
(poly-x #s(poly "foo"))

3
typed-racket-test/unit-tests/all-tests.rkt
View File

@ -43,4 +43,5 @@
"generalize-tests.rkt"
"rep-tests.rkt"
"prims-tests.rkt"
"tooltip-tests.rkt")
"tooltip-tests.rkt"
"prefab-tests.rkt")

4
typed-racket-test/unit-tests/parse-type-tests.rkt
View File

@ -262,6 +262,10 @@
[(String [#:a String] String * -> String)
(->optkey -String [] #:rest -String #:a -String #f -String)]
;;; Prefab structs
[(Prefab foo String) (-prefab 'foo -String)]
[FAIL (Prefab (foo 0) String)]
;;; Classes
[(Class) (-class)]
[(Class (init [x Number] [y Number]))

90
typed-racket-test/unit-tests/prefab-tests.rkt Normal file
View File

@ -0,0 +1,90 @@
#lang racket/base
;; Unit tests for prefab type helpres
(require "test-utils.rkt"
racket/list
rackunit
typed-racket/types/prefab)
(provide tests)
(gen-test-main)
(define-check (check-normalize key n norm)
(check-equal? (normalize-prefab-key key n) norm))
;; check that the abbreviate function is consistent with how
;; Racket abbreviates in the run-time
(define-check (check-abbreviate key n)
(check-equal? (abbreviate-prefab-key key)
(prefab-struct-key
(apply make-prefab-struct key (make-list n 0)))))
(define tests
(test-suite
"Tests for prefab type helpers"
(check-normalize '(foo) 1 '(foo 1 (0 #f) #()))
(check-normalize '(foo) 3 '(foo 3 (0 #f) #()))
(check-normalize '(foo 1) 1 '(foo 1 (0 #f) #()))
(check-normalize '(foo 3) 3 '(foo 3 (0 #f) #()))
(check-normalize '(foo bar 3) 4 '(foo 1 (0 #f) #() bar 3 (0 #f) #()))
(check-normalize '(foo 3 bar 3) 6 '(foo 3 (0 #f) #() bar 3 (0 #f) #()))
(check-normalize '(foo 1 #()) 1 '(foo 1 (0 #f) #()))
(check-normalize '(foo 1 #(0)) 1 '(foo 1 (0 #f) #(0)))
(check-normalize '(foo 5 (0 #f)) 5 '(foo 5 (0 #f) #()))
(check-normalize '(foo 5 (1 #f)) 6 '(foo 5 (1 #f) #()))
(check-normalize '(foo 5 (0 #f) #()) 5 '(foo 5 (0 #f) #()))
(check-normalize '(foo bar 4) 7 '(foo 3 (0 #f) #() bar 4 (0 #f) #()))
(check-normalize '(foo (1 #f) bar 4) 8 '(foo 3 (1 #f) #() bar 4 (0 #f) #()))
(check-normalize '(foo #(1) bar 4) 7 '(foo 3 (0 #f) #(1) bar 4 (0 #f) #()))
(check-normalize '(foo bar 4 (1 #f)) 8 '(foo 3 (0 #f) #() bar 4 (1 #f) #()))
(check-normalize '(foo bar 1 baz 4 (1 #f))
8
'(foo 2 (0 #f) #() bar 1 (0 #f) #() baz 4 (1 #f) #()))
(check-equal? (prefab-key->field-count '(foo 1 (0 #f) #()))
1)
(check-equal? (prefab-key->field-count '(foo 1 (1 #f) #()))
2)
(check-equal? (prefab-key->field-count
'(foo 1 (1 #f) #() bar 1 (0 #f) #()))
3)
(check-equal? (prefab-key->field-count
'(foo 1 (1 #f) #() bar 1 (0 #f) #() baz 2 (0 #f) #()))
5)
(check-abbreviate '(foo) 1)
(check-abbreviate '(foo 1) 1)
(check-abbreviate '(foo 3) 3)
(check-abbreviate '(foo bar 3) 4)
(check-abbreviate '(foo 3 bar 3) 6)
(check-abbreviate '(foo 1 #()) 1)
(check-abbreviate '(foo 1 #(0)) 1)
(check-abbreviate '(foo 5 (0 #f)) 5)
(check-abbreviate '(foo 5 (1 #f)) 6)
(check-abbreviate '(foo 5 (0 #f) #()) 5)
(check-abbreviate '(foo 5 (1 #f) #()) 6)
(check-abbreviate '(foo 5 (0 #f) #(1)) 5)
(check-abbreviate '(foo 5 (1 #f) #(1)) 6)
(check-abbreviate '(foo 5 (0 #f) #() bar 1) 6)
(check-abbreviate '(foo 5 (0 #f) #(1) bar 1) 6)
(check-abbreviate '(foo 5 (1 #f) #(1) bar 1) 7)
(check-abbreviate '(foo 5 (1 #f) #(1) bar 1 #()) 7)
(check-abbreviate '(foo 5 (0 #f) #(1) bar 1 #()) 6)
(check-abbreviate '(foo 5 (0 #f) #() bar 1 #()) 6)
(check-abbreviate '(foo 5 (1 #f) #(1) bar 1 #(0)) 7)
(check-true (prefab-key-subtype? '(foo 1 (0 #f) #() bar 1 (0 #f) #())
'(bar 1 (0 #f) #())))
(check-false (prefab-key-subtype? '(foo 1 (0 #f) #())
'(bar 1 (0 #f) #())))
(check-equal? (prefab-key->field-mutability
'(foo 1 (0 #f) #() bar 1 (0 #f) #()))
(list #f #f))
(check-equal? (prefab-key->field-mutability
'(foo 2 (0 #f) #(0) bar 3 (0 #f) #(1)))
(list #f #t #f #t #f))
(check-equal? (prefab-key->field-mutability
'(foo 2 (0 #f) #(0) bar 3 (0 #f) #(1) baz 1 (0 #f) #(0)))
(list #t #f #t #f #t #f))))

14
typed-racket-test/unit-tests/subtype-tests.rkt
View File

@ -347,4 +347,18 @@
[FAIL
(-class #:method ((m (-> -Nat))) #:augment ((m (-> -Nat))))
(-class #:method ((m (-> -Nat))))]
;; prefab structs
[(-prefab 'foo -String) (-prefab 'foo -String)]
[(-prefab 'foo -String) (-prefab 'foo (-opt -String))]
[(-prefab '(bar foo 1) -String -Symbol) (-prefab 'foo -String)]
[(-prefab '(bar foo 1) -String -Symbol) (-prefab 'foo (-opt -String))]
[FAIL
(-prefab '(foo #(0)) -String) (-prefab '(foo #(0)) (-opt -String))]
[(-prefab '(foo 1 #(0)) -String -Symbol)
(-prefab '(foo #(0)) -String)]
[(-prefab '(bar foo 1 #(0)) -String -Symbol)
(-prefab '(foo #(0)) -String)]
[FAIL
(-prefab '(foo #()) -String) (-prefab '(foo #(0)) (-opt -String))]
))

33
typed-racket-test/unit-tests/typecheck-tests.rkt
View File

@ -96,6 +96,10 @@
;; test: syntax? tc-results? [(option/c tc-results?)]
;; [(listof (list id type))] -> void?
;; Checks that the expression typechecks using the expected type to the golden result.
;;
;; The new-mapping argument (here and in subsequent functions) is used to extend the
;; lexical type environment in the test case with additional bindings. Its use is to
;; simulate forms that are difficult to put in unit tests, like `struct`.
(define (test expr golden (expected #f) (new-mapping '()))
(test/proc expr (lambda (_) golden) expected new-mapping))
@ -3525,6 +3529,24 @@
;; PR 14889
[tc-err (ann (vector-ref (ann (vector "hi") (Vectorof String)) 0) Symbol)
#:msg #rx"Polymorphic function.*could not be applied"]
[tc-e (let ()
(foo-x (foo "foo"))
(foo-x #s(foo "foo"))
(foo-x #s((foo 1 (0 #f) #()) "foo"))
(foo-x #s((bar foo 1 (0 #f) #()) "foo" 'bar))
(foo-x #s((baz bar 1 foo 1 (0 #f) #()) "foo" 'bar 'baz)))
-String
#:extend-env ([foo (t:-> -String (-prefab 'foo -String))]
[foo-x (t:-> (-prefab 'foo -String) -String)])]
[tc-err (begin (foo-x "foo")
(error "foo"))
#:extend-env ([foo-x (t:-> (-prefab 'foo -String) -String)])
#:msg #rx"expected: \\(Prefab.*given: String"]
[tc-err (begin (foo-x #s(bar "bar"))
(error "foo"))
#:extend-env ([foo-x (t:-> (-prefab 'foo -String) -String)])
#:msg #rx"expected: \\(Prefab foo.*given: \\(Prefab bar"]
)
(test-suite
@ -3580,5 +3602,16 @@
#:expected (-mu X (-pair (-vec (t:Un (-val ':a) X)) (t:Un (-val ':b) X)))]
[tc-l/err #(1 2) #:expected (make-HeterogeneousVector (list -Number -Symbol))
#:msg #rx"expected: Symbol"]
[tc-l #s(foo "a" a)
(-prefab 'foo -String (-val 'a))]
[tc-l #s((foo 2 (0 #f) #()) "a" a)
(-prefab 'foo -String (-val 'a))]
[tc-l #s((foo bar 1) "a" a)
(-prefab '(foo bar 1) -String (-val 'a))]
[tc-l #s((foo bar 1 baz 1) "a" a)
(-prefab '(foo bar 1 baz 1) -String (-val 'a))]
[tc-l #s(foo "a")
(-prefab 'foo (-opt -String))
#:expected (-prefab 'foo (-opt -String))]
)
))