Add language spec.

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)