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