;;;-*-Mode: LISP; Package: GUI -*-
;;;
;;; Copyright 2002-2007 Clozure Associates
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;     http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.


(in-package "GUI")

(eval-when (:compile-toplevel :load-toplevel :execute)
  (def-cocoa-default *default-font-name* :string "Courier" "Name of font to use in editor windows")
  (def-cocoa-default *default-font-size* :float 12.0f0 "Size of font to use in editor windows, as a positive SINGLE-FLOAT")
  (def-cocoa-default *tab-width* :int 8 "Width of editor tab stops, in characters"))

(defclass cocoa-ide (application)
  ())

(defun init-cocoa-ide ()
  (with-autorelease-pool
      (#/standardUserDefaults ns:ns-user-defaults)
      (let* ((bundle (open-main-bundle))
	     (dict (#/infoDictionary  bundle))
	     (classname (#/objectForKey: dict #@"NSPrincipalClass"))
	     (progname (#/objectForKey: dict #@"CFBundleName")))
	(if (%null-ptr-p classname)
	  (error "problems loading bundle: can't determine class name"))
	(unless (%null-ptr-p progname)
          (#/setProcessName: (#/processInfo ns:ns-process-info) progname))
	(let* ((appclass (#_NSClassFromString classname))
	       (app (#/sharedApplication appclass))
	       (main-menu (#/initWithTitle: (#/alloc ns:ns-menu) #@"MainMenu")))
	  (#/setMainMenu: app main-menu)
	  (#/release main-menu)
	  app))))



#+apple-objc
(defun trace-dps-events (flag)
  (external-call "__DPSSetEventsTraced"
		 :unsigned-byte (if flag #$YES #$NO)
		 :void))

(defclass appkit-process (process)
    ((have-interactive-terminal-io :initform t)))

(defmethod event-loop-can-have-interactive-terminal-io ((process appkit-process))
  #+windows-target t
  #-windows-target (slot-value process 'have-interactive-terminal-io))

;;; Interrupt the AppKit event process, by enqueing an event (if the
;;; application event loop seems to be running.)  It's possible that
;;; the event loop will stop after the calling thread checks; in that
;;; case, the application's probably already in the process of
;;; exiting, and isn't that different from the case where asynchronous
;;; interrupts are used.
(defmethod process-interrupt ((process appkit-process) function &rest args)
  (if (eq process *current-process*)
    (apply function args)
    (if (and *NSApp* (#/isRunning *NSApp*))
      (queue-for-gui #'(lambda () (apply function args)) :at-start t)
      #+not-yet
      (let* ((invoked nil)
             (f (lambda ()
                  (unless invoked
                    (setq invoked t)
                    (apply function args)))))
        (queue-for-gui f :at-start t)
        (call-next-method process f))
      (call-next-method))))

(defparameter *debug-in-event-process* t)

(defparameter *event-process-reported-conditions* () "Things that we've already complained about on this event cycle.")

(defmethod ccl::process-debug-condition ((process appkit-process) condition frame-pointer)
  "Better than nothing.  Not much better."
  (when *debug-in-event-process*
    (let* ((c (if (typep condition 'ccl::ns-lisp-exception)
                (ccl::ns-lisp-exception-condition condition)
                condition)))
      (unless (or (not (typep c 'error)) (member c *event-process-reported-conditions*))
        (push c *event-process-reported-conditions*)
        (cond ((slot-value process 'have-interactive-terminal-io)
               (ccl::application-error ccl::*application* c frame-pointer))
              (t
               (catch 'need-a-catch-frame-for-backtrace
                 (let* ((*debug-in-event-process* nil)
                        (context
                         (ccl::new-backtrace-info nil
                                                  frame-pointer
                                                  (if ccl::*backtrace-contexts*
                                                      (or (ccl::child-frame
                                                           (ccl::bt.youngest
                                                            (car ccl::*backtrace-contexts*))
                                                           nil)
                                                          (ccl::last-frame-ptr))
                                                      (ccl::last-frame-ptr))
                                                  (ccl::%current-tcr)
                                                  condition
                                                  (ccl::%current-frame-ptr)
                                                  #+ppc-target ccl::*fake-stack-frames*
                                                  #+x86-target (ccl::%current-frame-ptr)
                                                  (ccl::db-link)
                                                  (1+ ccl::*break-level*)))
                        (ccl::*backtrace-contexts* (cons context ccl::*backtrace-contexts*)))  
                   (format t "~%~%*** Error in event process: ~a~%~%" condition)
                   (print-call-history :context context :detailed-p t :count 20
                                       :origin frame-pointer)
                   (format t "~%~%~%")
                   (force-output t)
                   ))))))))

(defun enable-foreground ()
  #+apple-objc
  (rlet ((psn :<P>rocess<S>erial<N>umber))
    (#_GetCurrentProcess psn)
    (#_TransformProcessType psn #$kProcessTransformToForegroundApplication)
    (eql 0 (#_SetFrontProcess psn))))

(objc:defmethod (#/toggleConsole: :void) ((self ide-application) sender)
  (let* ((console (console self)))
    (unless (%null-ptr-p console)
      (mark-console-output-available console nil)
      (if (setf (console-window-hidden-by-user console) (#/isVisible console))
        (#/orderOut: console sender)
        (#/orderFront: console sender)))))

(objc:defmethod (#/validateMenuItem: :<BOOL>) ((self ide-application)
                                               item)
  (let* ((action (#/action item)))
    (cond ((eql action (@selector #/toggleConsole:))
           (let* ((console (console self)))
             (unless (%null-ptr-p console)
               (if (#/isVisible console)
                 (#/setTitle: item #@"Hide System Console")
                 (#/setTitle: item #@"Show System Console"))
               t)))
          (t #+cocotron t #-cocotron (call-next-method item)))))

(defmethod ccl::process-exit-application ((process appkit-process) thunk)
  (when (eq process ccl::*initial-process*)
    (%set-toplevel thunk)
    (#/terminate: *NSApp* +null-ptr+)))

(defun run-event-loop ()
  (%set-toplevel nil)
  (change-class *cocoa-event-process* 'appkit-process)
  (event-loop))

(defun stop-event-loop ()
  (#/stop: *nsapp* +null-ptr+))

(defun event-loop (&optional end-test)
  (let* ((app *NSApp*)
         (thread ccl::*current-process*))
    (loop
      (if (event-loop-can-have-interactive-terminal-io thread)
        (with-simple-restart (abort "Process the next event")
          (#/run app))
        (let* ((ccl::*break-on-errors* nil))
          (handler-case (let* ((*event-process-reported-conditions* nil))
                          (if end-test
                            (#/run app)
                            #|(#/runMode:beforeDate: (#/currentRunLoop ns:ns-run-loop)
                                                     #&NSDefaultRunLoopMode
                                                     (#/distantFuture ns:ns-date))|#
                            (#/run app)))
            (error (c) (nslog-condition c)))))
      #+debug (log-debug "~&runMode exited, end-test: ~s isRunning ~s quitting: ~s" end-test (#/isRunning app) ccl::*quitting*)
      (when (or (and end-test (funcall end-test))
		(and ccl::*quitting* (not (#/isRunning app))))
	(return)))))

(defparameter *delegate-class-name* "IDEApplicationDelegate")

(defun start-cocoa-ide ()
  (flet ((cocoa-startup ()
	   ;; Start up a thread to run periodic tasks.
           (ccl::with-standard-initial-bindings
               (process-run-function "housekeeping" #'ccl::housekeeping-loop)
               (with-autorelease-pool
                   (enable-foreground)
                 (or *NSApp* (setq *NSApp* (init-cocoa-ide)))
                 #-cocotron
                 (let* ((icon (#/imageNamed: ns:ns-image #@"NSApplicationIcon")))
                   (unless (%null-ptr-p icon)
                     (#/setApplicationIconImage: *NSApp* icon)))
                 (setf (ccl::application-ui-object *application*) *NSApp*)
                 (when (and *delegate-class-name*
			    (%null-ptr-p (#/delegate *nsapp*)))
                   (let* ((class (with-cfstring (s *delegate-class-name*)
				   (#_NSClassFromString s)))
                          (delegate (#/init (#/alloc class))))
                     (#/setDelegate: *NSApp* delegate))))
               (run-event-loop))))
    (process-interrupt *cocoa-event-process* #'(lambda ()
                                                 (%set-toplevel 
                                                  #'cocoa-startup)
                                                 (toplevel)))))

(defparameter *font-attribute-names*
  '((:bold . #.#$NSBoldFontMask)
    (:italic . #.#$NSItalicFontMask)
    (:small-caps . #.#$NSSmallCapsFontMask)))


;;; The NSFont method #/isFixedPitch has returned random answers
;;; in many cases for the last few OSX releases.  Try to return
;;; a reasonable answer, by checking to see if the width of the
;;; advancement for the #\i glyph matches that of the advancement
;;; of the #\m glyph.

#-cocotron
(defun is-fixed-pitch-font (font)
  (= (ns:ns-size-width (#/advancementForGlyph: font (#/glyphWithName: font #@"i")))
     (ns:ns-size-width (#/advancementForGlyph: font (#/glyphWithName: font #@"m")))))

#+cocotron
(defun is-fixed-pitch-font (font)
  (#/isFixedPitch font))

;;; Try to find the specified font.  If it doesn't exist (or isn't
;;; fixed-pitch), try to find a fixed-pitch font of the indicated size.
(defun default-font (&key (name *default-font-name*)
			  (size *default-font-size*)
			  (attributes ()))
				
  (setq size (cgfloat size))
  (with-cstrs ((name name))
    (with-autorelease-pool
	(rletz ((matrix (:array :<CGF>loat 6)))
	  (setf (paref matrix (:* :<CGF>loat) 0) size
                (paref matrix (:* :<CGF>loat) 3) size)
          (let* ((fontname (#/stringWithCString: ns:ns-string name))
		 (font (#/fontWithName:matrix: ns:ns-font fontname matrix))
		 
		 (implemented-attributes ()))
	    (if (or (%null-ptr-p font)
		    (and 
		     (not (is-fixed-pitch-font font))))
	      (setq font (#/userFixedPitchFontOfSize: ns:ns-font size)))
	    (when attributes
	      (dolist (attr-name attributes)
		(let* ((pair (assoc attr-name *font-attribute-names*))
		       (newfont))
		  (when pair
		    (setq newfont
                          (#/convertFont:toHaveTrait:
                           (#/sharedFontManager ns:ns-font-manager) font (cdr pair)))
		    (unless (eql font newfont)
		      (setq font newfont)
		      (push attr-name implemented-attributes))))))
	    (values (#/retain font) implemented-attributes))))))


;;; Create a paragraph style, mostly so that we can set tabs reasonably.
(defun create-paragraph-style (font line-break-mode)
  (let* ((p (make-instance 'ns:ns-mutable-paragraph-style))
	 (charwidth (fround (nth-value 1 (size-of-char-in-font font)))))
    (#/setLineBreakMode: p
                         (ecase line-break-mode
                           (:char #$NSLineBreakByCharWrapping)
                           (:word #$NSLineBreakByWordWrapping)
                           ;; This doesn't seem to work too well.
                           ((nil) #$NSLineBreakByClipping)))
    ;; Clear existing tab stops.
    (#/setTabStops: p (#/array ns:ns-array))
    ;; And set the "default tab interval".
    (#/setDefaultTabInterval: p (cgfloat (* *tab-width* charwidth)))
    p))
    
(defun create-text-attributes (&key (font (default-font))
				    (line-break-mode *default-line-break-mode*)
				    (color nil)
                                    (obliqueness nil)
                                    (stroke-width nil))
  (let* ((dict (make-instance 'ns:ns-mutable-dictionary :with-capacity 5)))
    (#/setObject:forKey: dict (create-paragraph-style font line-break-mode)
			 #&NSParagraphStyleAttributeName)
    (#/setObject:forKey: dict font #&NSFontAttributeName)
    (when color
      (#/setObject:forKey: dict color #&NSForegroundColorAttributeName))
    (when stroke-width
      (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number stroke-width)
			   #&NSStrokeWidthAttributeName))
    (when obliqueness
      (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number obliqueness)
			   #&NSObliquenessAttributeName))
    dict))


(defun get-cocoa-window-flag (w flagname)
  (case flagname
    (:accepts-mouse-moved-events
     (#/acceptsMouseMovedEvents w))
    (:cursor-rects-enabled
     (#/areCursorRectsEnabled w))
    (:auto-display
     (#/isAutodisplay w))))



(defun (setf get-cocoa-window-flag) (value w flagname)
  (case flagname
    (:accepts-mouse-moved-events
     (#/setAcceptsMouseMovedEvents: w value))
    (:auto-display
     (#/setAutodisplay: w value))))



(defun activate-window (w)
  ;; Make w the "key" and frontmost window.  Make it visible, if need be.
  (#/makeKeyAndOrderFront: w nil))

(defun set-window-title (window title)
  (#/setTitle: window (if title
                        (if (typep title 'ns:ns-string)
                          title
                          (%make-nsstring title))
                        #@"") ))

(defmethod allocate-instance ((class ns:+ns-window)
                              &rest initargs
                              &key
                              (with-content-rect nil content-rect-p)
                              (style-mask 0 style-mask-p)
                              (x 200)
                              (y 200)
                              (width 500)
                              (height 200)
                              (closable t)
                              (iconifyable t)
                              (expandable t)
                              (metal nil)
                              (backing :buffered)
                              (defer t defer-p)
                              &allow-other-keys)
  (declare (ignore defer with-content-rect))
  (unless content-rect-p
    (setq initargs (cons :with-content-rect
                         (cons (ns:make-ns-rect x y width height)
                               initargs))))
  (unless (and style-mask-p (typep style-mask 'fixnum))
    (setq initargs (cons :style-mask
                         (cons (logior #$NSTitledWindowMask
                                       (if closable #$NSClosableWindowMask 0)
                                       (if iconifyable #$NSMiniaturizableWindowMask 0)
                                       (if expandable #$NSResizableWindowMask 0)
                                       (if metal #$NSTexturedBackgroundWindowMask 0))
                               initargs))))
  (unless (typep (getf initargs :backing) 'fixnum)
    (setq initargs
          (cons :backing
                (cons (ecase backing
                        ((t :retained) #$NSBackingStoreRetained)
                        ((nil :nonretained) #$NSBackingStoreNonretained)
                        (:buffered #$NSBackingStoreBuffered))
                      initargs))))
  (unless defer-p
    (setq initargs (cons :defer (cons t initargs))))
  (apply #'call-next-method class initargs))

(defmethod initialize-instance :after ((w ns:ns-window)
                                       &key
                                       (title nil)
                                       (x 200.0)
                                       (y 200.0)
                                       (height 200.0)
                                       (width 500.0)
                                       (closable t)
                                       (iconifyable t)
                                       (metal nil)
                                       (expandable t)
                                       (backing :buffered)
                                       (defer t)
                                       (accepts-mouse-moved-events nil)
                                       (auto-display t)
                                       (activate nil)
                                       &allow-other-keys)
  ;; Several of the keyword args we claim to accept are actually processed
  ;; by the ALLOCATE-INSTANCE method above and are ignored here.
  (declare (ignore x y width height closable iconifyable expandable metal
                   backing defer))
  (setf (get-cocoa-window-flag w :accepts-mouse-moved-events)
        accepts-mouse-moved-events
        (get-cocoa-window-flag w :auto-display)
        auto-display)
  ;;; Should maybe have a way of controlling this.
  (#/setBackgroundColor: w (#/whiteColor ns:ns-color))
  (when title
    (set-window-title w title))
  (when activate
    (activate-window w)))


(defmethod allocate-instance ((class ns:+ns-view)
                              &rest initargs
                              &key
                              (with-frame nil with-frame-p)
                              (x 0)
                              (y 0)
                              (width 0)
                              (height 0)
                              &allow-other-keys)
  (declare (ignorable with-frame))
  (unless with-frame-p
    (setq initargs (cons :with-frame
                         (cons (ns:make-ns-rect x y width height) initargs))))
  (apply #'call-next-method class initargs))


(defmethod initialize-instance :after ((view ns:ns-view)
                                       &key
                                       (horizontally-resizable nil hrp)
                                       (vertically-resizable nil vrp)
                                       (max-x-margin nil maxxp)
                                       (min-x-margin nil minxp)
                                       (max-y-margin nil maxyp)
                                       (min-y-margin nil minyp)
                                       (resizes-subviews t rsp)
                                       view-container
                                       &allow-other-keys)
  (let* ((mask (#/autoresizingMask view))
         (newmask mask))
    (when hrp
      (setq newmask (if horizontally-resizable
                      (logior newmask #$NSViewWidthSizable)
                      (logandc2 newmask #$NSViewWidthSizable))))
    (when vrp
      (setq newmask (if vertically-resizable
                      (logior newmask #$NSViewHeightSizable)
                      (logandc2 newmask #$NSViewHeightSizable))))
    (when minxp
      (setq newmask (if min-x-margin
                      (logior newmask #$NSViewMinXMargin)
                      (logandc2 newmask #$NSViewMinXMargin))))
    (when maxxp
      (setq newmask (if max-x-margin
                      (logior newmask #$NSViewMaxXMargin)
                      (logandc2 newmask #$NSViewMaxXMargin))))
    (when minyp
      (setq newmask (if min-y-margin
                      (logior newmask #$NSViewMinYMargin)
                      (logandc2 newmask #$NSViewMinYMargin))))
    (when maxyp
      (setq newmask (if max-y-margin
                      (logior newmask #$NSViewMaxYMargin)
                      (logandc2 newmask #$NSViewMaxYMargin))))
    (unless (eql mask newmask)
      (#/setAutoresizingMask: view newmask)))
  (when rsp
    (#/setAutoresizesSubviews: view resizes-subviews))
  (when view-container
    (install-view-in-container view view-container)))
                              

(defun new-cocoa-window (&key
                         (class (find-class 'ns:ns-window))
                         (title nil)
                         (x 200.0)
                         (y 200.0)
                         (height 200.0)
                         (width 500.0)
                         (closable t)
                         (iconifyable t)
                         (metal nil)
                         (expandable t)
                         (backing :buffered)
                         (defer t)
                         (accepts-mouse-moved-events nil)
                         (auto-display t)
                         (activate t))
  (make-instance class
                 :title title
                 :x x
                 :y y
                 :height height
                 :width width
                 :closable closable
                 :iconifyable iconifyable
                 :metal metal
                 :expandable expandable
                 :backing backing
                 :defer defer
                 :accepts-mouse-moved-events accepts-mouse-moved-events
                 :auto-display auto-display
                 :activate activate))

(defmethod view-window ((view ns:ns-view))
  (let* ((w (#/window view)))
    (unless (%null-ptr-p w)
      w)))

(defmethod install-view-in-container ((view ns:ns-view) (container ns:ns-view))
  (#/addSubview: container view))

(defmethod install-view-in-container ((view ns:ns-view) (container ns:ns-window))
  (#/addSubview: (#/contentView container) view))
