Refactor.

2 files changed, 222 insertions, 202 deletions

diff --git a/aws/cloudformation/base.scm b/aws/cloudformation/base.scm
new file mode 100644
index 0000000..76c073d
--- /dev/null
+++ b/aws/cloudformation/base.scm
@@ -0,0 +1,220 @@
+;;; guile-cloudformation --- Scheme DSL for CloudFormation templates
+;;; Copyright © 2018 David Thompson <davet@gnu.org>
+;;;
+;;; Guile-CloudFormation is free software: you can redistribute it
+;;; and/or modify it under the terms of the GNU General Public License
+;;; as published by the Free Software Foundation, either version 3 of
+;;; the License, or (at your option) any later version.
+;;;
+;;; Guile-CloudFormation is distributed in the hope that it will be
+;;; useful, but WITHOUT ANY WARRANTY; without even the implied
+;;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+;;; See the GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (aws cloudformation base)
+  #:use-module (aws cloudformation utils)
+  #:use-module (ice-9 match)
+  #:use-module (oop goops)
+  #:use-module (srfi srfi-1)
+  #:export (<cloudformation-property>
+            <cloudformation-object>
+            <cloudformation-attribute>
+            <cloudformation-resource>
+            <cloudformation-stack>
+            attributes
+            description
+            documentation-url
+            id
+            name
+            outputs
+            parameters
+            primitive-type
+            properties
+            required?
+            resource-name
+            resources
+            to-json
+            type-check
+            type-checker
+            update-type
+            valid?))
+
+(define-class <cloudformation-property> ()
+  (name #:getter name #:init-keyword #:name)
+  (type-checker #:getter type-checker #:init-keyword #:type-checker)
+  (required? #:getter required? #:init-keyword #:required?)
+  (update-type #:getter update-type #:init-keyword #:update-type)
+  (documentation-url #:getter documentation-url
+                     #:init-keyword #:documentation-url))
+
+(define-method (type-check (procedure <procedure>) x)
+  (procedure x))
+
+(define-method (type-check (property <cloudformation-property>) x)
+  ((type-checker property) x))
+
+(define-class <cloudformation-class> (<class>)
+  (properties #:getter properties)
+  (cfn-name #:getter cfn-name)
+  (documentation-url #:getter documentation-url))
+
+(define-method (initialize (cfn-class <cloudformation-class>) args)
+  (define* (slot-cfn-property slot-name #:key cfn-property #:allow-other-keys)
+    (and cfn-property (cons slot-name cfn-property)))
+  (define* (init #:key cfn-name documentation-url slots #:allow-other-keys)
+    (slot-set! cfn-class 'cfn-name cfn-name)
+    (slot-set! cfn-class 'documentation-url documentation-url)
+    (slot-set! cfn-class
+               'properties
+               (filter-map (lambda (slot-args)
+                             (apply slot-cfn-property slot-args))
+                           slots)))
+  (apply init args)
+  (next-method))
+
+(define-class <cloudformation-object> ()
+  #:metaclass <cloudformation-class>)
+
+(define-method (initialize (obj <cloudformation-object>) args)
+  (next-method)
+  ;; Ensure that all required properties have been specified, and that
+  ;; all specified properties pass the type checker.
+  (for-each (match-lambda
+              ((slot-name . prop)
+               (cond
+                ((and (required? prop) (not (slot-bound? obj slot-name)))
+                 (error "required property not specified:" slot-name))
+                ((slot-bound? obj slot-name)
+                 (let ((value (slot-ref obj slot-name)))
+                   (unless (type-check prop value)
+                     (error "wrong type for property:" slot-name value)))))))
+            (slot-ref (class-of obj) 'properties)))
+
+(define-method (cfn-name (obj <cloudformation-object>))
+  (cfn-name (class-of obj)))
+
+(define-method (properties (obj <cloudformation-object>))
+  (slot-ref (class-of obj) 'properties))
+
+(define-method (to-json/refs obj)
+  (to-json obj))
+
+(define-method (to-json (s <string>)) s)
+(define-method (to-json (b <boolean>)) b)
+(define-method (to-json (n <number>)) n)
+(define-method (to-json (p <pair>))
+  (if (pair? (car p))
+      `(@ ,@(map (match-lambda
+                   ((k . v)
+                    (cons k (to-json/refs v))))
+                 p))
+      (cons (to-json/refs (car p)) (to-json (cdr p)))))
+(define-method (to-json (null <null>))
+  '())
+
+(define-method (to-json (obj <cloudformation-object>))
+  (cons '@
+   (filter-map (match-lambda
+                 ((slot-name . property)
+                  (and (slot-bound? obj slot-name)
+                       (cons (name property)
+                             (to-json/refs (slot-ref obj slot-name))))))
+               (properties obj))))
+
+(define-method (valid? (obj <cloudformation-object>))
+  (every (match-lambda
+           ((slot-name . property)
+            (cond
+             ((and (required? property) (not (slot-bound? obj slot-name)))
+              #f)
+             ((not (or (required? property) (slot-bound? obj slot-name)))
+              #t)
+             (else
+              (type-check property (slot-ref obj slot-name))))))
+         (slot-ref (class-of obj) 'properties)))
+
+(define-class <cloudformation-attribute> ()
+  (name #:getter name #:init-keyword #:name)
+  (primitive-type #:getter primitive-type #:init-keyword #:primitive-type))
+
+(define-class <cloudformation-resource-class> (<cloudformation-class>)
+  (resource-name-prefix #:getter resource-name-prefix)
+  (attributes #:getter attributes))
+
+(define-method (initialize (resource-class <cloudformation-resource-class>) args)
+  (define* (init #:key attributes cfn-name #:allow-other-keys)
+    (when cfn-name
+      (slot-set! resource-class 'resource-name-prefix
+                 (string-concatenate
+                  (drop (delete "" (string-split cfn-name #\:)) 1))))
+    (slot-set! resource-class 'attributes attributes))
+  (apply init args)
+  (next-method))
+
+(define-class <cloudformation-resource> (<cloudformation-object>)
+  (id #:getter id #:init-keyword #:id)
+  (cfn-id #:getter cfn-id)
+  #:metaclass <cloudformation-resource-class>)
+
+(define-method (initialize (resource <cloudformation-resource>) args)
+  (next-method)
+  (unless (slot-bound? resource 'id)
+    (error "no id specified for resource:" resource))
+  (slot-set! resource 'cfn-id (id->cfn-id (id resource))))
+
+(define-method (type-check (proc <procedure>)
+                           (resource <cloudformation-resource>))
+  (type-check proc "arn:dummy"))
+
+(define-method (to-json/refs (resource <cloudformation-resource>))
+  `(@ ("Ref" . ,(cfn-id resource))))
+
+(define-method (to-json (resource <cloudformation-resource>))
+  `(@ ("Type" . ,(cfn-name resource))
+      ("Properties" . ,(next-method))))
+
+(define-class <cloudformation-stack> ()
+  (description #:getter description #:init-keyword #:description #:init-form "")
+  (parameters #:getter parameters #:init-keyword #:parameters)
+  (resources #:getter resources #:init-keyword #:resources)
+  (outputs #:getter outputs #:init-keyword #:outputs))
+
+(define-method (transitive-resources (stack <cloudformation-stack>))
+  (define (scan-object obj)
+    (cond
+     ((is-a? obj <pair>)
+      (match obj
+        ((first rest ...)
+         (concatenate (cons (scan-object first)
+                            (scan-object rest))))
+        ((key . value)
+         (scan-object value))))
+     ((is-a? obj <cloudformation-resource>)
+      (list obj))
+     ((is-a? obj <cloudformation-object>)
+      (scan-properties obj))
+     (else
+      '())))
+  (define (scan-properties obj)
+    (append-map (match-lambda
+                  ((slot-name . prop)
+                   (let ((value (and (slot-bound? obj slot-name)
+                                     (slot-ref obj slot-name))))
+                     (scan-object value))))
+                (properties obj)))
+  (append-map (lambda (resource)
+                (cons resource (scan-properties resource)))
+              (resources stack)))
+
+(define-method (to-json (stack <cloudformation-stack>))
+  `(@ ("AWSTemplateFormatVersion" . "2010-09-09")
+      ("Description" . ,(description stack))
+      ("Resources" .
+       (@ ,@(map (lambda (resource)
+                   (cons (cfn-id resource)
+                         (to-json resource)))
+                 (transitive-resources stack))))))
diff --git a/aws/cloudformation/utils.scm b/aws/cloudformation/utils.scm
index 8aea303..2bb32d8 100644
--- a/aws/cloudformation/utils.scm
+++ b/aws/cloudformation/utils.scm
@@ -18,33 +18,9 @@
 (define-module (aws cloudformation utils)
   #:use-module (aws cloudformation utils base32)
   #:use-module (aws cloudformation utils sha-1)
-  #:use-module (ice-9 match)
-  #:use-module (oop goops)
   #:use-module (rnrs bytevectors)
-  #:use-module (srfi srfi-1)
-  #:export (<cloudformation-property>
-            <cloudformation-object>
-            <cloudformation-attribute>
-            <cloudformation-resource>
-            <cloudformation-stack>
-            attributes
-            aws-string->symbol
-            description
-            documentation-url
-            id
-            name
-            outputs
-            parameters
-            primitive-type
-            properties
-            required?
-            resource-name
-            resources
-            to-json
-            type-check
-            type-checker
-            update-type
-            valid?))
+  #:export (aws-string->symbol
+            id->cfn-id))
 
 (define (aws-string->symbol str)
   ;; Drop the "AWS::" that's at the beginning of *almost* everything.
@@ -96,123 +72,6 @@
         (else
          (cons (string-ref str i) (loop (1+ i) #f #f))))))))
 
-(define-class <cloudformation-property> ()
-  (name #:getter name #:init-keyword #:name)
-  (type-checker #:getter type-checker #:init-keyword #:type-checker)
-  (required? #:getter required? #:init-keyword #:required?)
-  (update-type #:getter update-type #:init-keyword #:update-type)
-  (documentation-url #:getter documentation-url
-                     #:init-keyword #:documentation-url))
-
-(define-method (type-check (procedure <procedure>) x)
-  (procedure x))
-
-(define-method (type-check (property <cloudformation-property>) x)
-  ((type-checker property) x))
-
-(define-class <cloudformation-class> (<class>)
-  (properties #:getter properties)
-  (cfn-name #:getter cfn-name)
-  (documentation-url #:getter documentation-url))
-
-(define-method (initialize (cfn-class <cloudformation-class>) args)
-  (define* (slot-cfn-property slot-name #:key cfn-property #:allow-other-keys)
-    (and cfn-property (cons slot-name cfn-property)))
-  (define* (init #:key cfn-name documentation-url slots #:allow-other-keys)
-    (slot-set! cfn-class 'cfn-name cfn-name)
-    (slot-set! cfn-class 'documentation-url documentation-url)
-    (slot-set! cfn-class
-               'properties
-               (filter-map (lambda (slot-args)
-                             (apply slot-cfn-property slot-args))
-                           slots)))
-  (apply init args)
-  (next-method))
-
-(define-class <cloudformation-object> ()
-  #:metaclass <cloudformation-class>)
-
-(define-method (initialize (obj <cloudformation-object>) args)
-  (next-method)
-  ;; Ensure that all required properties have been specified, and that
-  ;; all specified properties pass the type checker.
-  (for-each (match-lambda
-              ((slot-name . prop)
-               (cond
-                ((and (required? prop) (not (slot-bound? obj slot-name)))
-                 (error "required property not specified:" slot-name))
-                ((slot-bound? obj slot-name)
-                 (let ((value (slot-ref obj slot-name)))
-                   (unless (type-check prop value)
-                     (error "wrong type for property:" slot-name value)))))))
-            (slot-ref (class-of obj) 'properties)))
-
-(define-method (cfn-name (obj <cloudformation-object>))
-  (cfn-name (class-of obj)))
-
-(define-method (properties (obj <cloudformation-object>))
-  (slot-ref (class-of obj) 'properties))
-
-(define-method (to-json/refs obj)
-  (to-json obj))
-
-(define-method (to-json (s <string>)) s)
-(define-method (to-json (b <boolean>)) b)
-(define-method (to-json (n <number>)) n)
-(define-method (to-json (p <pair>))
-  (if (pair? (car p))
-      `(@ ,@(map (match-lambda
-                   ((k . v)
-                    (cons k (to-json/refs v))))
-                 p))
-      (cons (to-json/refs (car p)) (to-json (cdr p)))))
-(define-method (to-json (null <null>))
-  '())
-
-(define-method (to-json (obj <cloudformation-object>))
-  (cons '@
-   (filter-map (match-lambda
-                 ((slot-name . property)
-                  (and (slot-bound? obj slot-name)
-                       (cons (name property)
-                             (to-json/refs (slot-ref obj slot-name))))))
-               (properties obj))))
-
-(define-method (valid? (obj <cloudformation-object>))
-  (every (match-lambda
-           ((slot-name . property)
-            (cond
-             ((and (required? property) (not (slot-bound? obj slot-name)))
-              #f)
-             ((not (or (required? property) (slot-bound? obj slot-name)))
-              #t)
-             (else
-              (type-check property (slot-ref obj slot-name))))))
-         (slot-ref (class-of obj) 'properties)))
-
-(define-class <cloudformation-attribute> ()
-  (name #:getter name #:init-keyword #:name)
-  (primitive-type #:getter primitive-type #:init-keyword #:primitive-type))
-
-(define-class <cloudformation-resource-class> (<cloudformation-class>)
-  (resource-name-prefix #:getter resource-name-prefix)
-  (attributes #:getter attributes))
-
-(define-method (initialize (resource-class <cloudformation-resource-class>) args)
-  (define* (init #:key attributes cfn-name #:allow-other-keys)
-    (when cfn-name
-      (slot-set! resource-class 'resource-name-prefix
-                 (string-join (drop (delete "" (string-split cfn-name #\:)) 1)
-                              "")))
-    (slot-set! resource-class 'attributes attributes))
-  (apply init args)
-  (next-method))
-
-(define-class <cloudformation-resource> (<cloudformation-object>)
-  (id #:getter id #:init-keyword #:id)
-  (cfn-id #:getter cfn-id)
-  #:metaclass <cloudformation-resource-class>)
-
 (define char-set:alphanumeric
   (char-set-intersection char-set:ascii char-set:letter+digit))
 
@@ -233,62 +92,3 @@
                    (sha-1
                     (string->utf8
                      (symbol->string sym)))))))
-
-(define-method (initialize (resource <cloudformation-resource>) args)
-  (next-method)
-  (unless (slot-bound? resource 'id)
-    (error "no id specified for resource:" resource))
-  (slot-set! resource 'cfn-id (id->cfn-id (id resource))))
-
-(define-method (type-check (proc <procedure>)
-                           (resource <cloudformation-resource>))
-  (type-check proc "arn:dummy"))
-
-(define-method (to-json/refs (resource <cloudformation-resource>))
-  `(@ ("Ref" . ,(cfn-id resource))))
-
-(define-method (to-json (resource <cloudformation-resource>))
-  `(@ ("Type" . ,(cfn-name resource))
-      ("Properties" . ,(next-method))))
-
-(define-class <cloudformation-stack> ()
-  (description #:getter description #:init-keyword #:description #:init-form "")
-  (parameters #:getter parameters #:init-keyword #:parameters)
-  (resources #:getter resources #:init-keyword #:resources)
-  (outputs #:getter outputs #:init-keyword #:outputs))
-
-(define-method (transitive-resources (stack <cloudformation-stack>))
-  (define (scan-object obj)
-    (cond
-     ((is-a? obj <pair>)
-      (match obj
-        ((first rest ...)
-         (concatenate (cons (scan-object first)
-                            (scan-object rest))))
-        ((key . value)
-         (scan-object value))))
-     ((is-a? obj <cloudformation-resource>)
-      (list obj))
-     ((is-a? obj <cloudformation-object>)
-      (scan-properties obj))
-     (else
-      '())))
-  (define (scan-properties obj)
-    (append-map (match-lambda
-                  ((slot-name . prop)
-                   (let ((value (and (slot-bound? obj slot-name)
-                                     (slot-ref obj slot-name))))
-                     (scan-object value))))
-                (properties obj)))
-  (append-map (lambda (resource)
-                (cons resource (scan-properties resource)))
-              (resources stack)))
-
-(define-method (to-json (stack <cloudformation-stack>))
-  `(@ ("AWSTemplateFormatVersion" . "2010-09-09")
-      ("Description" . ,(description stack))
-      ("Resources" .
-       (@ ,@(map (lambda (resource)
-                   (cons (cfn-id resource)
-                         (to-json resource)))
-                 (transitive-resources stack))))))