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

Correctly combine or filters in combine-props.

Browse Source 
Closes PR 14534.
This commit is contained in:
Eric Dobson 2014-06-02 22:30:55 -07:00
parent 83edd9b52d
commit 48ac219d6f
3 changed files with 47 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-metafunctions.rkt
View File

@ -218,10 +218,10 @@
(cond
[(null? ps) (apply -or result)]
[(for/or ([other-p (in-list (append derived-formulas derived-atoms))])
(complementary? (car ps) other-p))
(contradictory? (car ps) other-p))
(or-loop (cdr ps) result)]
[(for/or ([other-p (in-list derived-atoms)])
(implied-atomic? (car ps) other-p))
(implied-atomic? (car ps) other-p))
-top]
[else (or-loop (cdr ps) (cons (car ps) result))]))])
(if (OrFilter? new-or)

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

@ -39,4 +39,5 @@
"check-below-tests.rkt"
"init-env-tests.rkt"
"filter-tests.rkt"
"metafunction-tests.rkt"
"rep-tests.rkt")

44
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/metafunction-tests.rkt Normal file
View File

@ -0,0 +1,44 @@
#lang racket/base
(require "test-utils.rkt"
rackunit racket/format
(types abbrev union filter-ops)
(typecheck tc-metafunctions)
(for-syntax racket/base syntax/parse))
(provide tests)
(gen-test-main)
(define-syntax (test-combine-props stx)
(syntax-parse stx
[(_ new:expr existing:expr expected:expr box-v:expr)
(quasisyntax/loc stx
(test-case (~a '(new + existing = expected))
(define b (box #t))
(define-values (res-formulas res-props) (combine-props new existing b))
#,(syntax/loc stx (check-equal? (append res-formulas res-props) expected))
#,(syntax/loc stx (check-equal? (unbox b) box-v))))]))
(define tests
(test-suite "Metafunctions"
(test-suite "combine-props"
(test-combine-props
(list (-or (-not-filter -String #'x) (-not-filter -String #'y)))
(list (-filter (Un -String -Symbol) #'x) (-filter (Un -String -Symbol) #'y))
(list (-or (-not-filter -String #'y) (-not-filter -String #'x))
(-filter (Un -String -Symbol) #'y) (-filter (Un -String -Symbol) #'x))
#t)
(test-combine-props
(list (-or (-filter -String #'x) (-filter -String #'y)))
(list (-filter (Un -String -Symbol) #'x) (-filter (Un -String -Symbol) #'y))
(list (-or (-filter -String #'y) (-filter -String #'x))
(-filter (Un -String -Symbol) #'y) (-filter (Un -String -Symbol) #'x))
#t)
)
))