;;; 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 (language cloudformation spec)
  #: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)
  #:use-module (system base language)
  #:export (cloudformation))

(define (property-type-name? name)
  (number? (string-index name #\.)))

(define (classify sym)
  "Add < and > around SYM to form a conventional class name."
  (symbol-append '< sym '>))

(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 (strip-namespace name)))
            (class-name (classify sym)))
       `(begin
          (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
                  ;; Export all slot getter methods.
                  ,@(map (match-lambda
                           ((pname . _)
                            (aws-string->symbol pname)))
                         (assoc-ref spec "Properties"))))))))

(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
                  (strip-namespace name)))
            (class-name (classify sym)))
       `(begin
          (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 . _)
                            (aws-string->symbol aws-name)))
                         (assoc-ref spec "Properties"))))))))

(define (compile-scheme exp env opts)
  (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 base)
                 #: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 port)))
  #:compilers `((scheme . ,compile-scheme))
  #:printer write)