(in-package #:cmamut)

; Ideas:
; Generate code that creates a package and puts all definitions there.
; If symbol names are unaltered we can skip connecting everything together.
; To avoid collisions the created package shouldn't import any symbols.
; Maybe use straight defuns and ffi functions to get as close as possible to the C names without much work.
; Only define functions from the target library, but get all other definitions.

; 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 reference-table (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)))
             (if (string= (gethash "tag" pointed-type) ":char")
               'sb-alien:c-string
               (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)
          ((string= tag ":char")
           'sb-alien:char)
          ((string= tag ":short")
           'sb-alien:short)
          ((string= tag ":int")
           'sb-alien:int)
          ((string= tag ":long")
           'sb-alien:long)
          ((string= tag ":struct")
           (list 'sb-alien:struct (gethash "name" raw-type)))
          ((string= tag ":union")
           (list 'sb-alien:union (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))
         (enum? (string= (gethash "tag" base-type) ":enum")))
    (when enum?
      (setf (gethash (gethash "id" base-type) reference-table)
            new-name))
    `(sb-alien:define-alien-type
       ,new-name
       ,(if enum?
          `(sb-alien:enum ,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
       ,(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
       ,(gethash "name" raw-union)
       ,@(queue:to-list cooked-fields))))

(defun cook-enum (raw-enum)
  (let ((name (gethash (gethash "id" raw-enum) reference-table))
        (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
       nil
       (sb-alien:enum
         ,name
         ,@(queue:to-list cooked-fields)))))

(defstruct spec
  functions
  typedefs
  structs
  unions
  enums)

(defun prepare-spec (spec)
  (clrhash reference-table)
  (let ((s (make-spec)))
    (dotimes (i (length spec))
      (cond ((string= (gethash "tag" (aref spec i)) "function")
             (push (aref spec i) (spec-functions s)))
            ((string= (gethash "tag" (aref spec i)) "typedef")
             (push (aref spec i) (spec-typedefs s)))
            ((string= (gethash "tag" (aref spec i)) "struct")
             (push (aref spec i) (spec-structs s)))
            ((string= (gethash "tag" (aref spec i)) "enum")
             (push (aref spec i) (spec-enums s)))
            ((string= (gethash "tag" (aref spec i)) "union")
             (push (aref spec i) (spec-unions s)))
            (t)))
; typedefs must be generated first to build the reference table
    (setf (spec-typedefs s) (mapcar #'cook-typedef (spec-typedefs s)))
    (setf (spec-functions s) (mapcar #'cook-function (spec-functions s)))
    (setf (spec-enums s) (mapcar #'cook-enum (spec-enums s)))
    (setf (spec-structs s)
          (mapcar (lambda (x)
                    `(sb-alien:define-alien-type nil ,(cook-struct x)))
                  (spec-structs s)))
    (setf (spec-unions s)
          (mapcar (lambda (x)
                    `(sb-alien:define-alien-type nil ,(cook-union x)))
                  (spec-unions s)))
    s))

(defun to-file (spec filename) 
  (with-open-file (f filename
                     :direction :output
                     :if-exists :overwrite
                     :if-does-not-exist :create)
; definitions must be written in the following order to avoid "unknown type" errors
    (princ ";;; GENERATED BY CMAMUT" f)
    (terpri f)
    (format f "~{~s~&~}" (spec-typedefs spec))
    (format f "~{~s~&~}" (spec-enums spec))
    (format f "~{~s~&~}" (spec-structs spec))
    (format f "~{~s~&~}" (spec-unions spec))
    (format f "~{~s~&~}" (spec-functions spec))))