source: branches/working-0711/ccl/cocoa-ide/cocoa-prefs.lisp @ 7804

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

sync with trunk

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 7.2 KB
Line 
1;;;-*-Mode: LISP; Package: GUI -*-
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 "GUI")
18
19(defloadvar *lisp-preferences-panel* nil)
20
21(defclass lisp-preferences-panel (ns:ns-panel)
22    ()
23  (:metaclass ns:+ns-object))
24
25(defclass font-name-transformer (ns:ns-value-transformer)
26    ()
27  (:metaclass ns:+ns-object))
28
29(objc:defmethod #/transformedNameClass ((self +font-name-transformer))
30  ns:ns-string)
31
32
33(objc:defmethod (#/allowsReverseTransformation :<BOOL>)
34    ((self +font-name-transformer))
35  nil)
36
37(objc:defmethod #/transformValue ((self font-name-transformer) value)
38  ;; Is there any better way of doing this that doesn't involve
39  ;; making a font ?
40  (#/displayName (make-instance ns:ns-font
41                                :with-name value
42                                :size (cgfloat 12.0))))
43
44
45
46(defclass lisp-preferences-window-controller (ns:ns-window-controller)
47    ()
48  (:metaclass ns:+ns-object))
49(declaim (special lisp-preferences-window-controller))
50
51(objc:defmethod (#/fontPanelForDefaultFont: :void)
52    ((self lisp-preferences-window-controller) sender)
53  (let* ((fm (#/sharedFontManager ns:ns-font-manager)))
54    (#/setSelectedFont:isMultiple: fm (default-font) nil)
55    (#/setEnabled: fm t)
56    (#/setTarget: fm self)
57    (#/setAction: fm (@selector #/changeDefaultFont:)))
58  (#/orderFrontFontPanel: *NSApp* sender))
59
60
61(objc:defmethod (#/fontPanelForModelineFont: :void)
62                ((self lisp-preferences-window-controller) sender)
63  (declare (special *modeline-font-name* *modeline-font-size*))
64  (let* ((fm (#/sharedFontManager ns:ns-font-manager)))
65    (#/setSelectedFont:isMultiple: fm (default-font
66                                          :name *modeline-font-name*
67                                        :size *modeline-font-size*)
68                                   nil)
69    (#/setTarget: fm self)
70    (#/setAction: fm (@selector #/changeModelineFont:)))
71  (#/orderFrontFontPanel: *NSApp* sender))
72
73
74(objc:defmethod (#/changeDefaultFont: :void) ((self lisp-preferences-window-controller) sender)
75  (let* ((f (#/convertFont: sender (default-font))))
76    (when (is-fixed-pitch-font f)
77      (let* ((values (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller))))
78        (#/setValue:forKey: values (#/fontName f) #@"defaultFontName")
79        (#/setValue:forKey: values (#/stringWithFormat: ns:ns-string #@"%u" (round (#/pointSize f))) #@"defaultFontSize")))))
80
81(objc:defmethod (#/changeModelineFont: :void) ((self lisp-preferences-window-controller) sender)
82  (declare (special *modeline-font-name* *modeline-font-size*))
83  (let* ((f (#/convertFont: sender (default-font
84                                          :name *modeline-font-name*
85                                        :size *modeline-font-size*))))
86    (when (is-fixed-pitch-font f)
87      (let* ((values (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller))))
88        (#/setValue:forKey: values (#/fontName f) #@"modelineFontName")
89        (#/setValue:forKey: values (#/stringWithFormat: ns:ns-string #@"%u" (round (#/pointSize f))) #@"modelineFontSize")))))
90
91
92(objc:defmethod (#/changeColor: :void) ((self lisp-preferences-panel)
93                                        sender)
94  (declare (ignore sender)))
95
96
97(objc:defmethod (#/selectHyperspecFileURL: :void)
98    ((self lisp-preferences-window-controller)
99     sender)
100  (declare (ignore sender))
101  (let* ((panel (make-instance 'ns:ns-open-panel))
102         (values (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller))))
103    (#/setAllowsMultipleSelection: panel nil)
104    (#/setCanChooseDirectories: panel t)
105    (#/setCanChooseFiles: panel nil)
106    (when (eql
107           (#/runModalForDirectory:file:types:
108            panel
109            (#/valueForKey: values #@"hyperspecFileURLString")
110            +null-ptr+
111            +null-ptr+)
112           #$NSOKButton)
113      (let* ((filename (#/objectAtIndex: (#/filenames panel) 0)))
114        (#/setValue:forKey: values filename #@"hyperspecFileURLString")))))
115
116(objc:defmethod (#/selectCCLdirectory: :void)
117    ((self lisp-preferences-window-controller)
118     sender)
119  (declare (ignore sender))
120  (let* ((panel (make-instance 'ns:ns-open-panel))
121         (values (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller))))
122    (#/setAllowsMultipleSelection: panel nil)
123    (#/setCanChooseDirectories: panel t)
124    (#/setCanChooseFiles: panel nil)
125    (when (eql
126           (#/runModalForDirectory:file:types:
127            panel
128            (#/valueForKey: values #@"cclDirectory")
129            +null-ptr+
130            +null-ptr+)
131           #$NSOKButton)
132      ;; #/stringByStandardizingPath seems to strip trailing slashes
133      (let* ((filename (#/stringByAppendingString:
134                        (#/stringByStandardizingPath (#/objectAtIndex: (#/filenames panel) 0))
135                         #@"/")))
136        (#/setValue:forKey: values filename #@"cclDirectory")))))
137
138
139
140(objc:defmethod #/sharedPanel ((self +lisp-preferences-panel))
141  (cond (*lisp-preferences-panel*)
142        (t
143         (let* ((domain (#/standardUserDefaults ns:ns-user-defaults))
144                (initial-values (cocoa-defaults-initial-values)))
145           (#/registerDefaults: domain initial-values)
146           (update-cocoa-defaults)
147           (#/setValueTransformer:forName:
148            ns:ns-value-transformer
149            (make-instance 'font-name-transformer)
150            #@"FontNameTransformer")
151           (let* ((sdc (#/sharedUserDefaultsController ns:ns-user-defaults-controller)))
152             (#/setAppliesImmediately: sdc nil)
153             (#/setInitialValues: sdc initial-values)
154             (let* ((controller (make-instance lisp-preferences-window-controller
155                                             :with-window-nib-name #@"preferences"))
156                    (window (#/window controller)))
157               (unless (%null-ptr-p window)
158                 (#/setFloatingPanel: window t)
159                 (#/addObserver:selector:name:object:
160                  (#/defaultCenter ns:ns-notification-center)
161                  controller
162                  (@selector #/defaultsChanged:)
163                  #&NSUserDefaultsDidChangeNotification
164                  (#/standardUserDefaults ns:ns-user-defaults))
165                 (setq *lisp-preferences-panel* window))))))))
166
167 
168(objc:defmethod #/init ((self lisp-preferences-panel))
169  (let* ((class (class-of self)))
170    (#/dealloc self)
171    (#/sharedPanel class)))
172
173
174(objc:defmethod (#/makeKeyAndOrderFront: :void)
175    ((self lisp-preferences-panel) sender)
176  (let* ((color-panel (#/sharedColorPanel ns:ns-color-panel)))
177    (#/close color-panel)
178    (#/setAction: color-panel +null-ptr+)
179    (#/setShowsAlpha: color-panel t))
180  (call-next-method sender))
181
182(objc:defmethod (#/show :void) ((self lisp-preferences-panel))
183  (#/makeKeyAndOrderFront: self +null-ptr+))
184
185(objc:defmethod (#/defaultsChanged: :void)
186    ((self lisp-preferences-window-controller)
187     notification)
188  (declare (ignore notification))
189  (update-cocoa-defaults))
190 
191
192
Note: See TracBrowser for help on using the repository browser.