-
Notifications
You must be signed in to change notification settings - Fork 0
/
example-macros.rkt
89 lines (78 loc) · 2.51 KB
/
example-macros.rkt
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
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
#lang racket/base
(require plai
(prefix-in contract: racket/contract))
(require (for-syntax "../../tests/kb-base/example-keybindings/plai.rkt"
"../../tests/kb-base/example-keybindings/contracts.rkt"
"../../tests/kb-base/example-keybindings/misc-racket.rkt"
"../../kb-base/kb-base/helpers.rkt"
syntax/parse
racket/base
racket/list))
(define-syntax (my-cond stx)
(attach-keybindings
(syntax-parse stx
#:literals (else)
[(_ [else expr ...])
#'(begin expr ...)]
[(_)
#'(void)]
[(_ [q-expr a-expr ...] c-clause ...)
#'(if q-expr
(begin a-expr ...)
(my-cond c-clause ...))])
(list
(make-kb "c:b"
swap-cond-branches
"cond-kb"
'local
stx))))
(my-cond [(= 1 0) "umm..."]
[(> 1 0) (my-cond [#f #f]
[#t #t])]
[(< 1 0) #f])
(define-syntax (my-define-type stx)
(syntax-parse stx
[(_ type-name
[var-name (field-name field-c) field-clause ...]
...)
(define first-var-pos (- (syntax-position (third (syntax->list stx))) 1))
(attach-keybindings
#'(define-type type-name [var-name (field-name field-c) field-clause ...] ...)
(list (make-kb "c:space"
(gen-type-case (symbol->string (syntax-e #'type-name))
first-var-pos)
"generate-type-case"
'global
stx)))]))
(my-define-type Shape
[circle (r number?)]
[rect (l number?)
(w number?)])
(define-syntax (-> stx)
(syntax-parse stx
[(_ mandatory-dom ... range)
(attach-keybindings
#'(contract:-> mandatory-dom ... range)
(list (make-kb "c:a"
arrow-to-arrow-star
"arrow-to-arrow-star"
'local
stx)))]))
(define/contract (my-f n)
(-> number? string?)
(make-string n #\a))
(define-syntax (->* stx)
(syntax-parse stx
[(_ (mandatory-dom ...) (optional-dom ...) range)
(attach-keybindings
#'(contract:->* (mandatory-dom ...) (optional-dom ...) range)
(list (make-kb "c:q"
arrow-star-to-arrow-i
"arrow-star-to-arrow-i"
'local
stx)))]))
(define/contract (other-f n [c #\a])
(->* (number?)
(char?)
string?)
(make-string n c))