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

; TODO: Get constants from macro file generated by c2ffi -M

; TODO: Use c2ffi to extract the spec.json using the header file as parameter
(defun get-raw-spec (filename)
  (json:from-file filename))

(defun cook-type (raw-type type-associations)
  (let ((tag (gethash "tag" raw-type)))
    (cond ((string= tag ":void")
           'sb-alien:void)
          ((string= tag ":function-pointer")
           (list 'sb-alien:* t))
          ((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 type-associations))))))
          ((string= tag ":float")
           'sb-alien:float)
          ((or (string= tag ":double") (string= tag ":long-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 ":unsigned-long-long")
           'sb-alien:unsigned-long-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") (char= (char tag 0) #\<))
           'sb-alien:int)
          ((or (string= tag ":long") (string= tag ":signed-long"))
           'sb-alien:long)
          ((or (string= tag ":long-long") (string= tag ":signed-long-long"))
           'sb-alien:long-long)
          ((string= tag ":array")
           (list 'sb-alien:array
                 (cook-type (gethash "type" raw-type) type-associations)
                 (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 ":enum")
           (list 'sb-alien:enum (gethash "name" raw-type)))
          ((string= tag "struct")
           (cook-struct raw-type type-associations))
          ((string= tag "union")
           (cook-union raw-type type-associations))
          ((string= tag "__builtin_va_list")
           (list 'sb-alien:* t))
          (t (let ((new-type (gethash tag type-associations)))
               (if new-type
                 (cook-type new-type type-associations)
                 (error "Unknown type: ~a" tag)))))))

(defun cook-function (raw-function type-associations &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 (gethash "name" (aref raw-params j)))
                       (cook-type (gethash "type" (aref raw-params j)) type-associations))))
    `(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) type-associations)
       ,@(queue:to-list cooked-params))))

(defun cook-struct (raw-struct type-associations)
  (let ((raw-fields (gethash "fields" raw-struct))
        (cooked-fields (queue:new)))
    (dotimes (j (length raw-fields))
      (queue:add cooked-fields
                 (list (intern (gethash "name" (aref raw-fields j)))
                       (cook-type (gethash "type" (aref raw-fields j)) type-associations))))
    `(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 type-associations)
  (let ((raw-fields (gethash "fields" raw-union))
        (cooked-fields (queue:new)))
    (dotimes (j (length raw-fields))
      (queue:add cooked-fields
                 (list (intern (gethash "name" (aref raw-fields j)))
                       (cook-type (gethash "type" (aref raw-fields j)) type-associations))))
    `(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 enum-references)
  (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 (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)))))

(defun generate-enum-references (raw-typedefs)
  (let ((enum-references (make-hash-table :test #'equal :size 256)))
    (dolist (i raw-typedefs)
      (let ((base-type (gethash "type" i)))
        (when (string= (gethash "tag" base-type) ":enum")
          (setf (gethash (gethash "id" base-type) enum-references)
                (gethash "name" i)))))
    enum-references))

; Typedefs get "flattened" so that resolving is just a lookup.
(defun generate-type-associations (raw-typedefs)
  (let ((type-associations (make-hash-table :test #'equal :size 256)))
    (dolist (i raw-typedefs)
      (when (string= (gethash "tag" (gethash "type" i)) ":enum")
        (setf (gethash "name" (gethash "type" i)) (gethash "name" i)))
      (setf (gethash (gethash "name" i) type-associations) (gethash "type" i)))
    (labels ((flatten-typedef
               (k v)
               (let ((new-v (gethash (gethash "tag" v) type-associations)))
                 (when new-v
                   (setf (gethash k type-associations) new-v)
                   (flatten-typedef k new-v)))))
      (maphash #'flatten-typedef type-associations))
    type-associations))

(defstruct spec
  functions
  typedefs
  structs
  unions
  enums)

; This is done so we can separate definition types into stages when generating code.
; Some crazy shit is happening when processing typedefs so we can identify nested composite types and put them into the right buckets.
; What's left on the typedefs are references to said composite types.
; This allows for a comfier type resolution stage by letting us flatten typedefs.
; Composite types cause problems because they can't be redefined.
(defun classify-definitions (raw-spec)
  (let ((spec (make-spec)))
    (dotimes (i (length raw-spec))
      (classify-definition (aref raw-spec i) spec))
    spec))

(defun classify-definition (def spec)
  (let ((tag (gethash "tag" def)))
    (cond ((string= tag "function")
           (push def (spec-functions spec)))

          ((or (string= tag "typedef")
               (string= tag ":array")
               (string= tag ":pointer"))
           (let* ((internal-type (gethash "type" def))
                  (internal-tag (gethash "tag" internal-type)))
             (cond ((or (string= internal-tag "struct")
                        (string= internal-tag "union"))
                    (when (string= (gethash "name" internal-type) "")
                      (setf (gethash "name" internal-type) (gethash "name" def)))
                    (classify-definition internal-type spec)
                    (setf (gethash "type" def)
                          (json:obj ("tag" (gethash "tag" internal-type))
                                    ("name" (gethash "name" internal-type)))))
                   ((or (string= internal-tag ":array")
                        (string= internal-tag ":pointer"))
                    (classify-definition internal-type spec)))
             (when (string= tag "typedef")
               (push def (spec-typedefs spec)))))

          ((string= tag "struct")
           (push def (spec-structs spec)))
          ((string= tag "enum")
           (push def (spec-enums spec)))
          ((string= tag "union")
           (push def (spec-unions spec)))))
  spec)

(defun codegen (spec)
  (let ((enum-references (generate-enum-references (spec-typedefs spec)))
        (type-associations (generate-type-associations (spec-typedefs spec))))
    (let ((enums (mapcar (lambda (x) (cook-enum x enum-references))
                         (spec-enums spec)))
          (structs (mapcar (lambda (x)
                             `(sb-alien:define-alien-type nil ,(cook-struct x type-associations)))
                           (spec-structs spec)))
          (unions (mapcar (lambda (x)
                            `(sb-alien:define-alien-type nil ,(cook-union x type-associations)))
                          (spec-unions spec)))
          (functions (mapcar (lambda (x) (cook-function x type-associations))
                             (spec-functions spec))))
      (remove-duplicates (concatenate 'list enums structs unions functions) :test #'equal))))

(defun to-file (code filename)
  (with-open-file (f filename
                     :direction :output
                     :if-exists :supersede
                     :if-does-not-exist :create)
    (let ((*print-length* nil)
          (*print-level* nil))
      (format f "~{~s~&~}" code))))

(defun run (input output)
  (let* ((raw-spec (get-raw-spec input))
         (spec (classify-definitions raw-spec))
         (code (codegen spec)))
    (to-file code output)))