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
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
|
(define-module (language cloudformation spec)
#:use-module (aws json)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
#:use-module (system base language)
#:export (cloudformation))
(define (property-type-name? name)
(number? (string-index name #\.)))
(define (aws-string->symbol str)
;; Drop the "AWS::" that's at the beginning of *almost* everything.
(let ((str (if (string-prefix? "AWS::" str)
(string-drop str 5)
str)))
(list->symbol
(let loop ((i 0)
(same-word? #t))
(cond
((= i (string-length str)) ; end of string
'())
;; "IoT" violates all the rules. grrrr
((and (< (+ i 3) (string-length str))
(eqv? (string-ref str i) #\I)
(eqv? (string-ref str (+ i 1)) #\o)
(eqv? (string-ref str (+ i 2)) #\T))
(cons* #\i #\o #\t (loop (+ i 3) #f)))
;; Get rid of "."
((eqv? (string-ref str i) #\.)
(loop (1+ i) #f))
;; Get rid of "::"
((and (eqv? (string-ref str i) #\:)
(eqv? (string-ref str (1+ i)) #\:))
(loop (+ i 2) #f))
((char-upper-case? (string-ref str i)) ; detect camel casing
(cond
;; If we've had a string of uppercase characters and the
;; next character is lowercase, we're actually at the
;; beginning of a new word. For example, when we reach the
;; "I" in "DBInstance" we need to treat it as the beginning
;; of a new word.
((and same-word?
(< (1+ i) (string-length str))
(char-lower-case? (string-ref str (1+ i))))
(loop i #f))
;; Consecutive uppercase characters are part of the same word.
(same-word?
(cons (char-downcase (string-ref str i)) (loop (1+ i) #t)))
;; Encountering an uppercase character after a series of
;; non-uppercase characters means that we are at the
;; beginning of a new word.
(else
(if (zero? i)
(cons (char-downcase (string-ref str i)) (loop (1+ i) #t))
(cons* #\- (char-downcase (string-ref str i)) (loop (1+ i) #t))))))
(else
(cons (string-ref str i) (loop (1+ i) #f))))))))
(define (classify sym)
"Add < and > around SYM to form a conventional class name."
(symbol-append '< sym '>))
(define (compile-type-class name spec)
(cond
((assoc-ref spec "PrimitiveType")
(aws-primitive-type->class
(assoc-ref spec "PrimitiveType")))
((string=? (assoc-ref spec "Type") "List")
`(list
(quote list)
,(pk 'list
(if (assoc-ref spec "PrimitiveItemType")
(aws-primitive-type->class
(assoc-ref spec "PrimitiveItemType"))
(aws-composite-type->class
(aws-string->symbol
(car (string-split name #\.)))
(assoc-ref spec "ItemType"))))))
((string=? (assoc-ref spec "Type") "Map")
`(list
(quote map)
,(pk 'list
(if (assoc-ref spec "PrimitiveItemType")
(aws-primitive-type->class
(assoc-ref spec "PrimitiveItemType"))
(aws-composite-type->class
(aws-string->symbol
(car (string-split name #\.)))
(assoc-ref spec "ItemType"))))))
(else
(aws-composite-type->class
(aws-string->symbol
(car (string-split name #\.)))
(assoc-ref spec "Type")))))
(define (compile-property-type exp)
(match exp
((name . spec)
(let* ((sym (aws-string->symbol name))
(class-name (pk 'class-name (classify sym))))
`(begin
(define-composite-property ,class-name
,name ,(assoc-ref spec "Documentation")
,@(map (match-lambda
((pname . pspec)
(list (aws-string->symbol pname)
pname
(assoc-ref pspec "Required")
(assoc-ref pspec "Documentation")
(compile-type-class name pspec)
(assoc-ref pspec "UpdateType"))))
(assoc-ref spec "Properties")))
,(compile-resource-constructor sym
(assoc-ref spec "Properties"))
(export ,class-name
,sym ; constructor
;; Export all slot getter methods.
,@(map (match-lambda
((pname . _)
(aws-string->symbol pname)))
(assoc-ref spec "Properties"))))))))
(define (compile-attribute exp)
(match exp
((name . spec)
;; TODO: pick the right type checker
(list (aws-string->symbol name) name 'string?))))
(define (aws-primitive-type->class type)
(pk 'primitive-type
(match type
("String" '<string>)
("Boolean" '<boolean>)
((or "Integer" "Long") '<integer>)
("Double" '<real>)
("Timestamp" '<date>)
;; TODO: deal with this
("Json" '<top>))))
(define (aws-composite-type->class prefix type)
(match type
("Tag" '<tag>)
(_
(pk 'composite-type
(classify (symbol-append prefix '- (aws-string->symbol type)))))))
(define (compile-resource-constructor name properties)
(let ((required-properties
(filter-map (match-lambda
((aws-name . spec)
(and (assoc-ref spec "Required")
(aws-string->symbol aws-name))))
properties))
(optional-properties
(filter-map (match-lambda
((aws-name . spec)
(and (not (assoc-ref spec "Required"))
(aws-string->symbol aws-name))))
properties)))
`(define* (,name #:key
,@(map (lambda (arg)
`(,arg (error "missing required property:"
(quote ,arg))))
required-properties)
,@optional-properties
#:rest kwargs)
;; TODO: Generate docstring.
(apply make ,(classify name) kwargs))))
(define (compile-resource-type exp)
(match exp
((name . spec)
(let* ((sym (aws-string->symbol name))
(class-name (classify sym)))
`(begin
(define-resource ,(pk 'resource-class class-name)
,name ,(assoc-ref spec "Documentation")
,(map compile-attribute (or (assoc-ref spec "Attributes") '()))
,(map (match-lambda
((pname . spec)
(let ((sym (aws-string->symbol pname)))
(list sym
pname
(pk 'property sym (compile-type-class name spec))
(assoc-ref spec "Required")
(assoc-ref spec "UpdateType")
(assoc-ref spec "Documentation")))))
(assoc-ref spec "Properties")))
,(compile-resource-constructor sym (assoc-ref spec "Properties"))
(export ,class-name ,sym
;; Export all slot getter methods.
,@(map (match-lambda
((aws-name . _)
(aws-string->symbol aws-name)))
(assoc-ref spec "Properties"))))))))
(define (compile-scheme exp env opts)
(values `(begin
(define-module (aws cloudformation)
#:use-module (aws cloudformation utils)
#:use-module (oop goops)
#:use-module (srfi srfi-19))
(define <date> (class-of (current-date)))
(define-public cloudformation-specification-version
,(assoc-ref exp "ResourceSpecificationVersion"))
,@(map compile-property-type (assoc-ref exp "PropertyTypes"))
,@(map compile-resource-type (assoc-ref exp "ResourceTypes")))
env env))
(define-language cloudformation
#:title "AWS Cloudformation"
#:reader (lambda (port env)
(if (eof-object? (peek-char port))
(read-char port)
(read-json port)))
#:compilers `((scheme . ,compile-scheme))
#:printer write)
|
