(in-package #:cmamut)

; Ideas:
; Generate code that creates a package and puts all definitions there.
; To avoid collisions the created package shouldn't import any symbols.
; Only define functions from the target library, but get all other definitions.
; To reduce amount of names being generated, resolve all types to their base counterparts
; Separate generation, preprocessing and type resolution phases
; Preprocessing phase should handle enums, structs and unions
; Basic types are handled by type resolution phase
; Can put an error to default case in cook type to enforce type resolution

; TODO: Get constants from macro file generated by c2ffi -M
; TODO: Use c2ffi to extract the spec.json using the header file as parameter

(defvar enum-references (make-hash-table :test #'equal :size 256))

(defun get-spec ()
  (json:from-file "~/common-lisp/cmamut/spec.json"))

(defun cook-type (raw-type)
  (let ((tag (gethash "tag" raw-type)))
    (cond ((string= tag ":void")
           'sb-alien:void)
          ((string= tag ":function-pointer")
           'sb-alien:function)
          ((string= tag ":pointer")
           (let ((pointed-type (gethash "type" raw-type)))
             (cond ((string= (gethash "tag" pointed-type) ":char")
                    'sb-alien:c-string)
                   ((string= (gethash "tag" pointed-type) ":void")
                    (list 'sb-alien:* t))
                   (t (list 'sb-alien:* (cook-type pointed-type))))))
          ((string= tag ":float")
           'sb-alien:float)
          ((string= tag ":double")
           'sb-alien:double)
          ((string= tag ":unsigned-char")
           'sb-alien:unsigned-char)
          ((string= tag ":unsigned-short")
           'sb-alien:unsigned-short)
          ((string= tag ":unsigned-int")
           'sb-alien:unsigned-int)
          ((string= tag ":unsigned-long")
           'sb-alien:unsigned-long)
          ((or (string= tag ":char") (string= tag ":signed-char"))
           'sb-alien:char)
          ((or (string= tag ":short") (string= tag ":signed-short"))
           'sb-alien:short)
          ((or (string= tag ":int") (string= tag ":signed-int"))
           'sb-alien:int)
          ((or (string= tag ":long") (string= tag ":signed-long"))
           'sb-alien:long)
          ((string= tag ":array")
           (list 'sb-alien:array
                 (cook-type (gethash "type" raw-type))
                 (gethash "size" raw-type)))
          ((string= tag ":struct")
           (list 'sb-alien:struct (intern (gethash "name" raw-type))))
          ((string= tag ":union")
           (list 'sb-alien:union (intern (gethash "name" raw-type))))
          ((string= tag "struct")
           (cook-struct raw-type))
          ((string= tag "union")
           (cook-union raw-type))
          (t tag))))

(defun cook-function (raw-function &optional name-transformer)
  (let ((raw-params (gethash "parameters" raw-function))
        (cooked-params (queue:new)))
    (dotimes (j (length raw-params))
      (queue:add cooked-params
                 (list (intern (string-upcase (gethash "name" (aref raw-params j))))
                       (cook-type (gethash "type" (aref raw-params j))))))
    `(sb-alien:define-alien-routine
       ,(let ((function-name (gethash "name" raw-function)))
          (if name-transformer
            (list function-name (funcall name-transformer function-name))
            function-name))
       ,(cook-type (gethash "return-type" raw-function))
       ,@(queue:to-list cooked-params))))

(defun cook-typedef (raw-typedef)
  (let* ((base-type (gethash "type" raw-typedef))
         (new-name (gethash "name" raw-typedef)))
    (if (string= (gethash "tag" base-type) ":enum")
      (progn (setf (gethash (gethash "id" base-type) enum-references) new-name) nil)
      `(sb-alien:define-alien-type
         ,new-name
         ,(cook-type base-type)))))

(defun cook-struct (raw-struct)
  (let ((raw-fields (gethash "fields" raw-struct))
        (cooked-fields (queue:new)))
    (dotimes (j (length raw-fields))
      (queue:add cooked-fields
                 (list (intern (string-upcase (gethash "name" (aref raw-fields j))))
                       (cook-type (gethash "type" (aref raw-fields j))))))
    `(sb-alien:struct
       ,(when (> (length (gethash "name" raw-struct)) 0)
          (intern (gethash "name" raw-struct)))
       ,@(queue:to-list cooked-fields))))

(defun cook-union (raw-union)
  (let ((raw-fields (gethash "fields" raw-union))
        (cooked-fields (queue:new)))
    (dotimes (j (length raw-fields))
      (queue:add cooked-fields
                 (list (intern (string-upcase (gethash "name" (aref raw-fields j))))
                       (cook-type (gethash "type" (aref raw-fields j))))))
    `(sb-alien:union
       ,(when (> (length (gethash "name" raw-union)) 0)
          (intern (gethash "name" raw-union)))
       ,@(queue:to-list cooked-fields))))

(defun cook-enum (raw-enum)
  (let ((name (gethash (gethash "id" raw-enum) enum-references))
        (raw-fields (gethash "fields" raw-enum))
        (cooked-fields (queue:new)))
    (dotimes (j (length raw-fields))
      (queue:add cooked-fields
                 (list (intern (string-upcase (gethash "name" (aref raw-fields j))))
                       (gethash "value" (aref raw-fields j)))))
    `(sb-alien:define-alien-type
       ,name
       (sb-alien:enum
         nil
         ,@(queue:to-list cooked-fields)))))

(defun filter-base-types (raw-typedefs)
  (clrhash type-associations)
  (setf (gethash ":char" type-associations) t)
  (setf (gethash ":short" type-associations) t)
  (setf (gethash ":int" type-associations) t)
  (setf (gethash ":long" type-associations) t)
  (setf (gethash ":signed-char" type-associations) t)
  (setf (gethash ":signed-short" type-associations) t)
  (setf (gethash ":signed-int" type-associations) t)
  (setf (gethash ":signed-long" type-associations) t)
  (setf (gethash ":unsigned-char" type-associations) t)
  (setf (gethash ":unsigned-short" type-associations) t)
  (setf (gethash ":unsigned-int" type-associations) t)
  (setf (gethash ":unsigned-long" type-associations) t)
  (setf (gethash ":float" type-associations) t)
  (setf (gethash ":double" type-associations) t)
  (setf (gethash ":function-pointer" type-associations) t)
  (labels ((take-deps
             (deps)
             (let (remaining)
               (dolist (i deps)
                 (let ((tag (gethash "tag" (gethash "type" i))))
                   (if (gethash tag type-associations)
                     (setf (gethash (gethash "name" i) type-associations) tag)
                     (push i remaining))))
               (if (= (length deps) (length remaining))
                 remaining
                 (take-deps remaining)))))
    (let ((result (take-deps raw-typedefs)))
      (labels ((associate-base-type
                 (k v)
                 (let ((new-v (gethash v type-associations)))
                   (if (eq new-v t)
                     (setf (gethash k type-associations) v)
                     (associate-base-type k new-v)))))
        (maphash (lambda (k v)
                   (unless (eq v t)
                     (associate-base-type k v)))
                 type-associations))
      result)))

(defstruct spec
  functions
  typedefs
  structs
  unions
  enums)

(defun classify-definitions (spec)
  (let ((s (make-spec)))
    (dotimes (i (length spec))
      (let ((tag (gethash "tag" (aref spec i))))
        (cond ((string= tag "function")
               (push (aref spec i) (spec-functions s)))

              ((string= tag "typedef")
               (let ((internal-type (gethash "type" (aref spec i))))
                 (cond ((string= (gethash "tag" internal-type) "struct")
                        (when (string= (gethash "name" internal-type) "")
                          (setf (gethash "name" internal-type) (gethash "name" (aref spec i))))
                        (push (gethash "type" (aref spec i)) (spec-structs s))
                        (setf (gethash "type" (aref spec i))
                              (json:from-string
                                (format nil
                                        "{ \"tag\": \":struct\", \"name\": ~s }"
                                        (gethash "name" internal-type))))))
                 (push (aref spec i) (spec-typedefs s))))

              ((string= tag "struct")
               (push (aref spec i) (spec-structs s)))
              ((string= tag "enum")
               (push (aref spec i) (spec-enums s)))
              ((string= tag "union")
               (push (aref spec i) (spec-unions s)))
              (t))))
    s))

(defun codegen (spec)
  (clrhash enum-references)
  ; typedefs must be generated first to build the reference table
  (setf (spec-typedefs spec)
        (remove nil (mapcar #'cook-typedef (filter-base-types (spec-typedefs spec)))))
  (setf (spec-functions spec) (mapcar #'cook-function (spec-functions spec)))
  (setf (spec-enums spec) (mapcar #'cook-enum (spec-enums spec)))
  (setf (spec-structs spec)
        (mapcar (lambda (x)
                  `(sb-alien:define-alien-type nil ,(cook-struct x)))
                (spec-structs spec)))
  (setf (spec-unions spec)
        (mapcar (lambda (x)
                  `(sb-alien:define-alien-type nil ,(cook-union x)))
                (spec-unions spec)))
  spec)

(defun to-file (spec filename) 
  (with-open-file (f filename
                     :direction :output
                     :if-exists :supersede
                     :if-does-not-exist :create)
    (princ ";;; GENERATED BY CMAMUT" f)
    (terpri f)
    (let ((*print-length* nil)
          (*print-level* nil))
      (format f "~{~s~&~}" (spec-enums spec))
      (format f "~{~s~&~}" (spec-typedefs spec)))))
;(format f "~{~s~&~}" (spec-structs spec))
;(format f "~{~s~&~}" (spec-unions spec))
;(format f "~{~s~&~}" (spec-functions spec)))))