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

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

@ -2,12 +2,16 @@
(require polysemy
rackunit
syntax/macro-testing
(poly-rename-in "test-2-provide.rkt"
[foo |(poly-case string?)| bar]
[bar |(poly-case string?)| foo]))
[[foo bar] |(poly-case string?)|]
[[bar foo] |(poly-case string?)|]))
(check-equal? (foo 1) 11)
(check-equal? (foo "abc") "bar-abc")
(check-equal? (bar 1) 21)
(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
(provide (poly-out [baz identifier-macro match-expander]))
(require polysemy
rackunit)
(provide (poly-out [baz identifier-macro match-expander]))
(require (poly-rename-in "test-provide.rkt"
[foo identifier-macro baz])
[(foo baz) identifier-macro])
(poly-rename-in "test-provide-b.rkt"
[bar identifier-macro foo]
[bar match-expander baz]
[(bar foo) identifier-macro]
[(bar baz) match-expander]
[foo match-expander]))
(define-poly bar identifier-macro (λ (stx) #'"overridden bar"))
@ -36,4 +36,4 @@
'((a aa aaa) (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)))