(in-package :win32)

#! (:library "User32" :ignore "WINUSERAPI" :export t :pascal "WINAPI")
/*
 * Flags for TrackPopupMenu
 */
#define TPM_LEFTBUTTON  	0x0000L
#define TPM_RIGHTBUTTON 	0x0002L
#define TPM_LEFTALIGN   	0x0000L
#define TPM_CENTERALIGN 	0x0004L
#define TPM_RIGHTALIGN  	0x0008L
#define TPM_TOPALIGN        0x0000L
#define TPM_VCENTERALIGN    0x0010L
#define TPM_BOTTOMALIGN     0x0020L
#define TPM_HORIZONTAL      0x0000L     /* Horz alignment matters more */
#define TPM_VERTICAL        0x0040L     /* Vert alignment matters more */
#define TPM_NONOTIFY        0x0080L     /* Don't send any notification msgs */
#define TPM_RETURNCMD       0x0100L
#define TPM_RECURSE         0x0001L
#define TPM_HORPOSANIMATION 0x0400L
#define TPM_HORNEGANIMATION 0x0800L
#define TPM_VERPOSANIMATION 0x1000L
#define TPM_VERNEGANIMATION 0x2000L
#define TPM_NOANIMATION     0x4000L
#define TPM_LAYOUTRTL       0x8000L

WINUSERAPI HMENU WINAPI CreatePopupMenu();
WINUSERAPI int WINAPI TrackPopupMenu(HMENU hMenu, unsigned int uFlags, int x, int y, 
	int nReserved, HWND hWnd, CONST RECT *prcRect);
WINUSERAPI BOOL WINAPI AttachThreadInput(DWORD idAttach, DWORD idAttachTo, BOOL fAttach);
!#

(defun pretty-print-selection (form)
	(let ((*print-case* :downcase)
		  (*print-pretty* t))
		(cl::editor-replace-selection (format nil "~S" form))))
	
(defun ccl::ide-context-menu (x y win)
	(let* ((menu (CreatePopupMenu))
		   (selection (ccl::get-selection))
		   (func-list nil)
		   (index 0))
			(if (null selection) (return-from ccl::ide-context-menu))	;; no menu items		
			(multiple-value-bind (selected-form err)
			(ignore-errors (read-from-string selection))
			(when (and (not (typep err 'error)) (symbolp selected-form))
				(win::AppendMenu menu
					(logior win::MF_ENABLED win::MF_STRING)
					(incf index)
					(ct:create-c-string (format nil "Documentation for ~A" selected-form)))
				(push #'(lambda () (documentation selected-form)) func-list))
			(when (and (not (typep err 'error)) (symbolp selected-form)
					(fboundp selected-form)
					(functionp (symbol-function selected-form))
					(ccl:function-source-file (symbol-function selected-form)))
				(win::AppendMenu menu
					(logior win::MF_ENABLED win::MF_STRING)
					(incf index)
					(ct:create-c-string (format nil "Lookup source for ~A" selected-form)))
				(push #'(lambda () (db:find-source selected-form)) func-list))
			(when (not (typep err 'error))
				(win::AppendMenu menu
					(logior win::MF_ENABLED win::MF_STRING)
					(incf index)
					(ct:create-c-string (format nil "Pretty-Print Selection")))
				(push #'(lambda () (pretty-print-selection selected-form)) func-list))
			(setf func-list (nreverse func-list))
			(if (null func-list) (return-from ccl::ide-context-menu))	;; no menu items		
			(let ((ret
				(TrackPopupMenu menu (logior TPM_LEFTALIGN TPM_RIGHTBUTTON TPM_NONOTIFY TPM_RETURNCMD)
					x y 0 win ct:null)))
				(ignore-errors (funcall (nth (- ret 1) func-list)))
				ret))))

(ct:defun-direct-c-callback pl::on-context-menu ((x :long)(y :long)(win (:void *)))
	(ccl::ide-context-menu x y win))

(ct:defun-direct-c-callback pl::on-heap-size ((generation :long)(capacity (:long *))(used (:long *)))
	(multiple-value-bind (percent total current)
		(cl::heap-used generation)
		(setf (ct:cref (:long *) capacity 0) total)
		(setf (ct:cref (:long *) used 0) current)
		percent))

;;; Given a string, see if it represents a known symbol. Don't intern
;;; the symbol, if it doesn't exist. This is used to lookup arbitrary strings
;;; from the IDE, and we don't want to intern stuff that doesn't normally
;;; get evaluated.
;;; If found, return the symbol, otherwise return the integer 0.
;;;
(defun lookup-symbol (string)
	(let ((package-chars nil)
		  (symbol-chars nil)
		  (package-markers 0)
		  (package-name nil)
		  (symbol-name nil)
		  (marker-pos (position #\: string))
		  (length (length string)))
		
		(unless marker-pos
			(multiple-value-bind (sym found)
				(find-symbol (string-upcase string) *package*)
				(return-from lookup-symbol (if found sym 0))))
		
		;; handle explicit package
		(setq package-chars (subseq string 0 marker-pos))						
		(incf package-markers)
		(incf marker-pos)
		(when (and (< marker-pos length) (eq (char string marker-pos) #\:))
			(incf package-markers)
			(incf marker-pos))
		(setf symbol-chars (string-upcase (subseq string marker-pos length)))

		(if (> (length package-chars) 0)
			(setq package-name (string-upcase package-chars))
			(setq package-name "KEYWORD"))
		
		(if (> (length symbol-chars) 0)
			(setq symbol-name (string-upcase symbol-chars))
			(return-from lookup-symbol 0))

		(let ((package (find-package package-name)))
			(if (null package)
				(return-from lookup-symbol 0))
			(multiple-value-bind (sym state)
				(find-symbol symbol-name package)
				(if (and (= package-markers 1) (not (eq state ':external)))
					0
					(if state sym 0))))))
		
(ct:defun-direct-c-callback ccl::lookup-lambda-list ((symName (:char *))(buf (:char *))(bufLength :long))
	(setf (ct:cref (:char *) buf 0) 0)     ;; initialize to empty string
    (ignore-errors
        (let ((sym (lookup-symbol (ct:c-string-to-lisp-string symName))))
    		(if (and (symbolp sym)(fboundp sym))
    			(let ((func (symbol-function sym))
    				  (lambda-list nil)
    				  (function-type "Function"))
    				(if (macro-function sym)
    					(setf lambda-list (ccl::macro-lambda-list func) function-type "Macro")
    					(if (cl::standard-generic-function-p func)
    						(setf lambda-list (generic-function-lambda-list func) function-type "Generic-Function")
    						(setf lambda-list (ccl:function-lambda-list func))))
    				(do* ((astr (format nil "~{~A ~}" lambda-list))
    					  (str (format nil "~A ~A[~A]" sym (string-downcase astr) function-type))
    					  (n 0 (+ n 1))
    					  (len (min (length str) (- bufLength 1))))
    					((= n len)(setf (ct:cref (:char *) buf n) 0) n)
    					(setf (ct:cref (:char *) buf n) (char-int (char str n)))))
    			0))))

(ct:defun-direct-c-callback ccl::load_file ((path (:char *)))
	(load (ct:c-string-to-lisp-string path)))

(ct:defun-direct-c-callback ccl::f001 ((x :long)(y :long))
	(* x y))