diff options
Diffstat (limited to 'language')
| -rw-r--r-- | language/cloudformation/spec.scm | 311 |
1 files changed, 139 insertions, 172 deletions
diff --git a/language/cloudformation/spec.scm b/language/cloudformation/spec.scm index 041dc6d..4cc1019 100644 --- a/language/cloudformation/spec.scm +++ b/language/cloudformation/spec.scm @@ -1,5 +1,6 @@ (define-module (language cloudformation spec) - #:use-module (aws json) + #:use-module (aws cloudformation utils) + #:use-module (aws cloudformation utils json) #:use-module (ice-9 match) #:use-module (ice-9 pretty-print) #:use-module (srfi srfi-1) @@ -9,186 +10,147 @@ (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-slots properties) + (define (update-type-string->symbol s) + (match s + ("Conditional" 'conditional) + ("Immutable" 'immutable) + ("Mutable" 'mutable))) + (define (primitive-type-checker type) + (match type + ("String" 'string?) + ("Boolean" 'boolean?) + ((or "Integer" "Long") 'integer?) + ("Double" 'real?) + ("Timestamp" 'date?) + ;; TODO: deal with this + ("Json" '(const #t)))) + (define (type-checker pspec) + (cond + ;; Primitive types + ((assoc-ref pspec "PrimitiveType") => + primitive-type-checker) + ;; Primitive lists/maps + ((assoc-ref pspec "PrimitiveItemType") => + (lambda (item-type) + (match (assoc-ref pspec "Type") + ("List" + `(lambda (items) + (every (lambda (item) + (type-check ,(primitive-type-checker item-type) + item)) + items))) + ("Map" + `(lambda (items) + (every (match-lambda + ((key . value) + (and (or (string? key) (symbol? key)) + (,(primitive-type-checker item-type) value))) + (_ #f)) + items)))))) + ;; Composite lists/maps + ((assoc-ref pspec "ItemType") + (match (assoc-ref pspec "Type") + ("List" + '(lambda (items) (every valid? items))) + ("Map" + '(lambda (items) + (every (match-lambda + ((key . value) + (and (or (string? key) (symbol? key)) + (valid? value))) + (_ #f)) + items))))) + ;; Composite types + ((assoc-ref pspec "Type") + 'valid?) + ;; Uh oh! + (else + (error "cannot compute type checker for property specification:" pspec)))) + (map (match-lambda + ((pname . pspec) + (let* ((boolean? (equal? (assoc-ref pspec "PrimitiveType") + "Boolean")) + (slot-name-base (aws-string->symbol pname)) + ;; Make boolean property names more + ;; Scheme-like by using a question mark + ;; at the end. + (slot-name (if boolean? + (symbol-append slot-name-base '?) + slot-name-base))) + `(,slot-name + #:init-keyword ,(symbol->keyword slot-name) + #:accessor ,slot-name + #:cfn-property + (make <cloudformation-property> + #:documentation-url ,(assoc-ref pspec "Documentation") + #:name ,pname + #:required? ,(assoc-ref pspec "Required") + #:type-checker ,(type-checker pspec) + #:update-type ',(update-type-string->symbol + (assoc-ref pspec "UpdateType"))))))) + properties)) + +(define (strip-namespace s) + (match (delete "" (string-split s #\:)) + ((_ _ x) x) + ((x) x))) (define (compile-property-type exp) (match exp ((name . spec) - (let* ((sym (aws-string->symbol name)) - (class-name (pk 'class-name (classify sym)))) + (let* ((sym (aws-string->symbol (strip-namespace name))) + (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")) + (define-class ,class-name (<cloudformation-object>) + ,@(compile-property-slots (assoc-ref spec "Properties")) + #:cfn-name ,name + #:documentation-url ,(assoc-ref spec "Documentation")) (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) + (define (primitive-type-string->symbol type) + (match type + ;; TODO: Handle JSON in a special way? + ((or "Json" "String") 'string) + ("Boolean" 'boolean) + ("Integer" 'integer))) + (define (compile-attributes attributes) + (if attributes + (map (match-lambda + ((name . spec) + `(cons ',(aws-string->symbol name) + (make <cloudformation-attribute> + #:name ,name + #:primitive-type + ',(primitive-type-string->symbol + ;; TODO: Handle attribute arrays + (or (assoc-ref spec "PrimitiveType") + (assoc-ref spec "PrimitiveItemType"))))))) + attributes) + '())) (match exp ((name . spec) - (let* ((sym (aws-string->symbol name)) + (let* ((sym (aws-string->symbol + (strip-namespace 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 + (define-class ,class-name (<cloudformation-resource>) + ,@(compile-property-slots (assoc-ref spec "Properties")) + #:cfn-name ,name + #:documentation-url ,(assoc-ref spec "Documentation") + #:attributes + (list ,@(compile-attributes (assoc-ref spec "Attributes")))) + (export ,class-name ;; Export all slot getter methods. ,@(map (match-lambda ((aws-name . _) @@ -196,23 +158,28 @@ (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)) + (let ((module-suffix (string->symbol (assoc-ref exp "ModuleSuffix"))) + (version (assoc-ref exp "ResourceSpecificationVersion"))) + (values `(begin + (define-module (aws cloudformation ,module-suffix) + #:use-module (aws cloudformation utils) + #:use-module (ice-9 match) + #:use-module (oop goops) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19)) + ,@(if version + `((define-public cloudformation-specification-version + ,version)) + '()) + ,@(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))) + (read port))) #:compilers `((scheme . ,compile-scheme)) #:printer write) |