(in-package :objc-runtime)

 (serapeum:eval-always
  (named-readtables:in-readtable :objc-readtable))

 
 (serapeum:eval-always
   (cffi:define-foreign-library cocoa
     (:darwin (:framework "Cocoa")))

   (cffi:define-foreign-library foundation

     (:darwin (:framework "Foundation")))

   (cffi:define-foreign-library appkit
     (:darwin (:framework "AppKit"))))

 
 (use-foreign-library foundation)
 (use-foreign-library cocoa)
 (use-foreign-library appkit)
 
 (defctype o-class :pointer)
 (defctype o-selector :pointer)
 
 (defcfun (objc-look-up-class "objc_lookUpClass" :library foundation)
     o-class
   (name :string))
 
 (defcfun (objc-allocate-class-pair "objc_allocateClassPair" :library foundation)
     :pointer
   (superclass :pointer)
   (name :string)
   (extra-bytes :int))
 

 (defcfun (objc-register-class-pair "objc_registerClassPair" :library foundation)
     :void
   (superclass :pointer))
 

 (defcfun (objc-get-protocol "objc_getProtocol" :library foundation)
     :pointer
   (name :string))
 
 (defcfun (class-add-protocol "class_addProtocol" :library foundation)
     :boolean
   (class :pointer)
   (protocol :pointer))
 

 (serapeum:eval-always
   (defctype sizet
       :ulong

     #+32-bit-target :uint))

 
 (defcfun (class-add-ivar "class_addIvar" :library foundation)
     :boolean
   (class :pointer)
   (name :string)
   (size :ulong)
   (alignment :uint8)
   (types :string))
 
 (defun add-pointer-ivar (class name)
   (class-add-ivar class name
                   (foreign-type-size :pointer)
                   (floor (log (foreign-type-size :pointer)
                               2))
                   "@"))
 

 
 #+nil
 (defun make-app-delegate-class (outlets)
   (let ((app-delegate-class (objc-runtime::objc-allocate-class-pair
                              #@NSObject "AppDelegate" 0)))
     (objc-runtime:add-pointer-ivar app-delegate-class "window")
     (objc-runtime:add-pointer-ivar app-delegate-class "delegate")
 
     (loop for outlet in outlets do

       (objc-runtime:add-pointer-ivar app-delegate-class outlet))

 
     app-delegate-class))
 

 #+(or)

 (defun %setup-objc-class (name base ivars)
   (let ((class-pair (objc-allocate-class-pair base name 0)))
     (loop for ivar in ivars

           )))

 (defcfun (objc-class-get-name "class_getName" :library foundation)
     :string
   (cls o-class))
 
 (defcfun (objc-class-get-superclass "class_getSuperclass" :library foundation)
     :pointer
   (cls o-class))
 
 (defcfun (objc-get-class-list "objc_getClassList" :library foundation)
     :int
   (cls-buffer o-class)
   (buffer-count :int))
 
 (defcfun (sel-register-name "sel_registerName" :library foundation)
     o-selector
   (name :string))
 

 (defmacro safe-objc-msg-send (result-type thing selector &rest args)
   (alexandria:once-only (thing selector)
     `(if [,thing @(respondsToSelector:) :pointer ,selector]b
          ,(ccase result-type

             (:string `[,thing ,selector ,@args]s)
             (:nsstring `[,thing ,selector ,@args]@)
             (:pointer `[,thing ,selector ,@args])
             (:int `[,thing ,selector ,@args]#)
             (:bool `[,thing ,selector ,@args]b))

          (error "invalid selector"))))
 

 ;;; This is a macro, because objc-msg-send is a macro.... which makes "apply" impossible
 ;;; \o/
 (defmacro objc-msg-send-nsstring (thing selector &rest args)
   `[[,thing ,selector ,@args] @(UTF8String)]s)

 (defmacro objc-msg-send-bool (thing selector &rest args)
   `(= 1 [,thing ,selector ,@args]#))
 

 (defcfun (class-copy-method-list "class_copyMethodList" :library foundation)
     :pointer
   (cls o-class)
   (numMethods (:pointer :int)))
 
 (defcfun (method-get-name "method_getName")

     :string

   (method :pointer))
 

 (defcfun (method-get-type-encoding "method_getTypeEncoding")
     :string
   (method :pointer))
 

 (defcfun (sel-get-name "sel_getName")
     :string
   (sel o-selector))
 

 (defcfun (class-get-instance-variable "class_getInstanceVariable" :library foundation)
     :pointer
   (cls o-class)
   (name :string))
 

 (defcfun (class-add-method "class_addMethod" :library foundation)
     :boolean
   (class :pointer)
   (selector :pointer)
   (cb :pointer)

   (type :string))
 

 (defcfun (object-get-class "object_getClass" :library foundation)
     :pointer
   (object :pointer))
 
 (defcfun (object-get-ivar "object_getIvar" :library foundation)
     :pointer
   (object :pointer)
   (ivar :pointer))
 

 (defcfun (object-get-instance-variable "object_getInstanceVariable" :library foundation)
     :pointer
   (object :pointer)
   (name :string)
   (out :pointer))
 

 (defcfun (class-get-property "class_getProperty" :library foundation)
     :pointer
   (cls o-class)
   (name :string))
 

 (defcstruct objc-property-attribute-t
   (name :string)
   (value :string))
 
 (defcfun (class-add-property "class_addProperty" :library foundation)
     :pointer
   (cls o-class)
   (name :string)
   (attributes (:pointer (:struct objc-property-attribute-t)))
   (attribute-count :unsigned-int))
 

 (defcfun (property-copy-attribute-value "property_copyAttributeValue" :library foundation)
     :string
   (prop :pointer)
   (name :string))
 
 
 (defcfun (property-get-attributes "property_getAttributes" :library foundation)
     :string
   (prop :pointer))
 

 (defun get-classes ()

   (let ((num-classes (objc-get-class-list (null-pointer) 0))
         (result (list)))

     (with-foreign-object (classes :pointer num-classes)

       (dotimes (n (objc-get-class-list classes num-classes) (nreverse result))

         (push (mem-aref classes :pointer n)

               result)))))

 (defgeneric get-methods (class)
   (:method ((class string))
     (get-methods (objc-look-up-class class)))

 
   #+ccl
   (:method ((class ccl:macptr))
     (with-foreign-object (num-methods :int)
       (let ((methods (class-copy-method-list class num-methods)))
         (let ((result (list)))
           (dotimes (n (mem-aref num-methods :int) (nreverse result))
             (push (mem-aref methods :pointer n)
                   result))))))
 

   #+sbcl
   (:method ((class sb-sys:system-area-pointer))
     (with-foreign-object (num-methods :int)
       (let ((methods (class-copy-method-list class num-methods)))
         (let ((result (list)))
           (dotimes (n (mem-aref num-methods :int) (nreverse result))
             (push (mem-aref methods :pointer n)
                   result)))))))
 

 (defmethod get-methods (f)
   (list))
 

 (defun make-nsstring (str)

   [[#@NSString @(alloc)] @(initWithCString:encoding:) :string str :uint 4])

 (defun extract-nsstring (ns-str)
   [ns-str @(UTF8String)]s)

 (defun get-method-name (method)
   (sel-get-name (method-get-name method)))
 

 (defun get-method-names (thing)
   (mapcar (alexandria:compose #'sel-get-name
                               #'method-get-name)
           (get-methods thing)))
 
 (defgeneric graph->dot (graph stream)
   (:method :around (graph stream)

      (declare (ignore graph))

 	   (format stream "~&digraph {~%~4trankdir=LR;~%")
 	   (call-next-method)
 	   (format stream "~&}"))
   (:method ((graph hash-table) stream)
     (loop for class being the hash-keys of graph using (hash-value superclass)
        do (format stream "~&~4t\"~a\" -> \"~a\"~%" class superclass))))
 
 (defparameter *selector-cache* (make-hash-table :test 'equal))

 (defparameter *class-cache* (make-hash-table :test 'equal))

 (serapeum:eval-always
   (defun normalize-selector-name (sel-name)
     (substitute #\: #\? sel-name)))
 

 (defun ensure-class (name)
   (let ((objc-class (objc-look-up-class name)))
     (when (and objc-class (not (null-pointer-p objc-class)))

       (alexandria:ensure-gethash name *class-cache* objc-class))))

 (defun ensure-selector (name)

   (alexandria:ensure-gethash name
                              *selector-cache*

                              (sel-register-name name)))
 
 (defmacro with-objc-classes ((&rest class-defs) &body body)
   `(let (,@(mapcar (fw.lu:destructuring-lambda ((lisp-name foreign-name))
                      `(,lisp-name (objc-look-up-class ,foreign-name)))
                    class-defs))
      ,@body))
 
 

 
 (cffi:defcvar (ns-app "NSApp" :library appkit) :pointer)
 
 (defclass objc-class ()
   ((%objc-class-name :initarg :name :reader name)
    (%class-pointer :initarg :pointer :reader class-pointer)
    (%cache :initform (make-hash-table :test 'equal) :allocation :class :reader objc-class-cache)))
 
 (defclass objc-selector ()
   ((%objc-selector-name :initarg :name :reader name)
    (%selector-pointer :initarg :pointer :reader selector-pointer)
    (%args :initarg :args :reader args)
    (%result-type :initarg :result-type :reader result-type)
    (%cache :initform (make-hash-table :test 'equal) :allocation :class :reader objc-selector-cache))
   (:metaclass closer-mop:funcallable-standard-class))
 
 (defun make-message-lambda-form (args rettype)
   (alexandria:with-gensyms ((target :target))
     (fw.lu:with (arg-syms (mapcar (serapeum:op _ (gensym "arg")) args))
       `(lambda (selector)
          (lambda (,target ,@arg-syms)
            (cffi:foreign-funcall
             "objc_msgSend"
             :pointer ,target
             :pointer selector
             ,@(mapcan #'list args arg-syms)
             ,rettype))))))
 
 (defmethod initialize-instance :after ((sel objc-selector) &key &allow-other-keys)
   (with-accessors ((pointer selector-pointer)
                    (args args)
                    (rettype result-type))
       sel
     (closer-mop:set-funcallable-instance-function
      sel
      (funcall (compile nil (make-message-lambda-form args rettype))
               pointer))))
 
 (defgeneric reset-class-cache (class)
   (:method ((class symbol))
     (reset-class-cache (find-class class)))
   (:method ((class class))
     (setf (slot-value (closer-mop:class-prototype class) '%cache)
           (make-hash-table :test 'equal))))
 
 
 (define-condition no-such-objc-class (serious-condition)
   ((%wanted-name :initarg :wanted-name :reader wanted-name))
   (:report (lambda (c s)
              (format s "No such Objective-C class: ~a" (wanted-name c)))))
 
 (defun %ensure-wrapped-objc-class (name)
   (let* ((class-cache (objc-class-cache (closer-mop:class-prototype (find-class 'objc-class))))
          (cached (gethash name class-cache)))
     (if cached

         cached

         (let ((objc-class (objc-look-up-class name)))
           (if (null-pointer-p objc-class)
               (error 'no-such-objc-class :wanted-name name)
               (setf (gethash name class-cache)
                     (make-instance 'objc-class
                                    :name name
                                    :pointer objc-class)))))))
 

 ;; TODO: should this error if there is no corresponding selector?
 ;;         Or should we let that fall through to message sending?

 (defun %ensure-wrapped-objc-selector (name target-class result-type args)
   (assert (= (count #\: name)

             (length args))

           (name args)
           "Invalid number of arg types for selector ~s" name)
 
   (let* ((class-cache (objc-selector-cache (closer-mop:class-prototype (find-class 'objc-selector))))
          (cached (gethash (list name target-class)
                           class-cache)))
     (if cached

         cached

         (let ((objc-selector (ensure-selector name)))
           (setf (gethash (list name target-class) class-cache)
                 (make-instance 'objc-selector
                                :name name
                                :pointer objc-selector
                                :result-type result-type
                                :args args))))))
 

 (defgeneric make-objc-instance (class &rest args)
   (:method ((class string) &rest args)
     (apply #'make-objc-instance (objc-look-up-class class) args))
   #+ccl
   (:method ((class ccl:macptr) &rest args)
     (declare (ignore args))
     (with-selectors (alloc init)
       [[class alloc] init]))
   #+sbcl
   (:method ((class sb-sys:system-area-pointer) &rest args)
     (declare (ignore args))
     (with-selectors (alloc init)
       [[class alloc] init])))
 

 (defun ensure-wrapped-objc-class (name)
   (tagbody
    retry (restart-case (return-from ensure-wrapped-objc-class
                          (%ensure-wrapped-objc-class name))
            (use-value (new)
              :interactive (lambda ()
                             (format t "New Objective-C class name: ")
                             (multiple-value-list (read)))
              :report "Retry with new class name"
              (setf name new)
              (go retry)))))

 (defmacro with-selectors ((&rest selector-specs) &body body)
   `(let (,@(mapcar (fw.lu:destructuring-lambda ((sym foreign-selector))
                      `(,sym (ensure-selector ,foreign-selector)))

                    (mapcar (fwoar.anonymous-gf:glambda (spec)

                              (:method ((spec symbol))
                                (list spec (normalize-selector-name
                                            (string-downcase spec))))
                              (:method ((spec cons))
                                (list (car spec) (cadr spec))))
                            selector-specs)))
      ,@body))

 (defmacro with-typed-selectors ((&rest defs) &body body)
   (let ((expanded-defs (loop for ((name objc-name) args ret-type) in defs

                              collect
                              `((,name (&rest r) (apply ,name r))
                                (,name (%ensure-wrapped-objc-selector ,objc-name ',ret-type ',args))))))

     `(let (,@(mapcar #'second expanded-defs))
        (flet (,@(mapcar #'first expanded-defs))
          ,@body))))

 
 (defun description (nsobject)
   [nsobject @(description)]@)
 
 (defun future-ns-date (seconds)
   [[#@NSDate @(alloc)]
    @(initWithTimeIntervalSinceNow:)
    :double (coerce seconds 'double-float)])
 
 (defun tick-ns-runloop (run-loop &optional (time 0.5d0))
   (let ((date (future-ns-date time)))
     (unwind-protect [run-loop @(runUntilDate:)
                               :pointer date]
       [date @(release)])))