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

Last change on this file since 7476 was 7476, checked in by gb, 13 years ago

make modeline font pref work

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 7.3 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      ;; #/stringByStandardizingPath seems to strip trailing slashes
136      (let* ((filename (#/stringByAppendingString:
137                        (#/stringByStandardizingPath (#/objectAtIndex: (#/filenames panel) 0))
138                         #@"/")))
139        (#/setValue:forKey: values filename #@"cclDirectory")))))
140
141
142
143(objc:defmethod #/sharedPanel ((self +lisp-preferences-panel))
144  (cond (*lisp-preferences-panel*)
145        (t
146         (let* ((domain (#/standardUserDefaults ns:ns-user-defaults))
147                (initial-values (cocoa-defaults-initial-values)))
148           (#/registerDefaults: domain initial-values)
149           (update-cocoa-defaults)
150           (#/setValueTransformer:forName:
151            ns:ns-value-transformer
152            (make-instance 'font-name-transformer)
153            #@"FontNameTransformer")
154           (let* ((sdc (#/sharedUserDefaultsController ns:ns-user-defaults-controller)))
155             (#/setAppliesImmediately: sdc nil)
156             (#/setInitialValues: sdc initial-values)
157             (let* ((controller (make-instance lisp-preferences-window-controller
158                                             :with-window-nib-name #@"preferences"))
159                    (window (#/window controller)))
160               (unless (%null-ptr-p window)
161                 (#/setFloatingPanel: window t)
162                 (#/addObserver:selector:name:object:
163                  (#/defaultCenter ns:ns-notification-center)
164                  controller
165                  (@selector #/defaultsChanged:)
166                  #&NSUserDefaultsDidChangeNotification
167                  (#/standardUserDefaults ns:ns-user-defaults))
168                 (setq *lisp-preferences-panel* window))))))))
169
170 
171(objc:defmethod #/init ((self lisp-preferences-panel))
172  (let* ((class (class-of self)))
173    (#/dealloc self)
174    (#/sharedPanel class)))
175
176
177(objc:defmethod (#/makeKeyAndOrderFront: :void)
178    ((self lisp-preferences-panel) sender)
179  (let* ((color-panel (#/sharedColorPanel ns:ns-color-panel)))
180    (#/close color-panel)
181    (#/setAction: color-panel +null-ptr+)
182    (#/setShowsAlpha: color-panel t))
183  (call-next-method sender))
184
185(objc:defmethod (#/show :void) ((self lisp-preferences-panel))
186  (#/makeKeyAndOrderFront: self +null-ptr+))
187
188(objc:defmethod (#/defaultsChanged: :void)
189    ((self lisp-preferences-window-controller)
190     notification)
191  (declare (ignore notification))
192  (update-cocoa-defaults))
193 
194
195
Note: See TracBrowser for help on using the repository browser.