source: trunk/source/cocoa-ide/cocoa-doc.lisp @ 12492

Last change on this file since 12492 was 12492, checked in by gb, 11 years ago

Work around missing Cocotron functionality.

File size: 6.6 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
58                #-cocotron
59                 (unless (%null-ptr-p dict)
60                        (#/valueForKey: dict #&NSTitleDocumentAttribute))))
61          (when title 
62            (#/setTitle: (#/window textview) title))
63          (when string
64            (#/beginEditing textstorage)
65            (#/replaceCharactersInRange:withAttributedString:
66             textstorage
67             (ns:make-ns-range 0 (#/length textstorage))
68             string)
69            (#/setSelectedRange: textview (ns:make-ns-range 0 0))
70            (#/endEditing textstorage)
71            (#/scrollRangeToVisible: textview (ns:make-ns-range 0 0)))))))
72  #$YES)
73
74(objc:defmethod (#/textView:shouldChangeTextInRange:replacementString: :<BOOL>)
75    ((self url-delegate)
76     textview
77     (range :<NSR>ange)
78     string)
79  (declare (ignorable textview range string))
80  nil)
81
82
83
84
85
86(objc:defmethod #/windowNibName ((self display-document))
87  #@"displaydoc")
88
89(objc:defmethod (#/windowControllerDidLoadNib: :void)
90    ((self display-document) controller)
91  (with-slots (text-view) self
92    (unless (%null-ptr-p text-view)
93      (#/setEditable: text-view t)
94      (#/setDelegate: text-view (make-instance 'url-delegate))))
95  (call-next-method controller))
96
97
98(defun hyperspec-root-url ()
99  (or *hyperspec-root-url*
100      (setq *hyperspec-root-url* (setup-hyperspec-root-url))))
101
102(defun setup-hyperspec-root-url ()
103  (make-instance 'ns:ns-url
104                 :with-string
105                 (%make-nsstring *hyperspec-url-string*)))
106
107(defun hyperspec-map-hash (document)
108  (or *hyperspec-map-sym-hash*
109      (rlet ((perror :id  +null-ptr+))
110        (let* ((map-url (make-instance 'ns:ns-url :with-string #@"Data/Map_Sym.txt" :relative-to-url (hyperspec-root-url)))
111               (data (make-instance 'ns:ns-data
112                                    :with-contents-of-url map-url
113                                    :options 0
114                                    :error perror)))
115          (let* ((err (pref perror :id)))
116            (unless (%null-ptr-p err)
117              (#/presentError: document err)
118              (return-from hyperspec-map-hash nil)))
119          (with-input-from-string (s (%str-from-ptr (#/bytes data) (#/length data)))
120            (let* ((hash (make-hash-table :test #'eq))
121                   (*package* (find-package "CL"))
122                   (eof (cons nil nil)))
123              (declare (dynamic-extent eof))
124              (loop
125                (let* ((sym (read s nil eof))
126                       (url (read-line s nil eof)))
127                  (when (eq sym eof)
128                    (return 
129                      (setq *hyperspec-map-sym-url* map-url
130                            *hyperspec-map-sym-hash* hash)))
131                  (setf (gethash sym hash) url)))))))))
132
133(defun lookup-hyperspec-symbol (symbol doc)
134  (let* ((relative-url (gethash symbol (hyperspec-map-hash doc))))
135    (when relative-url
136      (let* ((url (#/absoluteURL
137                   (make-instance 'ns:ns-url
138                                  :with-string (%make-nsstring relative-url)
139                                  :relative-to-url *hyperspec-map-sym-url*))))
140        (rlet ((pdocattrs :id +null-ptr+)
141               (perror :id  +null-ptr+))
142          (let* ((data (make-instance 'ns:ns-data
143                                      :with-contents-of-url url
144                                      :options 0
145                                      :error perror)))
146            (if (not (%null-ptr-p (pref perror :id)))
147              (progn
148                (#/presentError: doc (pref perror :id)))
149              (let* ((string (make-instance 'ns:ns-attributed-string
150                                            :with-html data
151                                            :base-url url
152                                            :document-attributes pdocattrs))
153                     (docattrs (pref pdocattrs :id))
154                     (title #+cocotron +null-ptr+
155                            #-cocotron
156                            (if (%null-ptr-p docattrs)
157                              +null-ptr+
158                              (#/objectForKey: docattrs #&NSTitleDocumentAttribute))))
159                (if (%null-ptr-p title)
160                  (setq title (%make-nsstring (string symbol))))
161                (#/newDisplayDocumentWithTitle:content:
162                 (#/sharedDocumentController ns:ns-document-controller)
163                 title
164                 string)))))))))
165                             
166
167
168                   
169                   
170                   
171                   
172               
Note: See TracBrowser for help on using the repository browser.