1;; guile-gnome
2;; Copyright (C) 2003,2004 Andy Wingo <wingo at pobox dot com>
3
4;; This program is free software; you can redistribute it and/or
5;; modify it under the terms of the GNU General Public License as
6;; published by the Free Software Foundation; either version 2 of
7;; the License, or (at your option) any later version.
8;;
9;; This program is distributed in the hope that it will be useful,
10;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12;; GNU General Public License for more details.
13;;
14;; You should have received a copy of the GNU General Public License
15;; along with this program; if not, contact:
16;;
17;; Free Software Foundation           Voice:  +1-617-542-5942
18;; 59 Temple Place - Suite 330        Fax:    +1-617-542-2652
19;; Boston, MA  02111-1307,  USA       gnu@gnu.org
20
21;;; Commentary:
22;;
23;;A help browser for guile-gnome applications. Designed to be used with
24;;stexinfo documents.
25;;
26;;There can only be one help browser in an application.
27;;
28;;Example use:
29;;
30;;@example
31;; (use-modules (gnome gtk) (gnome contrib help-browser))
32;;
33;; ;; optional
34;; (set-default-help-document! @var{my-stexi-doc}) ;; optional
35;;
36;; ;; @var{document} can be a nodal tree or an stexi document
37;; (add-help-root! @var{document})
38;;
39;; ;; shows default page
40;; (show-help)
41;;
42;; ;; shows the node named @var{node}
43;; (show-help @var{node})
44;;
45;; ;; shows the node named @var{node} in manual (root) @var{root}
46;; (show-help @var{node} @var{root})
47;;@end example
48;;
49;;; Code:
50
51(define-module (gnome contrib help-browser)
52  #:use-module (ice-9 optargs)
53  #:use-module (oop goops)
54  #:use-module (gnome gobject)
55  #:use-module (gnome glib)
56  #:use-module (gnome gtk)
57  #:use-module (srfi srfi-13)
58  #:use-module (texinfo)
59  #:use-module (texinfo indexing)
60  #:use-module (sxml simple)
61  #:use-module (container nodal-tree)
62  #:use-module (container delay-tree)
63  #:use-module (gnome contrib texinfo-buffer)
64  #:use-module (gnome contrib delay-tree-model)
65  #:use-module (gnome contrib filtered-list)
66  #:export (set-default-help-document! add-help-root! show-help
67            populate-help-hook the-help-window))
68
69(eval-when (expand load eval)
70  (warn "(gnome contrib help-browser) is still in development. ")
71  (warn "It might eat your baby! In any case, don't rely on it yet.")
72
73  (pk "mmm, babies taste good"))
74
75;; Add a `buffer' column to a normal delay-tree-model
76(define-class <help-tree> (<delay-tree-model>))
77(define-method (on-get-n-columns (obj <help-tree>))
78  3) ;; name, value, buffer
79(define-method (on-get-column-type (obj <help-tree>) index)
80  (case index
81    ((2) <gboxed-scm>)
82    (else (next-method))))
83(define-method (on-get-value (obj <help-tree>) iter index)
84  (case index
85    ((2)
86     (or (node-ref iter 'buffer)
87         (let ((buf (stexi->gtk-text-buffer (force-ref iter 'value))))
88           (node-set! iter 'buffer buf)
89           buf)))
90    (else
91     (next-method))))
92
93(define default-document
94  '(texinfo
95    (% (title "guile-gnome help browser"))
96    (node (% (name "top")))
97    (chapter "Help")
98    (para
99     "Welcome to guile-gnome's help system.")
100    (para
101     "The available sections can be browsed on the left.")
102    (para
103     "If you are looking for something specific, try the index.")
104    (para
105     "(This message can be customized. See the documentation for details.)")))
106
107(define default-buffer #f)
108
109;; exported
110(define (set-default-help-document! document)
111  "Doc me"
112  (or (eq? (car document) 'texinfo)
113      (error "The default help document must be stexinfo."))
114  (set! default-buffer #f)
115  (set! default-document document))
116
117(define the-help-tree (make <help-tree>))
118
119(define (add-help-root! document)
120  (append-root! the-help-tree document))
121
122;; the index
123(define-class <help-index> (<filtered-list-model>))
124(define-method (on-get-n-columns (obj <help-index>))
125  3) ;; name, node name, tree-iter
126(define-method (on-get-column-type (obj <help-index>) index)
127  (case index
128    ((0 1) <gchararray>)
129    ((2) (gtype-name->class "GtkTreeIter"))
130    (else (error "Invalid index" index))))
131(define-method (on-get-value (obj <help-index>) iter index)
132  (case index
133    ((0 1 2)
134     (list-ref iter index))
135    (else
136     (error "Invalid index" index))))
137(define-method (set-filter (obj <help-index>) filter)
138  (define (make-index)
139    (let loop ((index '()) (iter (iter-nth-child the-help-tree #f 0)))
140      (if (not iter)
141          (sort! index (lambda rows (apply string-ci<=? (map car rows))))
142          (let ((this-index (map
143                             (lambda (x) (list (car x) (cdr x) iter))
144                             (stexi-extract-index
145                              (get-value the-help-tree iter 1) #f 'all)))
146                (kids-index (let ((iter (iter-nth-child the-help-tree iter 0)))
147                              (if iter (loop '() iter) '()))))
148            (loop (append this-index kids-index index)
149                  (iter-next the-help-tree iter))))))
150
151  (if (null? (slot-ref obj 'list))
152      ;; Don't actually do the indexing until the first filter is set,
153      ;; that is, until the user has typed something in the search box
154      (slot-set! obj 'list (make-index)))
155  (next-method))
156
157(define the-help-window #f)
158
159;; the parts of the help window that we want to remember
160(define *topics-treeview* #f)
161(define *textbuffer* #f)
162(define *textview* #f)
163(define *current-node* #f)
164
165(define (get-help-buffer iter)
166  (cond
167   (iter (get-value the-help-tree iter 2))
168   (default-buffer default-buffer)
169   (else
170    (set! default-buffer (stexi->gtk-text-buffer default-document))
171    default-buffer)))
172
173(define (get-help-mark iter node-name)
174  (get-mark (get-help-buffer iter) (string-append "node-" node-name)))
175
176(define (make-help-window)
177  (define (add-topics-page w notebook)
178    (let* ((treemodel the-help-tree)
179           (treeview (make <gtk-tree-view> #:model treemodel #:headers-visible #f))
180           (scroll (make <gtk-scrolled-window>
181                     #:hscrollbar-policy 'automatic #:vscrollbar-policy 'automatic
182                     #:shadow-type 'in))
183           (cellrenderer (make <gtk-cell-renderer-text>))
184           (column (make <gtk-tree-view-column>))
185           (selection (get-selection treeview)))
186      (set! *topics-treeview* treeview)
187      (append-page notebook scroll (make <gtk-label> #:label "Topics"))
188      (add scroll treeview)
189      (set-mode selection 'single)
190      (pack-start column cellrenderer #t)
191      (add-attribute column cellrenderer "text" 0)
192      (append-column treeview column)
193      (connect
194       selection 'changed
195       (lambda (selection)
196         (call-with-values (lambda () (get-selected selection))
197           (lambda (model iter)
198             (set! *current-node* iter)
199             (set-buffer *textview* (get-help-buffer iter))
200             (set the-help-window 'title
201                  (if iter
202                      (get-value the-help-tree iter 0)
203                      (sxml->string
204                       (assq-ref (cdadr default-document) 'title))))))))
205      (emit selection 'changed)))
206
207  (define (add-index-page w notebook)
208    ;; The "Index" page
209    (let* ((vbox (make <gtk-vbox>))
210           (entry (make <gtk-entry>))
211           (list (make <gtk-tree-view>))
212           (treemodel (make <help-index>))
213           (scroll (make <gtk-scrolled-window>
214                     #:hscrollbar-policy 'automatic #:vscrollbar-policy 'automatic
215                     #:shadow-type 'in))
216           (treeview (make <gtk-tree-view> #:model treemodel #:headers-visible #f))
217           (cellrenderer (make <gtk-cell-renderer-text>))
218           (column (make <gtk-tree-view-column>))
219           (selection (get-selection treeview)))
220      (append-page notebook vbox (make <gtk-label> #:label "Index"))
221      (pack-start vbox entry #f #f 0)
222      (pack-start vbox scroll #t #t 0)
223      (add scroll treeview)
224      (set-mode selection 'single)
225      (pack-start column cellrenderer #t)
226      (add-attribute column cellrenderer "text" 0)
227      (append-column treeview column)
228      (set-text entry "(indexing takes some time)")
229      (select-region entry 0 -1)
230      (connect
231       entry 'changed
232       (lambda (entry)
233         (let ((text (get-text entry)))
234           (set-filter treemodel
235                       (if (equal? text "")
236                           #f
237                           (lambda (row)
238                             (string-contains-ci (car row) text)))))))
239      (connect
240       selection 'changed
241       (lambda (selection)
242         (call-with-values (lambda () (get-selected selection))
243           (lambda (model iter)
244             (if iter
245                 (select-node (get-value model iter 2)
246                              (get-value model iter 1)))))))))
247
248  (let* ((w (make <gtk-window>
249              #:default-height 400
250              #:default-width 700))
251         (textbuffer (make <gtk-text-buffer>))
252         (textview (make <gtk-text-view>
253                     #:editable #f #:cursor-visible #f #:wrap-mode 'word
254                     #:pixels-above-lines 2 #:pixels-below-lines 6
255                     #:pixels-inside-wrap 1 ;; #:justification 'fill <- not supported yet
256                     #:right-margin 10 #:left-margin 10))
257         (pane (make <gtk-hpaned> #:position 200))
258         (notebook (make <gtk-notebook> #:show-border #f))
259         (text-scroll (make <gtk-scrolled-window>
260                        #:hscrollbar-policy 'automatic #:vscrollbar-policy 'automatic
261                        #:shadow-type 'in)))
262
263    (add w pane)
264    (pack1 pane notebook #f #t)
265    (pack2 pane text-scroll #t #t)
266    (add text-scroll textview)
267    (set! the-help-window w)
268    (set! *textbuffer* textbuffer)
269    (set! *textview* textview)
270
271    (connect w 'delete-event (lambda (w e) (hide w) #t))
272
273    (add-topics-page w notebook)
274    (add-index-page w notebook)
275
276    (show-all w)
277    (hide w)))
278
279;; If manual-name is #f, look in the currently selected manual.
280;; If node-name is #f, select the top of the manual.
281(define (find-node node-name manual-name)
282  (define (find-node-named top name)
283    (or-map
284     (lambda (node)
285       (if (get-help-mark node name)
286           node
287           (find-node-named node name)))
288     (iter-children the-help-tree top)))
289  (let ((manual (if manual-name
290                    (let loop ((manual (get-iter-first the-help-tree)))
291                      (cond
292                       ((not manual)
293                        (error "Unknown manual:" manual-name))
294                       ((string=? (get-value the-help-tree manual 0)
295                                  manual-name)
296                        manual)
297                       (else
298                        (loop (iter-next the-help-tree manual)))))
299                    (if (not *current-node*)
300                        (error
301                         "The TOP node must specify a manual in its cross-references.")
302                        (let find-top ((node *current-node*))
303                          (let ((parent (iter-parent the-help-tree node)))
304                            (if (not parent)
305                                node
306                                (find-top parent))))))))
307
308    (if (and node-name (not (string=? node-name "top")))
309        (or
310         (find-node-named manual node-name)
311         (error "No such node in manual:" manual-name node-name))
312        manual)))
313
314(define (select-node iter node-name)
315  (let* ((treeview *topics-treeview*)
316         (path (get-path the-help-tree iter)))
317    (expand-to-path treeview path)
318    (select-path (get-selection treeview) path)
319    (scroll-to-cell treeview path #f #f 0 0))
320    ;; now the buffer should be correct...
321    ;; scroll in an idle loop to give the textview time to compute line heights
322    (g-idle-add
323     (lambda ()
324       (scroll-to-mark *textview*
325                       (if node-name
326                           (get-help-mark iter node-name)
327                           (create-mark (get-help-buffer iter)
328                                        #f
329                                        (get-start-iter (get-help-buffer iter))
330                                        #t))
331                       0.15 #f 0 0)
332       #f)))
333
334(define populate-help-hook (make-hook 0))
335
336(define (ensure-help-window)
337  (if (not the-help-window)
338      (begin
339        (run-hook populate-help-hook)
340        (make-help-window)))
341  the-help-window)
342
343(define* (show-help #:optional (node-name #f) (manual-name #f))
344  "Show the help window. If @var{manual-name} is @code{#f}, look in the
345currently selected manual. If @var{node-name} is @code{#f}, select the
346top of the manual."
347  (let ((window (ensure-help-window)))
348    (show window)
349    (if (or node-name manual-name)
350        (select-node (find-node node-name manual-name) node-name))
351    (present window)))
352
353(eval-when (expand load eval)
354  (add-hook! stexi-buffer-xref-activated-hook show-help))
355