source: release/1.3/source/cocoa-ide/cocoa-doc.lisp @ 11789

Last change on this file since 11789 was 11789, checked in by rme, 12 years ago

Merge r11788 from trunk (fix to hyperspec-map-hash)

File size: 6.5 KB
Line 
1;;;-*-Mode: LISP; Package: GUI -*-
2;;;
3;;;   Copyright (C) 2007 Clozure Associates
4
5(in-package "GUI")
6
7(def-cocoa-default *hyperspec-url-string* :string "http://www.lispworks.com/documentation/HyperSpec/" "HTTP URL for HyperSpec lookup")
8
9(defloadvar *hyperspec-root-url* nil)
10(defloadvar *hyperspec-map-sym-hash* nil)
11(defloadvar *hyperspec-map-sym-url* nil)
12
13(def-cocoa-default *hyperspec-lookup-enabled* :bool nil "enables hyperspec lookup"
14                   (lambda (old new)
15                     (unless (eq new old)
16                       (if new
17                         (setup-hyperspec-root-url)
18                         (progn
19                           (when *hyperspec-root-url*
20                             (#/release *hyperspec-root-url*))
21                           (setq *hyperspec-root-url* nil)
22                           (when *hyperspec-map-sym-url*
23                             (#/release *hyperspec-map-sym-url*))
24                           (setq *hyperspec-root-url* nil)
25                           (setq *hyperspec-map-sym-hash* nil))))))
26
27
28(defclass display-document (ns:ns-document)
29    ((text-view :foreign-type :id))
30  (:metaclass ns:+ns-object))
31
32(defclass url-delegate (ns:ns-object)
33    ()
34  (:metaclass ns:+ns-object))
35
36(objc:defmethod (#/textView:clickedOnLink:atIndex: :<BOOL>)
37    ((self url-delegate)
38     textview
39     link
40     (index :<NSUI>nteger))
41  (declare (ignorable link))
42  (let* ((attribute (#/attribute:atIndex:effectiveRange:
43                     (#/textStorage textview)
44                     #&NSLinkAttributeName
45                     index
46                     +null-ptr+)))
47    (if (typep attribute 'ns:ns-url)
48      (rlet ((dictp :id +null-ptr+))
49        (let* ((data (make-instance 'ns:ns-data :with-contents-of-url attribute))
50               (string (unless (%null-ptr-p data)
51                         (make-instance 'ns:ns-attributed-string 
52                                        :with-html data
53                                        :base-url attribute
54                                        :document-attributes dictp)))
55               (textstorage (#/textStorage textview))
56               (dict (pref dictp :id))
57               (title (unless (%null-ptr-p dict)
58                        (#/valueForKey: dict #&NSTitleDocumentAttribute))))
59          (when title 
60            (#/setTitle: (#/window textview) title))
61          (when string
62            (#/beginEditing textstorage)
63            (#/replaceCharactersInRange:withAttributedString:
64             textstorage
65             (ns:make-ns-range 0 (#/length textstorage))
66             string)
67            (#/setSelectedRange: textview (ns:make-ns-range 0 0))
68            (#/endEditing textstorage)
69            (#/scrollRangeToVisible: textview (ns:make-ns-range 0 0)))))))
70  #$YES)
71
72(objc:defmethod (#/textView:shouldChangeTextInRange:replacementString: :<BOOL>)
73    ((self url-delegate)
74     textview
75     (range :<NSR>ange)
76     string)
77  (declare (ignorable textview range string))
78  nil)
79
80
81
82
83
84(objc:defmethod #/windowNibName ((self display-document))
85  #@"displaydoc")
86
87(objc:defmethod (#/windowControllerDidLoadNib: :void)
88    ((self display-document) controller)
89  (with-slots (text-view) self
90    (unless (%null-ptr-p text-view)
91      (#/setEditable: text-view t)
92      (#/setDelegate: text-view (make-instance 'url-delegate))))
93  (call-next-method controller))
94
95
96(defun hyperspec-root-url ()
97  (or *hyperspec-root-url*
98      (setq *hyperspec-root-url* (setup-hyperspec-root-url))))
99
100(defun setup-hyperspec-root-url ()
101  (make-instance 'ns:ns-url
102                 :with-string
103                 (%make-nsstring *hyperspec-url-string*)))
104
105(defun hyperspec-map-hash (document)
106  (or *hyperspec-map-sym-hash*
107      (rlet ((perror :id  +null-ptr+))
108        (let* ((map-url (make-instance 'ns:ns-url :with-string #@"Data/Map_Sym.txt" :relative-to-url (hyperspec-root-url)))
109               (data (make-instance 'ns:ns-data
110                                    :with-contents-of-url map-url
111                                    :options 0
112                                    :error perror)))
113          (let* ((err (pref perror :id)))
114            (unless (%null-ptr-p err)
115              (#/presentError: document err)
116              (return-from hyperspec-map-hash nil)))
117          (with-input-from-string (s (%str-from-ptr (#/bytes data) (#/length data)))
118            (let* ((hash (make-hash-table :test #'eq))
119                   (*package* (find-package "CL"))
120                   (eof (cons nil nil)))
121              (declare (dynamic-extent eof))
122              (loop
123                (let* ((sym (read s nil eof))
124                       (url (read-line s nil eof)))
125                  (when (eq sym eof)
126                    (return 
127                      (setq *hyperspec-map-sym-url* map-url
128                            *hyperspec-map-sym-hash* hash)))
129                  (setf (gethash sym hash) url)))))))))
130
131(defun lookup-hyperspec-symbol (symbol doc)
132  (let* ((relative-url (gethash symbol (hyperspec-map-hash doc))))
133    (when relative-url
134      (let* ((url (#/absoluteURL
135                   (make-instance 'ns:ns-url
136                                  :with-string (%make-nsstring relative-url)
137                                  :relative-to-url *hyperspec-map-sym-url*))))
138        (rlet ((pdocattrs :id +null-ptr+)
139               (perror :id  +null-ptr+))
140          (let* ((data (make-instance 'ns:ns-data
141                                      :with-contents-of-url url
142                                      :options 0
143                                      :error perror)))
144            (if (not (%null-ptr-p (pref perror :id)))
145              (progn
146                (#/presentError: doc (pref perror :id)))
147              (let* ((string (make-instance 'ns:ns-attributed-string
148                                            :with-html data
149                                            :base-url url
150                                            :document-attributes pdocattrs))
151                     (docattrs (pref pdocattrs :id))
152                     (title (if (%null-ptr-p docattrs)
153                              +null-ptr+
154                              (#/objectForKey: docattrs #&NSTitleDocumentAttribute))))
155                (if (%null-ptr-p title)
156                  (setq title (%make-nsstring (string symbol))))
157                (#/newDisplayDocumentWithTitle:content:
158                 (#/sharedDocumentController ns:ns-document-controller)
159                 title
160                 string)))))))))
161                             
162
163
164                   
165                   
166                   
167                   
168               
Note: See TracBrowser for help on using the repository browser.