summaryrefslogtreecommitdiff
path: root/language/cloudformation
diff options
context:
space:
mode:
Diffstat (limited to 'language/cloudformation')
-rw-r--r--language/cloudformation/spec.scm311
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)