repos
/
qt.examples
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
initial import
Annotate for file src/class-browser.lisp
2009-04-05 tobias
1
(in-package :qt.examples)
15:36:46 '
2
(declaim (optimize (debug 3)))
'
3
'
4
(defclass classes-model (qt:abstract-list-model)
'
5
((items :reader items :initarg :items
'
6
:initform (make-array 0 :adjustable t
'
7
:fill-pointer t)))
'
8
(:metaclass cxx:class))
'
9
'
10
(defmethod cxx:row-count ((list classes-model) &rest args
'
11
&aux (parent (first args)))
'
12
(declare (ignore parent))
'
13
(length (items list)))
'
14
'
15
(defmethod cxx:data ((list classes-model) &rest args
'
16
&aux (index (first args))
'
17
(role (second args)))
'
18
(if (and (cxx:is-valid index)
'
19
(< (cxx:row index) (length (items list)))
'
20
(= role (value qt:+display-role+)))
'
21
(qt:make-variant (string-downcase
'
22
(class-name (aref (items list) (cxx:row index)))))
'
23
(make-instance 'qt:variant)))
'
24
'
25
(defun class-at (model-index)
'
26
(aref (items (cxx:model model-index)) (cxx:row model-index)))
'
27
'
28
(defclass class-browser (qt:splitter)
'
29
((classes :accessor classes
'
30
:initform (make-instance 'classes-model))
'
31
(classes-list :reader classes-list
'
32
:initform (make-instance 'qt:list-view))
'
33
(info :reader class-info
'
34
:initform (make-instance 'qt:label))
'
35
(web-view :reader web-view
'
36
:initform (make-instance 'qt.webkit:web-view)))
'
37
(:metaclass smoke::smoke-wrapper-class))
'
38
'
39
(defun setup-class-list (classes)
'
40
(do-external-symbols (symbol :qt)
'
41
(let ((class (find-class symbol nil)))
'
42
(when (and (not (null class))
'
43
(typep class (find-class 'smoke::smoke-standard-class)))
'
44
(vector-push-extend class
'
45
(items classes)))))
'
46
(sort (items classes) #'(lambda (class1 class2)
'
47
(string< (class-name class1)
'
48
(class-name class2)))))
'
49
'
50
(defmethod initialize-instance :after ((browser class-browser) &rest args)
'
51
(declare (ignore args))
'
52
(setup-class-list (classes browser))
'
53
'
54
(let* ((w (make-instance 'qt:widget))
'
55
(layout (make-instance 'qt:vbox-layout)))
'
56
(cxx:add-widget layout (classes-list browser))
'
57
(let ((search (make-instance 'qt:line-edit)))
'
58
(cxx:add-widget layout search)
'
59
(qt:connect (qt:get-signal search "textChanged(QString)")
'
60
#'(lambda (text)
'
61
;; FIXME since the class list is sorted we could do better
'
62
(cxx:keyboard-search (classes-list browser)
'
63
text))))
'
64
(let ((scroll (make-instance 'qt:scroll-area)))
'
65
(cxx:set-widget scroll (class-info browser))
'
66
(cxx:set-widget-resizable scroll t)
'
67
(cxx:add-widget layout scroll))
'
68
(cxx:set-layout w layout)
'
69
(cxx:add-widget browser w))
'
70
(cxx:add-widget browser (web-view browser))
'
71
(cxx:load (web-view browser) (make-instance 'qt:url
'
72
:args '("http://doc.trolltech.com/4.5")))
'
73
(cxx:set-uniform-item-sizes (classes-list browser) t)
'
74
(cxx:set-selection-mode (classes-list browser) qt:abstract-item-view.+single-selection+)
'
75
(cxx:set-model (classes-list browser) (classes browser))
'
76
(cxx:set-word-wrap (class-info browser) t)
'
77
(cxx:set-window-title browser "CL Qt Classes")
'
78
'
79
(qt:connect (qt:get-signal (cxx:selection-model (classes-list browser))
'
80
"currentChanged(QModelIndex, QModelIndex)")
'
81
#'(lambda (current previous)
'
82
(declare (ignore previous))
'
83
(set-info (class-info browser)
'
84
(web-view browser) current))))
'
85
'
86
(defun set-info (info web-view model-index)
'
87
(let* ((class (class-at model-index)))
'
88
(cxx:load web-view
'
89
(make-instance 'qt:url
'
90
:args (list (format nil "http://doc.trolltech.com/~A/~A.html"
'
91
(subseq (qt:q-version) 0 3)
'
92
(remove #\: (smoke::name class) :count 1)))))
'
93
(cxx:set-text info
'
94
(format nil "<h1>qt:~A</h1>
'
95
<p>~A</p>
'
96
<h2>Direct Superclasses</h2>
'
97
<ul>
'
98
~{ <li>~A</li> ~}
'
99
</ul>
'
100
<h2>Direct Subclasses</h2>
'
101
<ul>
'
102
~{ <li>~A</li>~}
'
103
</ul>
'
104
"
'
105
(string-downcase (class-name class))
'
106
(smoke::name class)
'
107
(mapcar #'(lambda (c) (string-downcase (class-name c)))
'
108
(closer-mop:class-direct-superclasses class))
'
109
(mapcar #'(lambda (c) (string-downcase (class-name c)))
'
110
(closer-mop:class-direct-subclasses class))))))
'
111
'
112
(defun class-browser ()
'
113
"Qt Class Browser"
'
114
(qt:with-app
'
115
(let ((browser (make-instance 'class-browser)))
'
116
(cxx:show browser)
'
117
(qt:exec))))