(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)