(defpackage :demo-app
   (:use :cl :objc-runtime)

   (:export
    #:get-method-names))

 (in-package :demo-app)
 (named-readtables:in-readtable :objc-readtable)
 
 (cffi:defcallback exception-handler :void ((exception :pointer))
   (with-selectors (reason)
     (format t "~&Exxception: ~a~%" [exception reason])
     (values)))
 

 (defun init-window (window rect a b c)
   (format t "~&got rect: ~s" rect)
   (cffi:foreign-funcall "objc_msgSend"
                         :pointer window
                         :pointer @(initWithContentRect:)
                         :pointer window
                         (:struct objc-runtime::ns-rect) rect
                         :char a
                         :char b
                         :boolean c
                         :pointer))

 (defmacro selector-lambda (selector &rest args)
   `(lambda (receiver)
      [receiver ,selector ,@args]))
 

 (defun init-with-frame (thing rect)
   (format t "~&got rect: ~s" rect)
   (cffi:foreign-funcall "objc_msgSend"
                         :pointer thing
                         :pointer @(initWithFrame:)
                         (:struct objc-runtime::ns-rect) rect
                         :pointer))
 

 (cffi:defcfun (print-rect "printRect")
     :void

   (rect (:struct objc-runtime:ns-rect)))

 #+(or)

 (cffi:defcfun (set-uncaught-exception-handler "set_uncaught_exception_handler"
                                               :library objc-runtime::expose-stuff)
     :void
   (cb :pointer))
 

 (defun value-for-key (thing key)
   (with-selectors ((vfk "valueForKey:"))

     (let ((key (objc-runtime::make-nsstring key)))

       [thing vfk :string key])))
 

 (defun call-with-rect (x y w h cb)
   (check-type x real)
   (check-type y real)
   (check-type w real)
   (check-type h real)

   (cffi:with-foreign-object (rect '(:struct objc-runtime::ns-rect))

     (cffi:with-foreign-slots (((:pointer ns-rect-origin) (:pointer ns-rect-size))

                               rect (:struct objc-runtime::ns-rect))

       (cffi:with-foreign-slots ((ns-point-x ns-point-y) ns-rect-origin (:struct ns-point))
         (setf ns-point-x (coerce x 'double-float)
               ns-point-y (coerce y 'double-float)))
       (cffi:with-foreign-slots ((ns-size-width ns-size-height)
                                 ns-rect-size (:struct ns-size))
         (setf ns-size-width (coerce w 'double-float)
               ns-size-height (coerce h 'double-float))))
     (funcall cb rect)))
 
 (defun call-with-point (x y cb)
   (check-type x real)
   (check-type y real)
   (cffi:with-foreign-object (point '(:struct ns-point))
     (cffi:with-foreign-slots ((ns-point-x ns-point-y) point (:struct ns-point))
       (setf ns-point-x (coerce x 'double-float)
             ns-point-y (coerce y 'double-float)))
     (funcall cb point)))
 
 (defmacro with-rect ((rect (x y) (w h)) &body body)
   `(call-with-rect ,x ,y ,w ,h
                    (lambda (,rect)
                      ,@body)))
 
 (defmacro with-point ((point (x y)) &body body)
   `(call-with-point ,x ,y
                    (lambda (,point)
                      ,@body)))
 
 (defun make-rect (x y w h)
   (check-type x real)
   (check-type y real)
   (check-type w real)
   (check-type h real)
   (cffi:convert-to-foreign `(ns-rect-origin
                              (objc-runtime:ns-point-x
                               ,(coerce x 'double-float)
                               objc-runtime:ns-point-y
                               ,(coerce y 'double-float))
                              ns-rect-size
                              (objc-runtime:ns-size-width
                               ,(coerce w 'double-float)
                               objc-runtime:ns-size-height
                               ,(coerce h 'double-float)))
                            '(:struct objc-runtime:ns-rect)))
 

 (defun show-alert (message &optional (informative-text "Informative Text!"))

   (let ((alert [[#@NSAlert @(alloc)] @(init)]))

     [alert @(setMessageText:) :pointer (objc-runtime::make-nsstring message)]
     [alert @(setInformativeText:) :pointer (objc-runtime::make-nsstring informative-text)]

     [alert @(addButtonWithTitle:) :pointer @"OK"]
     [alert @(addButtonWithTitle:) :pointer @"Cancel"]
     [alert @(runModal)]))

 (cffi:defcallback do-things-action :void ((a :pointer) (b :pointer) (sender :pointer))
   (declare (ignore a b sender))
   (show-alert "Starting Swank"
               "Loading Quicklisp from ~/quicklisp/setup.lisp + starting swank")
 
   (load "~/quicklisp/setup.lisp")
   (funcall (intern "QUICKLOAD" (find-package :QL)) :swank)
   (funcall (intern "CREATE-SERVER" (find-package :swank)) :port 5060 :dont-close t)

   (show-alert "Started swank on 5060"))
 
 (cffi:defcallback alert-action :void ((a :pointer) (b :pointer) (sender :pointer))

   (declare (ignore a b sender))
   (show-alert "Hello There!"))
 

 (cffi:defcallback profit-action :void ((a :pointer) (b :pointer) (sender :pointer))
   (declare (ignore a b sender))
   (show-alert "That Was Profitable!"))
 

 (defun alloc-init (cls)
   [[cls @(alloc)] @(init)])
 

 (defun make-button-delegate (button cb)

   (objc-runtime.data-extractors:objc-typecase button
     (#@NSButton (let ((my-class (objc-runtime::objc-allocate-class-pair #@NSObject "ButtonDel" 0)))
                   (objc-runtime::class-add-method my-class @(doMagic) cb "v@:@")
                   (fw.lu:prog1-bind (result (alloc-init my-class))
                     [button @(setTarget:) :pointer result]
                     [button @(setAction:) :pointer @(doMagic)])))
     (t (format t "~&The button is not a button~%"))))

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

 (defun make-app-delegate-class-with-props (foo outlets)
   (let ((app-delegate-class (objc-runtime::objc-allocate-class-pair
                              #@NSObject foo 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))
 

 (defun load-nib (name)
   ;; find and activate the nib
   (let* ((bundle [#@NSBundle @(mainBundle)])
          (nib [[#@NSNib @(alloc)] @(initWithNibNamed:bundle:)

                :pointer (objc-runtime::make-nsstring name)
                :pointer bundle]))

     (cffi:with-foreign-object (p :pointer)
       ;; TODO: is dropping p a problem here? The docs say something relevant.
       ;;       must investigate.
       [nib @(instantiateWithOwner:topLevelObjects:)
            :pointer objc-runtime::ns-app
            :pointer p])))
 

 ;#+null

 (defun main ()

   #+sbcl
   (sb-int:set-floating-point-modes :traps '())
 

   (load "~/quicklisp/setup.lisp")
   (funcall (intern "QUICKLOAD"
                    (find-package :QL))
            :swank)
 
   #+nil
   (funcall (intern "CREATE-SERVER"
                    (find-package :swank))
            :port 5060
            :dont-close t)
 

   (trivial-main-thread:with-body-in-main-thread (:blocking t)

     [#@NSAutoreleasePool @(new)]

     [#@NSApplication @(sharedApplication)]

     #+nil

     [objc-runtime::ns-app @(setActivationPolicy:) :int 0]
 

     ;; Setup the app delegate class. We register this one because it's useful
     ;; When debugging via something like lldb
     (objc-runtime::objc-register-class-pair
      (make-app-delegate-class '("actionButton"
                                 "alertButton"
                                 "profitButton")))
 

     (load-nib "MainMenu.nib")

     (let ((app-delegate [objc-runtime::ns-app @(delegate)]))
       (make-button-delegate (value-for-key app-delegate "actionButton")
                             (cffi:callback do-things-action))
       (make-button-delegate (value-for-key app-delegate "alertButton")
                             (cffi:callback alert-action))
       (make-button-delegate (value-for-key app-delegate "profitButton")
                             (cffi:callback profit-action)))

     [objc-runtime::ns-app @(activateIgnoringOtherApps:) :boolean t]

     [objc-runtime::ns-app @(run)]))

 
 (defclass application-shim ()
   ((%main-view :initarg :main-view :accessor main-view)))
 

 (cffi:defcfun (%set-string-value "objc_msgSend")
     :void
   (cls objc-runtime::o-class)
   (sel objc-runtime::o-selector)
   (value :pointer))

 (defun set-string-value (control string)
   (prog1 control
     (%set-string-value control @(setStringValue:)
                        (objc-runtime:make-nsstring string))))
 
 (defun label (text)
   (let ((view [[#@NSTextField @(alloc)] @(init)]))
     (prog1 view
       (set-string-value view text))))
 
 (defun button (title)
   (trivial-main-thread:with-body-in-main-thread (:blocking t)
     [#@NSButton @(buttonWithTitle:target:action:)
                 :pointer (objc-runtime:make-nsstring title)
                 :pointer #@NSButton
                 :pointer @(alloc)]))
 
 (defun init-in-main-thread (instance)
   (prog1 instance
     [instance @(performSelectorOnMainThread:withObject:waitUntilDone:)
               :pointer @(init)
               :pointer (cffi:null-pointer)
               :bool t]))
 

 (defvar *application-shim*
   (make-instance 'application-shim))

 (defun wait-for-events ()
   (let ((event [objc-runtime::ns-app @(nextEventMatchingMask:untilDate:inMode:dequeue:)
                                      :unsigned-long 18446744073709551615
                                      :pointer [#@NSDate @(distantFuture)]
                                      :pointer @"kCFRunLoopDefaultMode"
                                      :int 1]))
     [objc-runtime::ns-app @(sendEvent:) :pointer event]
     event))
 
 (defun tick ()
   (wait-for-events))
 
 (defun task-thread ()
   (bt:make-thread (lambda ()

                     #+(or)

                     (trivial-main-thread:with-body-in-main-thread (:blocking t)

                       [#@NSEvent @(stopPeriodicEvents)]

                       [#@NSEvent @(startPeriodicEventsAfterDelay:withPeriod:) :double 0.0d0 :double 0.01d0])
                     (loop
                       (trivial-main-thread:with-body-in-main-thread (:blocking t)
                         (tick))))
                   :name "Cocoa Event Loop Feeder"))
 

 ;;#+nil
 (defun old-main ()
   (trivial-main-thread:with-body-in-main-thread (:blocking nil)

     #+sbcl
     (sb-int:set-floating-point-modes :traps '())
 

     [#@NSAutoreleasePool @(new)]

     [#@NSApplication @(sharedApplication)]
 
     (format t "~&app: ~s~%" objc-runtime::ns-app)
     #+nil
     [objc-runtime::ns-app @(setActivationPolicy) :int 0]
 
     (let* ((application-name [[#@NSProcessInfo @(processInfo)] @(processName)]))
       (let* ((menubar [[#@NSMenu @(new)] @(autorelease)])
              (app-menu-item [[#@NSMenuItem @(new)] @(autorelease)])
              (app-menu [[#@NSMenu @(new)] @(autorelease)])
              (quit-name @"Quit")
              (key @"q")
              (quit-menu-item

                [[[#@NSMenuItem @(alloc)]
                  @(initWithTitle:action:keyEquivalent:) :pointer quit-name :pointer @(terminate?) :string key]
                 @(autorelease)]))

         [menubar @(addItem:) :pointer app-menu-item]
         [app-menu @(addItem:) :pointer quit-menu-item]
         [app-menu-item @(setSubmenu:) :pointer app-menu]
         [objc-runtime::ns-app @(setMainMenu:) :pointer menubar] )
 
       (setf (main-view *application-shim*)

             [#@NSStackView @(stackViewWithViews:)
                            :pointer [[#@NSArray @(alloc)] @(init)]])

       (with-point (p (20 20))
         (let* ((foreign-rect (make-rect 10 10 120 120))

                (the-window (init-window [#@NSWindow @(alloc)] foreign-rect 15 2 nil)))

           [(value-for-key the-window "contentView") @(addSubview:) :pointer (main-view *application-shim*)]
           [the-window @(cascadeTopLeftFromPoint:) :pointer p]
           [the-window @(setTitle:) :pointer application-name]
           [the-window @(makeKeyAndOrderFront:) :pointer (cffi:null-pointer)]
           [ objc-runtime::ns-app @(activateIgnoringOtherApps:) :boolean t]

           (task-thread))))))

 
 (cffi:defcfun (%get-view-frame "objc_msgSend_stret")
     :void
   (out (:pointer (:struct objc-runtime:ns-rect)))
   (class :pointer)
   (sel :pointer))
 
 (cffi:defcfun (%init-with-frame "objc_msgSend")
     :pointer
   (class :pointer)
   (sel :pointer)
   (frame (:struct objc-runtime:ns-rect)))
 
 (defmacro new-msg-send (selector ((&rest arg-types) return-type))
   (let ((arg-syms (mapcar (lambda (_) (gensym (symbol-name _)))
                           arg-types)))
     `(lambda ,(cons 'target arg-syms)
        (cffi:foreign-funcall "objc_msgSend"
                              :pointer target
                              :pointer ,selector
                              ,@(mapcan #'list arg-types arg-syms)
                              ,return-type))))
 
 (defmacro make-view-dictionary (&rest objc-values)
   (alexandria:with-gensyms (selector)
     `(let ((,selector (new-msg-send @(dictionaryWithObjectsAndKeys:)
                           ((,@(mapcar (lambda (_) _ :pointer) objc-values) :pointer)
                            :pointer))))
        (funcall ,selector ,@objc-values (cffi:null-pointer)))))
 
 #+(or)
 (defun text-view (parent-view)
   (let ((text-view [#@NSTextView @(alloc)]))
 

 
 
     (trivial-main-thread:with-body-in-main-thread (:blocking nil)
       (cffi:with-foreign-pointer (v (cffi:foreign-type-size '(:struct objc-runtime::ns-rect)))
         (%get-view-frame v *window-view* @(frame))
         (init-with-frame *text-view* v))
       [*window-view* @(addSubview:) :pointer *text-view*]?)
 

     (defparameter *view-dictionary*

       )
     ))
 
 #+(or)
 (progn
   (defparameter *window-view*
     [(main-view *application-shim*) @(superview)])
   (trivial-main-thread:with-body-in-main-thread (:blocking nil)
     [(main-view *application-shim*) @(removeFromSuperview)]?
     ))