(in-package :ccl)
(require "HEMLOCK")

(defstruct prefdef
  name		;; the text name
  getfn		;; function to get the value
  setfn		;; function to set the value 
  valtype	;; the value type :string, :integer, :float
  constrain	;; function to the constrian the value (Hmmm.)
  doc		;; the doc string
  pane		;; prefs panel tab id (:general, :hemlock)
  cell		;; form cell
  changed-p	;; indicated a changed value for revert/apply
  )

;;
;; @class prefsPanelView
;;
(defclass prefs-panel-view (ns:ns-view)
  ((tab-view :foreign-type :id :accessor prefs-panel-tab-view)
   (revert-button :foreign-type :id :accessor prefs-panel-revert-button)
   (apply-button :foreign-type :id :accessor prefs-panel-apply-button))
  (:metaclass ns:+ns-object))

;;
;; @class preferencesPanel
;;
(defclass preferences-panel (ns:ns-panel)
  ((bounds :foreign-type :<NSR>ect :accessor prefs-panel-bounds)
   (domain :foreign-type :id :accessor prefs-panel-domain)
   (prefs-view :accessor prefs-panel-view)
   (tabs :initform nil :accessor prefs-panel-tabs)
   (prefdefs :initform nil :accessor prefs-panel-prefdefs)
   )
  (:metaclass ns:+ns-object))

(defloadvar *prefs-panel* nil)

(defmacro import-cocoa-defaults (defs)
  `(dolist (d (cocoa-defaults))
     (let ((def d)) ; we need a real binding
       (push (make-prefdef
	      :name (cocoa-default-string def)
	      :getfn #'(lambda () (cocoa-default-value d))
	      :setfn #'(lambda (domain) (update-cocoa-default def domain))
	      :valtype :string
	      :doc (cocoa-default-doc def)
	      :constrain #'(lambda (v) v)
	      :pane :general
	      :changed-p nil
	      ) ,defs))))

(defmacro import-hemlock-defaults (defs)
  `(let* ((vars (hi::string-table-value-nodes hi::*global-variable-names*))
	  (n (length vars)))
     ;;
     ;;  Loop through the definitions in the defaults vector.
     ;;  Reverse the order to preserve the alphabetic sorting.
     ;;
     (dotimes (i n)
       (let ((hvar (elt vars (- n i 1))))
	 (when (hi::value-node-p hvar)
	   (let* ((name (ns-constant-string (hi::value-node-proper hvar)))
		  (key (objc-constant-string-nsstringptr name))
		  (object (get (hi::value-node-value hvar) 'hi::hemlock-variable-value))
		  (doc (hi::variable-object-documentation object)))
	     (push (make-prefdef
		    :name name
		    :getfn #'(lambda () (hi::variable-object-value object))
		    :setfn #'(lambda (domain)
			       (let* ((nsstring (send domain :string-for-key key)))
				 (unless (%null-ptr-p nsstring)
				   (setf (hi::variable-object-value object) 
					 (with-input-from-string (s (lisp-string-from-nsstring nsstring))
								 (read s))))))
		    :valtype :string
		    :constrain #'(lambda (val) val)
		    :doc doc
		    :pane :hemlock
		    :changed-p nil
		    ) ,defs)))))))

;;
;; @class prefsTabViewItem
;;
(defclass prefs-tab-view-item (ns:ns-tab-view-item)
  ((scroll-view :foreign-type :id :accessor prefs-tab-scroll-view)
   (form-view :foreign-type :id :accessor prefs-tab-form-view)
   (fake)
   (panel :accessor prefs-tab-panel))
  (:metaclass ns:+ns-object))

(defmethod set-form-cell-from-cocoa-pref ((self prefs-tab-view-item) cell doc type form val index)
  (send cell :set-tag index)
  (send cell :set-string-value val)
  (send cell :set-sends-action-on-end-editing 1)
  (when doc
    (send form
	  :set-tool-tip (%make-nsstring doc)
	  :for-cell cell))
  (case type
    (:int
     (send cell :set-entry-type #$NSIntType)
     '(send cell :set-alignment #$NSRightTextAlignment))
    (:float
     (send cell :set-entry-type #$NSFloatType)
     '(send cell :set-alignment #$NSRightTextAlignment))
    (t
     (send cell :set-scrollable t)))
  (send cell :set-action (@selector "notePrefsChange:"))
  (send cell :set-target self))

;;
;; - (void) prefsTabViewItem:notePrefsChange (id)
;;
(define-objc-method ((:void :note-prefs-change sender) 
		     prefs-tab-view-item)
  (declare (ignore sender))
  (let* ((panel *prefs-panel*) ;(prefs-tab-panel self)
	 (panel-view (prefs-panel-view panel))
	 (form (prefs-tab-form-view self))
	 (cell (send form :cell-at-index (send form 'index-of-selected-item)))
         ; (n (prefs-view-nvalues self)) ; the # of preferenced
         ; (form (prefs-view-form self)) ; redundant
         (index (send cell 'tag))	; index into prefdefs list
         (d (elt (prefs-panel-prefdefs panel) index)) ; prefdef struct
         ; (next (mod (1+ index) n)) ; was the next cell in the list
         (value (send cell 'string-value)) ; the new value
	 )
    ;;
    ;;  if the value changed ...
    ;;
    (unless (send value
                  :is-equal-to
                  (send (prefs-panel-domain panel)
                        :object-for-key
                        (objc-constant-string-nsstringptr (prefdef-name d))))
      ;; If there's a constraint, sanity-check the value.

      ;; Mark the prefdef as changed
      (setf (prefdef-changed-p d) t)

      ;; Notify the apply and revert buttons
      (send (prefs-panel-revert-button panel-view) :set-enabled t)
      (send (prefs-panel-apply-button panel-view) :set-enabled t))))

;;
;;  - (void) prefsPanelView:applyPrefs
;;
(define-objc-method ((:void :apply-prefs sender) 
		     prefs-panel-view)
  (declare (ignore sender))
  (let* ((panel *prefs-panel*)		;(prefs-tab-panel self)
         (domain (prefs-panel-domain panel)))
    (dolist (d (prefs-panel-prefdefs panel))
      (when (prefdef-changed-p d)
	(let* ((cell (prefdef-cell d))
	       (key (send cell 'title))
	       (val (send cell 'string-value)))
	  (send domain :set-object val :for-key key)
	  (setf (prefdef-changed-p d) nil)
	  (funcall (prefdef-setfn d) domain))))
    (send domain 'synchronize)
    (send (prefs-panel-revert-button self) :set-enabled nil)
    (send (prefs-panel-apply-button self) :set-enabled nil)))

;;
;; - (void) prefsPanelView:revertPrefs
;;
(define-objc-method ((:void :revert-prefs sender) 
		     prefs-panel-view)
  (declare (ignore sender))
  (let* ((panel *prefs-panel*) ;(prefs-tab-panel self)
         (domain (prefs-panel-domain panel)))
    (dolist (d (prefs-panel-prefdefs panel))
      (when (prefdef-changed-p d)
	(let* ((cell (prefdef-cell d))
	       (key (send cell 'title)))
	  (send cell :set-string-value (send domain :object-for-key key))
	  (setf (prefdef-changed-p d) nil))))
    (send domain 'synchronize)
    (send (prefs-panel-revert-button self) :set-enabled nil)
    (send (prefs-panel-apply-button self) :set-enabled nil)))

;;
;;  - (id) prefsPanelView:initWithFrame
;;
(define-objc-method ((:id :init-with-frame (:<NSR>ect frame))
                     prefs-panel-view)
    (send-super :init-with-frame frame)
  (slet ((tab-frame (ns-make-rect 0.0f0 30.0f0 (- (pref frame :<NSR>ect.size.width) 0.0f0) (- (pref frame :<NSR>ect.size.height) 30.0f0))))
    (let* ((tab-view (make-instance 'ns:ns-tab-view :with-frame tab-frame))) 
      (setf (prefs-panel-tab-view self) tab-view)
      (send tab-view :set-autoresizing-mask #$NSViewHeightSizable)
      (send tab-view :set-autoresizes-subviews 1)
      (slet ((revert-frame (ns-make-rect 20.0f0 5.0f0 80.0f0 20.0f0))
             (apply-frame (ns-make-rect (- (+ (pref frame :<NSR>ect.origin.x)
					      (pref frame :<NSR>ect.size.width))
					   (+ 80.0f0 20.0f0))
					5.0f0
					80.0f0
					20.0f0)))
        (let* ((apply-button (make-instance 'ns:ns-button :with-frame apply-frame))
               (revert-button (make-instance 'ns:ns-button :with-frame revert-frame)))
          (send apply-button :set-title #@"Apply")
          (send revert-button :set-title #@"Revert")
          (send apply-button :set-enabled nil)
          (send revert-button :set-enabled nil)
          (send apply-button :set-action (@selector "applyPrefs:"))
          (send apply-button :set-target self)
          (send revert-button :set-action (@selector "revertPrefs:"))
          (send revert-button :set-target self)
          (send apply-button :set-autoresizing-mask #$NSViewMinXMargin)
          (send revert-button :set-autoresizing-mask #$NSViewMaxXMargin)
          (send revert-button :set-bezel-style #$NSRoundedBezelStyle)
          (send apply-button :set-bezel-style #$NSRoundedBezelStyle)
          (setf (prefs-panel-revert-button self) revert-button
                (prefs-panel-apply-button self) apply-button)
          (send self :add-subview revert-button)
          (send self :add-subview apply-button)
          (send self :add-subview tab-view)
          self)))))


;;
;; @class prefs-panel
;;


;;
;;  - (id) prefsPanel:sharedPanel
;;
(define-objc-class-method ((:id shared-panel) 
			   preferences-panel)
  (cond (*prefs-panel*)
        (t
         (let* ((panel (new-cocoa-window :class self
                                         :title "New Preferences"
					 :width 600
					 :height 500
                                         :activate nil)))
           (slet ((bounds (send (send panel 'content-view) 'bounds)))
		 (let* ((v (make-instance 'prefs-panel-view :with-frame bounds)))
		   (send panel :set-content-view v)
		   (send v :set-needs-display t)
		   (setf (prefs-panel-view panel) v)
		   (setq *prefs-panel* panel)))
	   (setf (prefs-panel-domain panel) (send (@class "NSUserDefaults") 'standard-user-defaults))
	   (import-cocoa-defaults (prefs-panel-prefdefs panel))
	   (import-hemlock-defaults (prefs-panel-prefdefs panel))
	   panel))))

;;
;; - (id) prefsPanel:init
;;
(define-objc-method ((:id init)
		     preferences-panel)
  (let* ((class (class-of self)))
    (send self 'dealloc)
    (send class 'shared-panel)))


;;
;; create a tab-view-item
;;
(defmethod panel-init-tab-view ((panel preferences-panel) id)
  (let* ((tab-view-item (make-instance 'prefs-tab-view-item :with-identifier id))
	 (panel-view (prefs-panel-view panel))
	 (tab-view (prefs-panel-tab-view panel-view)))
    (slet ((frame (send tab-view 'bounds)))
      (let* ((scroll-view (make-instance 'ns:ns-scroll-view :with-frame frame))
	     (scroll-content (send scroll-view 'content-view)))
	(send scroll-view :set-border-type #$NSBezelBorder)
	(send scroll-view :set-has-vertical-scroller t)
	(send scroll-view :set-has-horizontal-scroller nil)
	(send scroll-view :set-rulers-visible nil)
	(send scroll-view :set-autoresizing-mask #$NSViewHeightSizable)
	(send tab-view-item :set-view scroll-view)
	(setf (prefs-tab-scroll-view tab-view-item) scroll-view)
	(setf (prefs-tab-panel tab-view-item) panel)
	(send scroll-content :set-autoresizes-subviews t)
	(slet* ((contentsize (send scroll-view 'content-size))
		(form-frame (ns-make-rect
			     0.0f0
			     0.0f0
			     (pref contentsize :<NSS>ize.width)
       			     (pref contentsize :<NSS>ize.height))))
	       (let* ((form (make-instance 'ns:ns-form :with-frame form-frame)))
		 (send form :set-scrollable t)
		 (send form :set-intercell-spacing (ns-make-size 1.0f0 4.0f0))
		 (send form :set-cell-size (ns-make-size 500.0f0 22.0f0))
		 (send form :set-autoresizing-mask (logior
						    #$NSViewWidthSizable
						    #$NSViewHeightSizable))
		 (setf (prefs-tab-form-view tab-view-item) form)
		 (send scroll-view :set-document-view form)))
	(send tab-view :add-tab-view-item tab-view-item)
	tab-view-item))))

;;
;;  create a tab-view-item and attach it to the form
;;
(defmethod make-prefs-tab-view-item ((panel preferences-panel) id name)
  (let ((tab (panel-init-tab-view panel (objc-constant-string-nsstringptr (ns-constant-string id)))))
    (send tab :set-label (objc-constant-string-nsstringptr (ns-constant-string name)))
    tab))

;;
;; INIT-FROM-PREFDEFS - loop through the prefdefs list and build the
;; tabbed lists. For each variable, look in the user defaults object
;; for a value; if we don't find one then use the predefined value.
;;
(defmethod init-from-prefdefs ((panel preferences-panel))
  (let ((tabs (prefs-panel-tabs panel))
	(domain (prefs-panel-domain panel))
	(i 0))
    (dolist (d (prefs-panel-prefdefs panel))
      (let* ((key (objc-constant-string-nsstringptr (prefdef-name d)))
	     (val (send domain :object-for-key key))
	     (tab (cdr (assoc (prefdef-pane d) tabs)))
	     (form  (prefs-tab-form-view tab))
	     (cell (send form :add-entry key)))
	(setf (prefdef-cell d) cell)
	(when (%null-ptr-p val)
	  (send domain
		:set-object (setq val (%make-nsstring (format nil "~a" (funcall (prefdef-getfn d)))))
		:for-key key))
	(set-form-cell-from-cocoa-pref tab ; the tab view
				       cell ; a new form cell
				       (prefdef-doc d) ; the lisp definition
				       (prefdef-valtype d) ; the lisp definition
				       form   ; the form view
				       val    ; the value
				       i)
	(incf i)))))


;;
;;  - (id) prefsPanel:show - show the preferences panel
;;  This method creates the tabs when executed for the first time,
;;  We call size-to-cells every time because large frames don't seem
;;  to size correctly on the first try. That may be because of the length
;;  if the list (163 items).
;;
(define-objc-method ((:void show)
		     preferences-panel)
  (send self :make-key-and-order-front (%null-ptr))
  (unless (prefs-panel-tabs self)
    (let* ((general-tab (make-prefs-tab-view-item self "1" "General"))
	   (hemlock-tab (make-prefs-tab-view-item self "2" "Hemlock Variables")))
      (setf (prefs-panel-tabs self) `((:general . ,general-tab)
				      (:hemlock . ,hemlock-tab)))
      (init-from-prefdefs self)))
  (send (prefs-tab-form-view (cdr (assoc :general (prefs-panel-tabs self)))) 'size-to-cells)
  (send (prefs-tab-form-view (cdr (assoc :hemlock (prefs-panel-tabs self)))) 'size-to-cells))