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