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