Ignore:
Timestamp:
Sep 8, 2009, 1:13:45 PM (10 years ago)
Author:
gfoy
Message:

Another new file, and mods to context-menu-cm.lisp.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/contrib/foy/context-menu-cm/context-menu-cm.lisp

    r12735 r12779  
    1 ;;;-*-Mode: LISP; Package: CONTEXT-MENU -*-
    21
    3 ;;; ----------------------------------------------------------------------------
    4 ;;;
    5 ;;;      context-menu-cm.lisp
    6 ;;;
    7 ;;;      copyright (c) 2009 Glen Foy
    8 ;;;      (Permission is granted to Clozure Associates to distribute this file.)
    9 ;;;
    10 ;;;      This code provides a mechanism for switching the tool that has access to
    11 ;;;      Hemlock's contextual popup menu.  This is an initial prototype, implementing
    12 ;;;      what may be the simplest approach.
    13 ;;;
    14 ;;;      The API for writing new tools is described in the accompanying NewTools file.
    15 ;;;
    16 ;;;      This software is offered "as is", without warranty of any kind.
    17 ;;;
    18 ;;;      Mod History, most recent first:
    19 ;;;      9/2/9   Changed the appearance of the Default Tool submenu.
    20 ;;;      8/31/9  version 0.1b1
    21 ;;;              First cut
    22 ;;;              Numerous User Interface suggestions, Rainer Joswig
    23 ;;;
    24 ;;; ----------------------------------------------------------------------------
     2;;; context-menu-cm.lisp
    253
    26 (defpackage "CONTEXT-MENU" (:nicknames "CMENU") (:use :cl :ccl))
    27 (in-package "CONTEXT-MENU")
     4(in-package :common-lisp-user)
    285
    29 (export '(register-tool add-default-tool-menu update-tool-menu set-default-tool
    30           tool-menu *hemlock-menu-dictionary* *tool-label-dictionary* *tool-doc-dictionary*
    31           *tool-key-dictionary* *dark-turquoise-color* *light-gray-color* check-hyperspec-availability))
    32 
    33 (defparameter *menu-manager* nil "The context-menu-manager instance.")
    34 
    35 (defparameter *dark-blue-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.2 0.2 0.5 1.0))
    36 (defparameter *dark-turquoise-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.28 0.28 1.0))
    37 (defparameter *wine-red-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.4 0.1 0.2 1.0))
    38 (defparameter *light-gray-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.92 0.92 0.92 1.0))
    39 
    40 (defparameter *hemlock-menu-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
    41 (#/setObject:forKey: *hemlock-menu-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    42 (#/setObject:forKey: *hemlock-menu-dictionary* *dark-blue-color* #&NSForegroundColorAttributeName)
    43 
    44 (defparameter *tool-label-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
    45 (#/setObject:forKey: *tool-label-dictionary* (#/systemFontOfSize: ns:ns-font (#/systemFontSize ns:ns-font)) #&NSFontAttributeName)
    46 (#/setObject:forKey: *tool-label-dictionary* *dark-turquoise-color* #&NSForegroundColorAttributeName)
    47 
    48 (defparameter *tool-doc-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
    49 (#/setObject:forKey: *tool-doc-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    50 (#/setObject:forKey: *tool-doc-dictionary* *dark-turquoise-color* #&NSForegroundColorAttributeName)
    51 
    52 (defparameter *tool-key-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
    53 (#/setObject:forKey: *tool-key-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    54 (#/setObject:forKey: *tool-key-dictionary* *wine-red-color* #&NSForegroundColorAttributeName)
    55 
    56 ;;; ----------------------------------------------------------------------------
    57 ;;;
    58 (defclass CONTEXT-MENU-MANAGER ()
    59   ((tool-alist :initform nil :accessor tool-alist)
    60    (default-tool :initform nil :accessor default-tool))
    61   (:documentation "A class to manage Hemlock's contextual popup menu, supporting access by multiple tools."))
    62 
    63 (defmethod display-menu ((manager context-menu-manager) view event)
    64   (when (default-tool manager)
    65     (let ((entry (assoc (default-tool manager) (tool-alist manager) :test #'string-equal)))
    66       (when entry
    67         (funcall (cdr entry) view event)))))
    68 
    69 (objc:defmethod #/menuForEvent: ((view gui::hemlock-text-view) (event :id))
    70   (display-menu *menu-manager* view event))
    71 
    72 (defun register-tool (tool-name menu-function)
    73   "Register the new tool with the menu-manager.  The last tool registered becomes the default tool."
    74   (let ((entry (find tool-name (tool-alist *menu-manager*) :test #'string-equal :key #'car)))
    75     (cond (entry
    76            (gui::alert-window :title "Notification" :message (format nil "Re-registering ~S." tool-name))
    77            (setf (tool-alist *menu-manager*) (delete tool-name (tool-alist *menu-manager*) :test #'string-equal :key #'car))
    78            (setf (tool-alist *menu-manager*) (cons (cons tool-name menu-function) (tool-alist *menu-manager*))))           
    79           (t
    80            (setf (tool-alist *menu-manager*) (cons (cons tool-name menu-function) (tool-alist *menu-manager*)))
    81            (setf (tool-alist *menu-manager*)
    82                  (sort (tool-alist *menu-manager*) #'string< :key #'car))
    83            (set-default-tool tool-name)))))
    84 
    85 (defun set-default-tool (tool-name)
    86   "Set the menu-manager's default tool.  Right-Click will display this tool's menu."
    87   (let ((registered-name (car (find tool-name (tool-alist *menu-manager*) :test #'string-equal :key #'car))))
    88     (if registered-name
    89       (setf (default-tool *menu-manager*) registered-name) ; keep the original capitalization
    90       (gui::alert-window :title "Notification" :message (format nil "~S is not a registered tool.  It can't be set as default." tool-name)))))
    91 
    92 ;;; ----------------------------------------------------------------------------
    93 ;;;
    94 (defclass DEFAULT-TOOL-MENU-ITEM (ns:ns-menu-item)
    95   ((name :accessor tool-name)) ; Lisp string
    96   (:documentation "Support for the Tool submenu.")
    97   (:metaclass ns:+ns-object))
    98 
    99 ;;; ----------------------------------------------------------------------------
    100 ;;;
    101 (defclass DEFAULT-TOOL-DOC-MENU-ITEM (ns:ns-menu-item)
    102   ((filename :accessor tool-filename))
    103   (:documentation "A menu-item to display the default tool's documentation.")
    104   (:metaclass ns:+ns-object))
    105 
    106 ;;; ----------------------------------------------------------------------------
    107 ;;;
    108 (defclass DEFAULT-TOOL-MENU (ns:ns-menu)
    109   ()
    110   (:documentation "A submenu displaying all registered tools.")
    111   (:metaclass ns:+ns-object))
    112 
    113 (objc:defmethod (#/hemlockDefaultToolAction: :void) ((m default-tool-menu) (sender :id))
    114   (set-default-tool (tool-name sender)))
    115 
    116 (objc:defmethod (#/hemlockDefaultToolDocAction: :void) ((m default-tool-menu) (sender :id))
    117   (display-doc (tool-filename sender)))
    118 
    119 (defun display-doc (path)
    120   "Display the default tool's documentation."
    121   (when (probe-file path)
    122     (#/openFile:withApplication: (#/sharedWorkspace ns:ns-workspace)
    123                                  (ccl::%make-nsstring (namestring path))
    124                                  (ccl::%make-nsstring "TextEdit"))))
     6(unless (member "CONTEXT-MENU-CM" *modules* :test #'string-equal)
    1257 
    126 (defmethod populate-menu ((menu default-tool-menu))
    127   (dotimes (count (#/numberOfItems menu))
    128     (#/removeItemAtIndex: menu 0))
    129   (flet ((create-menu-item (name)
    130            (let ((menu-item (make-instance 'default-tool-menu-item))
    131                  (attributed-string (#/initWithString:attributes:
    132                                      (#/alloc ns:ns-attributed-string)
    133                                      (ccl::%make-nsstring name)
    134                                      *tool-label-dictionary*)))
    135              (setf (tool-name menu-item) name)
    136              (#/setAttributedTitle: menu-item attributed-string)
    137              (#/setAction: menu-item (ccl::@selector "hemlockDefaultToolAction:"))
    138              (#/setTarget: menu-item  menu)
    139              (if (string-equal name (default-tool *menu-manager*))
    140                (#/setState: menu-item #$NSOnState)
    141                (#/setState: menu-item #$NSOffState))
    142              (#/addItem: menu menu-item))))
    143     (dolist (entry (tool-alist *menu-manager*))
    144       (create-menu-item (car entry)))))
    145 
    146 (defun add-default-tool-menu (menu &key doc-file)
    147   "Add the default tool submenu and possibly a documentation menu-item to MENU."
    148   (let ((default-item (make-instance ns:ns-menu-item))
    149         (tool-menu (make-instance 'default-tool-menu)))
    150     ;; Title is set by update method.
    151     (#/setSubmenu: default-item tool-menu)
    152     (#/insertItem:atIndex: menu default-item 0)
    153     (cond (doc-file
    154            (let ((doc-item (make-instance 'default-tool-doc-menu-item))
    155                  (attributed-string (#/initWithString:attributes:
    156                                      (#/alloc ns:ns-attributed-string)
    157                                      (ccl::%make-nsstring (format nil "     doc..." (default-tool *menu-manager*)))
    158                                      *tool-doc-dictionary*)))
    159              (#/setAttributedTitle: doc-item attributed-string)
    160              (#/setAction: doc-item (ccl::@selector "hemlockDefaultToolDocAction:"))
    161              (#/setTarget: doc-item  tool-menu)
    162              (setf (tool-filename doc-item) doc-file)
    163              (#/insertItem:atIndex: menu doc-item 1))
    164           (#/insertItem:atIndex: menu (#/separatorItem ns:ns-menu-item) 2))
    165           (t
    166            (#/insertItem:atIndex: menu (#/separatorItem ns:ns-menu-item) 1)))
    167     tool-menu))
    168 
    169 (defun update-tool-menu (menu default-menu &key sub-title)
    170   "Update MENU's Tool submenu."
    171   (let ((first-item (#/itemAtIndex: menu 0))
    172         (attributed-string (#/initWithString:attributes:
    173                             (#/alloc ns:ns-attributed-string)
    174                             (if sub-title
    175                               (ccl::%make-nsstring (format nil "~S
    176     (~A)" (default-tool *menu-manager*) sub-title))
    177                               (ccl::%make-nsstring (format nil "~S" (default-tool *menu-manager*))))
    178                             *tool-label-dictionary*)))
    179     (#/setAttributedTitle: first-item attributed-string)
    180     (populate-menu default-menu)))
    181 
    182 (let (checked-p)
    183 (defun check-hyperspec-availability (tool-name)
    184   "Some tools require the HyperSpec."
    185   (unless (or checked-p gui::*hyperspec-root-url*)
    186     (rlet ((perror :id  +null-ptr+))
    187       (let* ((map-url (make-instance 'ns:ns-url :with-string #@"Data/Map_Sym.txt" :relative-to-url (gui::hyperspec-root-url)))
    188              ;; kludge alert:
    189              (data (make-instance 'ns:ns-data
    190                      :with-contents-of-url map-url
    191                      :options 0
    192                      :error perror)))
    193         (declare (ignore data))
    194         (setq checked-p t)
    195         (unless (%null-ptr-p (pref perror :id))
    196           (gui::alert-window
    197            :title "Notification"
    198            :message (format nil "~S needs the HyperSpec, and it does not appear to be available. Check the documentation in the Context-Menu-CM/ReadMe, and restart CCL." tool-name))))))))
    199 
    200 (setq *menu-manager* (make-instance 'context-menu-manager))
     8(eval-when (:load-toplevel :execute)
     9  (defParameter *context-menu-directory*
     10    (make-pathname :name nil :type nil :defaults (if *load-pathname*
     11                                                     *load-pathname*
     12                                                     *loading-file-source-file*)))
     13  (defParameter *context-menu-files*
     14    (list (merge-pathnames ";context-menu.lisp" *context-menu-directory*)
     15          (merge-pathnames ";context-menu-dialogs.lisp" *context-menu-directory*))))
     16 
     17(dolist (file *context-menu-files*)
     18  (load file))
    20119
    20220(provide :context-menu-cm)
    20321
    204 
     22)
Note: See TracChangeset for help on using the changeset viewer.