33543ce054
When exporting row polymorphic functions from TR, just use absent clauses to ensure that TR won't accidentally try to add pre-existing fields/methods. No sealing is needed because the typechecker enforces parameteric use of the class.
343 lines
10 KiB
Racket
343 lines
10 KiB
Racket
#lang racket/base
|
|
|
|
(require "test-utils.rkt"
|
|
racket/list racket/format rackunit
|
|
(static-contracts instantiate optimize combinators structures)
|
|
(for-syntax racket/base syntax/parse))
|
|
|
|
(provide tests)
|
|
(gen-test-main)
|
|
|
|
(define-syntax (check-optimize stx)
|
|
(syntax-parse stx
|
|
[(_ argument* #:pos positive-expected* #:neg negative-expected*)
|
|
#'(test-suite (~a 'argument*)
|
|
(test-case "Trusted Positive"
|
|
(check-optimize-helper argument* positive-expected* #t #f))
|
|
(test-case "Trusted Negative"
|
|
(check-optimize-helper argument* negative-expected* #f #t)))]))
|
|
|
|
(define (check-optimize-helper argument expected trusted-positive trusted-negative)
|
|
(define trusted-side
|
|
(cond
|
|
[(and trusted-positive trusted-negative) 'both]
|
|
[trusted-positive 'positive]
|
|
[trusted-negative 'negative]
|
|
[else 'neither]))
|
|
(with-check-info*
|
|
(list (make-check-info 'original argument)
|
|
(make-check-info 'trusted trusted-side)
|
|
(make-check-expected expected))
|
|
(λ ()
|
|
(let ([opt (optimize argument
|
|
#:trusted-positive trusted-positive
|
|
#:trusted-negative trusted-negative)])
|
|
(with-check-info* (list (make-check-actual opt))
|
|
(lambda ()
|
|
(unless (equal? opt expected)
|
|
(fail-check))))))))
|
|
|
|
(define-syntax (check-syntax stx)
|
|
(syntax-parse stx
|
|
[(_ argument* expected*)
|
|
#'(test-case (~a 'argument*)
|
|
(define argument argument*)
|
|
(define expected expected*)
|
|
(with-check-info*
|
|
(list (make-check-info 'original argument)
|
|
(make-check-expected expected))
|
|
(λ ()
|
|
(let ([ctc (syntax->datum
|
|
(cadr
|
|
(instantiate
|
|
(optimize argument #:trusted-positive #t)
|
|
(λ (#:reason [reason #f]) (error 'nyi))
|
|
'impersonator)))])
|
|
(with-check-info* (list (make-check-actual ctc))
|
|
(λ ()
|
|
(unless (equal? ctc expected)
|
|
(fail-check))))))))]))
|
|
|
|
;; Ids with unique identity so that equals works
|
|
(define foo-id #'foo)
|
|
(define bar-id #'bar)
|
|
|
|
(define syntax-tests
|
|
(test-suite "Optimized Syntax Tests"
|
|
(check-syntax list?/sc
|
|
'any/c)
|
|
(check-syntax (arr/sc null #f (list list?/sc))
|
|
'(-> any))
|
|
(check-syntax (hash/sc list?/sc list?/sc)
|
|
'(hash/c list? list?))
|
|
|
|
))
|
|
|
|
|
|
(define optimizer-tests
|
|
(test-suite "Optimizer Tests"
|
|
;; Lists
|
|
(check-optimize (listof/sc any/sc)
|
|
#:pos any/sc
|
|
#:neg list?/sc)
|
|
(check-optimize (listof/sc none/sc)
|
|
#:pos any/sc
|
|
#:neg empty-list/sc)
|
|
|
|
;; Heterogeneous Lists
|
|
;; TODO fix ability to test equality here
|
|
#;
|
|
(check-optimize (list/sc any/sc)
|
|
#:pos any/sc
|
|
#:neg (list-length/sc 1))
|
|
(check-optimize (list/sc none/sc)
|
|
#:pos any/sc
|
|
#:neg none/sc)
|
|
(check-optimize (list/sc)
|
|
#:pos any/sc
|
|
#:neg empty-list/sc)
|
|
|
|
;; Sets
|
|
(check-optimize (set/sc any/sc)
|
|
#:pos any/sc
|
|
#:neg set?/sc)
|
|
(check-optimize (set/sc none/sc)
|
|
#:pos any/sc
|
|
#:neg empty-set/sc)
|
|
|
|
|
|
;; Vectors
|
|
(check-optimize (vectorof/sc any/sc)
|
|
#:pos any/sc
|
|
#:neg vector?/sc)
|
|
(check-optimize (vectorof/sc none/sc)
|
|
#:pos (vectorof/sc none/sc)
|
|
#:neg (vectorof/sc none/sc))
|
|
|
|
;; Heterogeneous Vectors
|
|
;; TODO fix ability to test equality here
|
|
#;
|
|
(check-optimize (vector/sc any/sc)
|
|
#:pos any/sc
|
|
#:neg (vector-length/sc 1))
|
|
(check-optimize (vector/sc none/sc)
|
|
#:pos (vector/sc none/sc)
|
|
#:neg (vector/sc none/sc))
|
|
;; TODO fix ability to test equality here
|
|
#;
|
|
(check-optimize (vector/sc)
|
|
#:pos any/sc
|
|
#:neg empty-vector/sc)
|
|
(check-optimize (vector/sc set?/sc)
|
|
#:pos (vector/sc set?/sc)
|
|
#:neg (vector/sc set?/sc))
|
|
|
|
;; HashTables
|
|
(check-optimize (hash/sc any/sc any/sc)
|
|
#:pos any/sc
|
|
#:neg hash?/sc)
|
|
(check-optimize (hash/sc none/sc any/sc)
|
|
#:pos (hash/sc none/sc any/sc)
|
|
#:neg (hash/sc none/sc any/sc))
|
|
(check-optimize (hash/sc any/sc none/sc)
|
|
#:pos (hash/sc any/sc none/sc)
|
|
#:neg (hash/sc any/sc none/sc))
|
|
|
|
;; And
|
|
(check-optimize (and/sc set?/sc)
|
|
#:pos any/sc
|
|
#:neg set?/sc)
|
|
(check-optimize (and/sc set?/sc any/sc)
|
|
#:pos any/sc
|
|
#:neg set?/sc)
|
|
(check-optimize (and/sc set?/sc none/sc)
|
|
#:pos any/sc
|
|
#:neg none/sc)
|
|
(check-optimize (and/sc)
|
|
#:pos any/sc
|
|
#:neg any/sc)
|
|
(check-optimize (and/sc any/sc any/sc)
|
|
#:pos any/sc
|
|
#:neg any/sc)
|
|
|
|
|
|
;; Or
|
|
(check-optimize (or/sc set?/sc)
|
|
#:pos any/sc
|
|
#:neg set?/sc)
|
|
(check-optimize (or/sc set?/sc any/sc)
|
|
#:pos any/sc
|
|
#:neg any/sc)
|
|
(check-optimize (or/sc set?/sc none/sc)
|
|
#:pos any/sc
|
|
#:neg set?/sc)
|
|
(check-optimize (or/sc)
|
|
#:pos any/sc
|
|
#:neg none/sc)
|
|
(check-optimize (or/sc none/sc none/sc)
|
|
#:pos any/sc
|
|
#:neg none/sc)
|
|
|
|
;; None
|
|
(check-optimize none/sc
|
|
#:pos any/sc
|
|
#:neg none/sc)
|
|
|
|
;; Boxes
|
|
(check-optimize (box/sc any/sc)
|
|
#:pos any/sc
|
|
#:neg box?/sc)
|
|
(check-optimize (box/sc none/sc)
|
|
#:pos (box/sc none/sc)
|
|
#:neg (box/sc none/sc))
|
|
(check-optimize (box/sc set?/sc)
|
|
#:pos (box/sc set?/sc)
|
|
#:neg (box/sc set?/sc))
|
|
|
|
;; Syntax Objects
|
|
(check-optimize (syntax/sc any/sc)
|
|
#:pos any/sc
|
|
#:neg syntax?/sc)
|
|
(check-optimize (syntax/sc none/sc)
|
|
#:pos any/sc
|
|
#:neg none/sc)
|
|
(check-optimize (syntax/sc set?/sc)
|
|
#:pos any/sc
|
|
#:neg (syntax/sc set?/sc))
|
|
|
|
;; Promises
|
|
(check-optimize (promise/sc any/sc)
|
|
#:pos any/sc
|
|
#:neg promise?/sc)
|
|
(check-optimize (promise/sc none/sc)
|
|
#:pos any/sc
|
|
#:neg (promise/sc none/sc))
|
|
(check-optimize (promise/sc set?/sc)
|
|
#:pos any/sc
|
|
#:neg (promise/sc set?/sc))
|
|
(check-optimize (promise/sc (box/sc set?/sc))
|
|
#:pos (promise/sc (box/sc set?/sc))
|
|
#:neg (promise/sc (box/sc set?/sc)))
|
|
|
|
(check-optimize
|
|
(function/sc (list (listof/sc any/sc))
|
|
(list)
|
|
(list)
|
|
(list)
|
|
#f
|
|
(list (listof/sc any/sc)))
|
|
#:pos
|
|
(function/sc (list list?/sc)
|
|
(list)
|
|
(list)
|
|
(list)
|
|
#f
|
|
#f)
|
|
#:neg
|
|
(function/sc (list any/sc)
|
|
(list)
|
|
(list)
|
|
(list)
|
|
#f
|
|
(list list?/sc)))
|
|
(check-optimize
|
|
(function/sc (list (listof/sc any/sc))
|
|
(list)
|
|
(list)
|
|
(list)
|
|
#f
|
|
(list any/sc))
|
|
#:pos
|
|
(function/sc (list list?/sc)
|
|
(list)
|
|
(list)
|
|
(list)
|
|
#f
|
|
#f)
|
|
#:neg
|
|
(function/sc (list any/sc)
|
|
(list)
|
|
(list)
|
|
(list)
|
|
#f
|
|
(list any/sc)))
|
|
|
|
(check-optimize (case->/sc empty)
|
|
#:pos (case->/sc empty)
|
|
#:neg (case->/sc empty))
|
|
(check-optimize (parameter/sc list?/sc set?/sc)
|
|
#:pos (parameter/sc list?/sc any/sc)
|
|
#:neg (parameter/sc any/sc set?/sc))
|
|
|
|
(check-optimize
|
|
(case->/sc (list (arr/sc (list (listof/sc any/sc)) (listof/sc (set/sc any/sc)) (list (listof/sc any/sc)))))
|
|
#:pos (case->/sc (list (arr/sc (list list?/sc) (listof/sc set?/sc) #f)))
|
|
#:neg (case->/sc (list (arr/sc (list any/sc) any/sc (list list?/sc)))))
|
|
|
|
(check-optimize
|
|
(object/sc #t (list (member-spec 'field 'x (listof/sc any/sc))))
|
|
#:pos (object/sc #t (list (member-spec 'field 'x list?/sc)))
|
|
#:neg (object/sc #t (list (member-spec 'field 'x list?/sc))))
|
|
|
|
(check-optimize
|
|
(object/sc #f (list (member-spec 'field 'x (listof/sc any/sc))))
|
|
#:pos (object/sc #f (list (member-spec 'field 'x list?/sc)))
|
|
#:neg (object/sc #f (list (member-spec 'field 'x list?/sc))))
|
|
|
|
(check-optimize
|
|
(class/sc #t (list (member-spec 'field 'x (listof/sc any/sc))) null)
|
|
#:pos (class/sc #t (list (member-spec 'field 'x list?/sc)) null)
|
|
#:neg (class/sc #t (list (member-spec 'field 'x list?/sc)) null))
|
|
|
|
(check-optimize
|
|
(class/sc #f (list (member-spec 'field 'x (listof/sc any/sc))) null)
|
|
#:pos (class/sc #f (list (member-spec 'field 'x list?/sc)) null)
|
|
#:neg (class/sc #f (list (member-spec 'field 'x list?/sc)) null))
|
|
|
|
(check-optimize
|
|
(recursive-sc (list foo-id bar-id)
|
|
(list (listof/sc (recursive-sc-use foo-id))
|
|
(listof/sc (recursive-sc-use bar-id)))
|
|
(recursive-sc-use foo-id))
|
|
#:pos (recursive-sc (list foo-id)
|
|
(list (listof/sc (recursive-sc-use foo-id)))
|
|
(recursive-sc-use foo-id))
|
|
#:neg (recursive-sc (list foo-id)
|
|
(list (listof/sc (recursive-sc-use foo-id)))
|
|
(recursive-sc-use foo-id)))
|
|
|
|
(check-optimize
|
|
(recursive-sc (list foo-id bar-id)
|
|
(list (listof/sc any/sc )
|
|
(listof/sc any/sc))
|
|
(recursive-sc-use foo-id))
|
|
#:pos any/sc
|
|
#:neg list?/sc)
|
|
|
|
(check-optimize (cons/sc any/sc list?/sc)
|
|
#:pos any/sc
|
|
#:neg (cons/sc any/sc list?/sc))
|
|
|
|
(check-optimize
|
|
(case->/sc
|
|
(list
|
|
(arr/sc empty #f (list set?/sc))
|
|
(arr/sc (list identifier?/sc) #f (list (listof/sc set?/sc)))))
|
|
#:pos (function/sc (list)
|
|
(list identifier?/sc)
|
|
(list)
|
|
(list)
|
|
#f
|
|
#f)
|
|
#:neg (case->/sc
|
|
(list
|
|
(arr/sc empty #f (list set?/sc))
|
|
(arr/sc (list any/sc) #f (list (listof/sc set?/sc))))))
|
|
|
|
))
|
|
|
|
(define tests
|
|
(test-suite "Static Contracts"
|
|
syntax-tests
|
|
optimizer-tests))
|