1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
|
#lang web-server/base
(require racket/stxparam
racket/match
"lib.rkt"
(only-in "unsafe/syntax.rkt"
#%#)
(for-syntax "lib.rkt"
racket/base
syntax/parse))
(provide formlet #%#)
; redefine formlet using contracted version of lib.rkt
(define-for-syntax (cross-of stx)
(syntax-parse
stx
#:literals (unquote unquote-splicing => #%# values)
[,(formlet . => . (values name:id ...)) (syntax/loc stx (vector name ...))]
[,(formlet . => . name:id) (syntax/loc stx name)]
[,e (syntax/loc stx null)]
[,@e (syntax/loc stx null)]
[(#%# n ...)
(quasisyntax/loc stx (list #,@(map cross-of (syntax->list #'(n ...)))))]
[(t ([k v] ...) n ...)
(quasisyntax/loc stx (list #,@(map cross-of (syntax->list #'(n ...)))))]
[(t n ...)
(quasisyntax/loc stx (list #,@(map cross-of (syntax->list #'(n ...)))))]
[s:expr
(syntax/loc stx null)]))
(define-for-syntax (circ-of stx)
(syntax-parse
stx
#:literals (unquote unquote-splicing => #%# values)
[,(formlet . => . (values name:id ...)) (syntax/loc stx (cross (pure (lambda (name ...) (vector name ...))) formlet))]
[,(formlet . => . name:id) (syntax/loc stx formlet)]
[,e (syntax/loc stx (xml e))]
[,@e (syntax/loc stx (xml-forest e))]
[(#%# n ...)
(let ([n-cross (map cross-of (syntax->list #'(n ...)))])
(quasisyntax/loc stx
(cross*
(pure (match-lambda*
[(list #,@n-cross)
(list #,@n-cross)]))
#,@(map circ-of (syntax->list #'(n ...))))))]
[(t ([k v] ...) n ...)
(quasisyntax/loc stx
(tag-xexpr `t `([k v] ...)
#,(circ-of (syntax/loc stx (#%# n ...)))))]
[(t n ...)
(quasisyntax/loc stx
(tag-xexpr `t null
#,(circ-of (syntax/loc stx (#%# n ...)))))]
[s:expr
(syntax/loc stx (xml 's))]))
(define-syntax (formlet stx)
(syntax-parse stx
[(_ q e:expr)
(quasisyntax/loc stx
(cross (pure (match-lambda [#,(cross-of #'q) e]))
#,(circ-of #'q)))]))
|
