diff options
Diffstat (limited to 'language')
| -rw-r--r-- | language/cloudformation/spec.scm | 218 |
1 files changed, 218 insertions, 0 deletions
diff --git a/language/cloudformation/spec.scm b/language/cloudformation/spec.scm new file mode 100644 index 0000000..041dc6d --- /dev/null +++ b/language/cloudformation/spec.scm @@ -0,0 +1,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) |