darcs - qt.examples

2 ;;; License: X11 license

4 (in-package :qt.examples)

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))

12 (defmethod cxx:row-count ((list classes-model) parent)

13 (length (items list)))

15 (defmethod cxx:data ((list classes-model) index role)

16 (if (and (cxx:is-valid index)

17 (< (cxx:row index) (length (items list)))

18 (= role (value qt:+display-role+)))

19 (string-downcase (class-name (aref (items list) (cxx:row index))))

20 (qt:make-variant)))

22 (defun class-at (model-index)

23 (aref (items (cxx:model model-index)) (cxx:row model-index)))

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

33 :initform (make-instance 'qt:web-view)))

34 (:metaclass cxx:class))

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)))))

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)))

60 (setf (cxx:widget scroll) (class-info browser)

61 (cxx:widget-resizable scroll) t)

62 (cxx:add-widget layout scroll))

63 (setf (cxx:layout w) layout)

64 (cxx:add-widget browser w))

65 (cxx:add-widget browser (web-view browser))

66 (qt:do-delayed-initialize

67 (setup-class-list (classes browser))

68 (setf (cxx:uniform-item-sizes (classes-list browser)) t

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")

73 (qt:connect (qt:get-signal (cxx:selection-model (classes-list browser))

74 "currentChanged(QModelIndex, QModelIndex)")

75 #'(lambda (current previous)

76 (declare (ignore previous))

77 (set-info (class-info browser)

78 (web-view browser) current)))))

80 (defun set-info (info web-view model-index)

81 (let* ((class (class-at model-index)))

82 (cxx:load web-view (format nil "http://qt.nokia.com/doc/~A/~(~A~).html"

83 (subseq (qt:q-version) 0 3)

84 (remove #\: (smoke:name class) :count 1)))

85 (cxx:set-text info

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))

98 (smoke:name class)

99 (mapcar #'(lambda (c) (string-downcase (class-name c)))

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"

106 (qt:with-app ()

107 (let ((browser (make-instance 'class-browser)))

108 (cxx:show browser)

109 (qt:exec))))