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

Fixed tests

Browse Source
This commit is contained in:
Georges Dupéron 2017-05-09 20:08:58 +02:00
parent e572113b0c
commit 92f18c3978
3 changed files with 27 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
main.rkt
View File

@ -63,13 +63,15 @@
...] ...]
...) ...)
#:with ((old-generated-id ...) ...) #:with ((old-generated-id ...) ...)
(map (λ (id meanings) (map (λ (meaning) (gen-id id meaning)) meanings)) (map (λ (id meanings) (map (λ (meaning) (gen-id id (syntax-e meaning)))
(syntax->list meanings)))
(syntax->list #'(old-id ...)) (syntax->list #'(old-id ...))
(map syntax-e (syntax->list #'((meaning ...) ...)))) (syntax->list #'((meaning ...) ...)))
#:with (new-generated-id ...) #:with ((new-generated-id ...) ...)
(map (λ (id meanings) (map (λ (meaning) (gen-id id meaning)) meanings)) (map (λ (id meanings) (map (λ (meaning) (gen-id id (syntax-e meaning)))
(syntax->list meanings)))
(syntax->list #'(new-id ...)) (syntax->list #'(new-id ...))
(map syntax-e (syntax->list #'((meaning ...) ...)))) (syntax->list #'((meaning ...) ...)))
#:with (new-id-no-duplicates ...) #:with (new-id-no-duplicates ...)
(remove-duplicates (syntax->list #'(new-id ...)) (remove-duplicates (syntax->list #'(new-id ...))
free-identifier=?) free-identifier=?)
@ -124,12 +126,12 @@
(map (λ (one-id) (gen-id one-id '| safeguard |)) (map (λ (one-id) (gen-id one-id '| safeguard |))
(syntax->list #'(new-id ...)))]) (syntax->list #'(new-id ...)))])
(register-meanings (syntax->datum #'(meaning ... ...))) (register-meanings (syntax->datum #'(meaning ... ...)))
(expand-export #'(combine-out new-id ... (pre-expand-export #'(combine-out new-id ...
safeguard ... safeguard ...
(rename-out [old-generated-id (rename-out [old-generated-id
new-generated-id] new-generated-id]
... ...)) ... ...))
modes))])))) modes))]))))
;; Definition of polysemic identifiers and parts of these ;; Definition of polysemic identifiers and parts of these
;; _____________________________________________________________________________ ;; _____________________________________________________________________________
@ -267,7 +269,7 @@
(for ([expanded (in-list expanded*)]) (for ([expanded (in-list expanded*)])
(when (free-id-set-member? covered-ids expanded) (when (free-id-set-member? covered-ids expanded)
(raise-syntax-error 'polysemy (raise-syntax-error 'polysemy
"Overlap between function cases" "some available function cases overlap"
stx stx
#f #f
pred-ids)) pred-ids))

10
test/test-2-require.rkt
View File

@ -2,12 +2,16 @@
(require polysemy (require polysemy
rackunit rackunit
syntax/macro-testing
(poly-rename-in "test-2-provide.rkt" (poly-rename-in "test-2-provide.rkt"
[foo |(poly-case string?)| bar] [[foo bar] |(poly-case string?)|]
[bar |(poly-case string?)| foo])) [[bar foo] |(poly-case string?)|]))
(check-equal? (foo 1) 11) (check-equal? (foo 1) 11)
(check-equal? (foo "abc") "bar-abc") (check-equal? (foo "abc") "bar-abc")
(check-equal? (bar 1) 21) (check-equal? (bar 1) 21)
(check-equal? (bar "abc") 3) (check-equal? (bar "abc") 3)
(baz "abc") (check-exn #px"overlap"
(λ ()
(convert-compile-time-error
(baz "abc"))))

12
test/test-require.rkt
View File

@ -1,15 +1,15 @@
#lang racket #lang racket
(provide (poly-out [baz identifier-macro match-expander]))
(require polysemy (require polysemy
rackunit) rackunit)
(provide (poly-out [baz identifier-macro match-expander]))
(require (poly-rename-in "test-provide.rkt" (require (poly-rename-in "test-provide.rkt"
[foo identifier-macro baz]) [(foo baz) identifier-macro])
(poly-rename-in "test-provide-b.rkt" (poly-rename-in "test-provide-b.rkt"
[bar identifier-macro foo] [(bar foo) identifier-macro]
[bar match-expander baz] [(bar baz) match-expander]
[foo match-expander])) [foo match-expander]))
(define-poly bar identifier-macro (λ (stx) #'"overridden bar")) (define-poly bar identifier-macro (λ (stx) #'"overridden bar"))
@ -36,4 +36,4 @@
'((a aa aaa) (b bb bbb))) '((a aa aaa) (b bb bbb)))
(check-equal? (my-macro2 a aa aaa foo b bb bbb) (check-equal? (my-macro2 a aa aaa foo b bb bbb)
'((a aa aaa) 42 (b bb bbb))) '((a aa aaa) 42 (b bb bbb)))