(in-package #:cmamut)

(defparameter +target-package+ (gensym))

(defun get-raw-spec (filename)
  (sb-ext:run-program "/usr/bin/c2ffi" (list filename
                                             "--macro-file" "defines.h"
                                             "--output" "spec.json"))
  (sb-ext:run-program "/usr/bin/c2ffi" '("defines.h"
                                         "--output" "defines.json"))
  (let ((spec (json:from-file "spec.json"))
        (defines (json:from-file "defines.json")))
    (delete-file "spec.json")
    (delete-file "defines.json")
    (delete-file "defines.h")
    (concatenate `(simple-vector ,(+ (length spec) (length defines))) spec defines)))

(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) +target-package+)))
          ((string= tag ":union")
           (list 'sb-alien:union (intern (gethash "name" raw-type) +target-package+)))
          ((string= tag ":enum")
           (list 'sb-alien:enum (gethash "name" raw-type)))
          ((or (string= tag "struct") (string= tag "union"))
           (cook-composite 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)
  (let ((raw-params (gethash "parameters" raw-function))
        (cooked-params (queue:new)))
    (dotimes (j (length raw-params))
      (queue:add cooked-params
                 (list (if (string= (gethash "name" (aref raw-params j)) "")
                         (gensym)
                         (intern (gethash "name" (aref raw-params j)) +target-package+))
                       (cook-type (gethash "type" (aref raw-params j)) type-associations))))
    `(sb-alien:define-alien-routine
       ,(let ((function-name (gethash "name" raw-function)))
          (list function-name (intern function-name +target-package+)))
       ,(cook-type (gethash "return-type" raw-function) type-associations)
       ,@(queue:to-list cooked-params))))

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

(defun cook-const (raw-const)
  `(defparameter
     ,(intern (gethash "name" raw-const) +target-package+)
     ,(gethash "value" raw-const)))

(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
                 `(defparameter
                    ,(intern (gethash "name" (aref raw-fields j)) +target-package+)
                    ,(gethash "value" (aref raw-fields j)))))
    `(progn
       ,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
  consts
  functions
  typedefs
  composite
  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)))

          ((and (string= tag "const") (gethash "value" def))
           (push def (spec-consts 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)))
                    (push internal-type (spec-composite 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 "enum")
           (push def (spec-enums spec)))

          ((or (string= tag "struct") (string= tag "union"))
           (push def (spec-composite spec)))))
  spec)

(defun gather-composite-dependencies (composite)
  (let ((names (make-hash-table)))
    (labels ((get-deps
               (def)
               (dolist (param (cddr def))
                 (let ((param-type (cadr param)))
                   (when (listp param-type)
                     (cond ((or (eql (car param-type) 'sb-alien:struct)
                                (eql (car param-type) 'sb-alien:union))
                            (setf (gethash (cadr param-type) names) t)
                            (get-deps param-type))
                           ((and (eql (car param-type) 'sb-alien:array)
                                 (listp (cadr param-type)))
                            (setf (gethash (caadr param-type) names) t)
                            (get-deps (cadr param-type)))))))))
      (get-deps composite))
    names))

(defun sort-composites-by-deps (composites)
  (let ((comps-and-deps (mapcar (lambda (x)
                                  (cons x (gather-composite-dependencies x)))
                                composites))
        (result nil))
    (labels ((filter-deps
               (cnd)
               (let ((new-cnd (remove-if (lambda (x) (= (hash-table-count (cdr x)) 0)) cnd)))
                 (if (= (length new-cnd) (length cnd))
                   result
                   (progn
                     (dolist (i cnd)
                       (when (= (hash-table-count (cdr i)) 0)
                         (push (car i) result)
                         (dolist (j new-cnd)
                           (remhash (second (car i)) (cdr j)))))
                     (filter-deps new-cnd))))))
      (filter-deps comps-and-deps))
    (reverse result)))

(defun codegen (spec function-filter)
  (let ((enum-references (generate-enum-references (spec-typedefs spec)))
        (type-associations (generate-type-associations (spec-typedefs spec))))
    (let ((consts (mapcar #'cook-const (spec-consts spec)))
          (enums (mapcar (lambda (x) (cook-enum x enum-references))
                         (spec-enums spec)))
          (composite (mapcar (lambda (x) `(sb-alien:define-alien-type ,(cadr x) ,x))
                             (sort-composites-by-deps
                               (mapcar (lambda (x) (cook-composite x type-associations))
                                       (spec-composite spec)))))
          (functions (mapcar (lambda (x) (cook-function x type-associations))
                             (if function-filter
                               (remove-if-not function-filter (spec-functions spec))
                               (spec-functions spec)))))
      (remove-duplicates (concatenate 'list consts enums composite 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)
          (*print-pretty* nil)
          (*package* (find-package +target-package+)))
      (format f "~{~s~&~}" code))))

(defun file-name (path)
  (subseq path
          (1+ (or (position #\/ path :from-end t) -1))
          (position #\. path)))

(defun run (input &optional function-filter)
  (when (not (find-package +target-package+))
    (make-package +target-package+))
  (let* ((raw-spec (get-raw-spec input))
         (spec (classify-definitions raw-spec))
         (code (codegen spec function-filter)))
    (to-file code (concatenate 'string (file-name input) ".lisp")))
  (delete-package (find-package +target-package+)))