source: trunk/ccl/cocoa-ide/cocoa-prefs.lisp @ 7139

Last change on this file since 7139 was 7139, checked in by gb, 12 years ago

Suppress warnings about *MODELINE-FONT-NAME*, -SIZE*.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 7.4 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2004 Clozure Associates
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19(eval-when (:compile-toplevel :execute)
20  (use-interface-dir :cocoa))
21
22
23(defloadvar *lisp-preferences-panel* nil)
24
25(defclass lisp-preferences-panel (ns:ns-panel)
26    ()
27  (:metaclass ns:+ns-object))
28
29(defclass font-name-transformer (ns:ns-value-transformer)
30    ()
31  (:metaclass ns:+ns-object))
32
33(objc:defmethod #/transformedNameClass ((self +font-name-transformer))
34  ns:ns-string)
35
36
37(objc:defmethod (#/allowsReverseTransformation :<BOOL>)
38    ((self +font-name-transformer))
39  nil)
40
41(objc:defmethod #/transformValue ((self font-name-transformer) value)
42  ;; Is there any better way of doing this that doesn't involve
43  ;; making a font ?
44  (#/displayName (make-instance ns:ns-font
45                                :with-name value
46                                :size (float 12.0 +cgfloat-zero+))))
47
48
49
50(defclass lisp-preferences-window-controller (ns:ns-window-controller)
51    ()
52  (:metaclass ns:+ns-object))
53
54(objc:defmethod (#/fontPanelForDefaultFont: :void)
55    ((self lisp-preferences-window-controller) sender)
56  (let* ((fm (#/sharedFontManager ns:ns-font-manager)))
57    (#/setSelectedFont:isMultiple: fm (default-font) nil)
58    (#/setEnabled: fm t)
59    (#/setTarget: fm self)
60    (#/setAction: fm (@selector #/changeDefaultFont:)))
61  (#/orderFrontFontPanel: *NSApp* sender))
62
63
64(objc:defmethod (#/fontPanelForModelineFont: :void)
65                ((self lisp-preferences-window-controller) sender)
66  (declare (special *modeline-font-name* *modeline-font-size*))
67  (let* ((fm (#/sharedFontManager ns:ns-font-manager)))
68    (#/setSelectedFont:isMultiple: fm (default-font
69                                          :name *modeline-font-name*
70                                        :size *modeline-font-size*)
71                                   nil)
72    (#/setTarget: fm self)
73    (#/setAction: fm (@selector #/changeModelineFont:)))
74  (#/orderFrontFontPanel: *NSApp* sender))
75
76
77(objc:defmethod (#/changeDefaultFont: :void) ((self lisp-preferences-window-controller) sender)
78  (let* ((f (#/convertFont: sender (default-font))))
79    (when (is-fixed-pitch-font f)
80      (let* ((values (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller))))
81        (#/setValue:forKey: values (#/fontName f) #@"defaultFontName")
82        (#/setValue:forKey: values (#/stringWithFormat: ns:ns-string #@"%u" (round (#/pointSize f))) #@"defaultFontSize")))))
83
84(objc:defmethod (#/changeModelineFont: :void) ((self lisp-preferences-window-controller) sender)
85  (declare (special *modeline-font-name* *modeline-font-size*))
86  (let* ((f (#/convertFont: sender (default-font
87                                          :name *modeline-font-name*
88                                        :size *modeline-font-size*))))
89    (when (is-fixed-pitch-font f)
90      (let* ((values (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller))))
91        (#/setValue:forKey: values (#/fontName f) #@"modelineFontName:")
92        (#/setValue:forKey: values (#/stringWithFormat: ns:ns-string #@"%u" (round (#/pointSize f))) #@"modelineFontSize")))))
93
94
95(objc:defmethod (#/changeColor: :void) ((self lisp-preferences-panel)
96                                        sender)
97  (declare (ignore sender)))
98
99
100(objc:defmethod (#/selectHyperspecFileURL: :void)
101    ((self lisp-preferences-window-controller)
102     sender)
103  (declare (ignore sender))
104  (let* ((panel (make-instance 'ns:ns-open-panel))
105         (values (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller))))
106    (#/setAllowsMultipleSelection: panel nil)
107    (#/setCanChooseDirectories: panel t)
108    (#/setCanChooseFiles: panel nil)
109    (when (eql
110           (#/runModalForDirectory:file:types:
111            panel
112            (#/valueForKey: values #@"hyperspecFileURLString")
113            +null-ptr+
114            +null-ptr+)
115           #$NSOKButton)
116      (let* ((filename (#/objectAtIndex: (#/filenames panel) 0)))
117        (#/setValue:forKey: values filename #@"hyperspecFileURLString")))))
118
119(objc:defmethod (#/selectCCLdirectory: :void)
120    ((self lisp-preferences-window-controller)
121     sender)
122  (declare (ignore sender))
123  (let* ((panel (make-instance 'ns:ns-open-panel))
124         (values (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller))))
125    (#/setAllowsMultipleSelection: panel nil)
126    (#/setCanChooseDirectories: panel t)
127    (#/setCanChooseFiles: panel nil)
128    (when (eql
129           (#/runModalForDirectory:file:types:
130            panel
131            (#/valueForKey: values #@"cclDirectory")
132            +null-ptr+
133            +null-ptr+)
134           #$NSOKButton)
135      (let* ((filename (#/pathWithComponents: ns:ns-string
136                                              (#/arrayWithObjects:
137                                               ns:ns-array
138                                               (#/objectAtIndex: (#/filenames panel) 0)
139                                               #@""
140                                               +null-ptr+))))
141        (#/setValue:forKey: values filename #@"cclDirectory")))))
142
143
144
145(objc:defmethod #/sharedPanel ((self +lisp-preferences-panel))
146  (cond (*lisp-preferences-panel*)
147        (t
148         (let* ((domain (#/standardUserDefaults ns:ns-user-defaults))
149                (initial-values (cocoa-defaults-initial-values)))
150           (#/registerDefaults: domain initial-values)
151           (update-cocoa-defaults)
152           (#/setValueTransformer:forName:
153            ns:ns-value-transformer
154            (make-instance 'font-name-transformer)
155            #@"FontNameTransformer")
156           (let* ((sdc (#/sharedUserDefaultsController ns:ns-user-defaults-controller)))
157             (#/setAppliesImmediately: sdc nil)
158             (#/setInitialValues: sdc initial-values)
159             (let* ((controller (make-instance lisp-preferences-window-controller
160                                             :with-window-nib-name #@"preferences"))
161                  (window (#/window controller)))
162               (unless (%null-ptr-p window)
163                 (#/setFloatingPanel: window t)
164                 (#/addObserver:selector:name:object:
165                  (#/defaultCenter ns:ns-notification-center)
166                  controller
167                  (@selector #/defaultsChanged:)
168                  #&NSUserDefaultsDidChangeNotification
169                  (#/standardUserDefaults ns:ns-user-defaults))
170                 (setq *lisp-preferences-panel* window))))))))
171
172 
173(objc:defmethod #/init ((self lisp-preferences-panel))
174  (let* ((class (class-of self)))
175    (#/dealloc self)
176    (#/sharedPanel class)))
177
178
179(objc:defmethod (#/makeKeyAndOrderFront: :void)
180    ((self lisp-preferences-panel) sender)
181  (let* ((color-panel (#/sharedColorPanel ns:ns-color-panel)))
182    (#/close color-panel)
183    (#/setAction: color-panel +null-ptr+)
184    (#/setShowsAlpha: color-panel t))
185  (call-next-method sender))
186
187(objc:defmethod (#/show :void) ((self lisp-preferences-panel))
188  (#/makeKeyAndOrderFront: self +null-ptr+))
189
190(objc:defmethod (#/defaultsChanged: :void)
191    ((self lisp-preferences-window-controller)
192     notification)
193  (declare (ignore notification))
194  (update-cocoa-defaults))
195 
196
197
Note: See TracBrowser for help on using the repository browser.