(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

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

; TODO: Use c2ffi to extract the spec.json using the header file as parameter
(defun get-raw-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)))) ;TODO: Add type resolution

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

; If the enum table population gets done at an earlier stage and all typedefs get flattened, there would be no need of having codegen for typedefs.
(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)))))

; Generates a table for type resolution.
; Typedefs get "flattened" so that resolving is just a lookup.
(defun flatten-typedefs (raw-typedefs)
  (let ((type-associations (make-hash-table :test #'equal :size 256)))
    (dolist (i raw-typedefs)
      (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:from-string
                            (format nil
                                    "{ \"tag\": \":~a\", \"name\": ~s }"
                                    (gethash "tag" internal-type)
                                    (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)
  (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-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)))
  (setf (spec-functions spec) (mapcar #'cook-function (spec-functions spec)))
  spec)

(defun to-json-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 "~{~a~&~}" (mapcar #'json:to-string code)))))

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