← Back to branch summary

~ubuntu-branches/ubuntu/saucy/texmacs/saucy-proposed

« back to all changes in this revision

Viewing changes to TeXmacs/progs/link/link-navigate.scm

  • Committer: Package Import Robot
  • Author(s): Atsuhito KOHDA
  • Date: 2013-02-21 11:51:59 UTC
  • mfrom: (4.3.2 sid)
  • Revision ID: package-import@ubuntu.com-20130221115159-e0ejzow5o83ogzsy
Tags: 1:1.0.7.18-1
* New Upstream Release.
* Removed 05_fixRd.patch and updated 01_american.patch, 09_ipa.patch
  10_tex-files.cpp.patch

Show diffs side-by-side

added added

removed removed

Lines of Context:
TeXmacs/progs/link/link-navigate.scm
12
12
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13
13
 
14
14
(texmacs-module (link link-navigate)
15
 
  (:use (utils library cursor) (link link-edit) (link link-extern)))
 
15
  (:use (utils library cursor) (link link-edit) (link link-extern)
 
16
        (generic generic-edit)))
 
17
 
 
18
; FIXME: remove these two and find a better way
 
19
(define (escape-link-args s)
 
20
  "Escape only args of the type #some:label"
 
21
  (let* ((m (string-length s))
 
22
         (h (or (string-index s #\#) m))
 
23
         (a (or (string-index s #\?) m))
 
24
         (i (min m h a))
 
25
         (base (substring s 0 i))
 
26
         (qry (substring s (min m i) m)))
 
27
    (if (< i m) (string-append base (string-replace qry ":" "%3A")) s)))
 
28
 
 
29
(define (unescape-link-args s)
 
30
  (string-replace s "%3A" ":"))
16
31
 
17
32
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
18
33
;; Navigation mode
19
34
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
20
35
 
21
 
(define navigation-bidirectional-links? #t)
 
36
(define navigation-bidirectional-links? #f)
22
37
(define navigation-external-links? #t)
23
38
(define navigation-link-pages? #t)
24
39
(define navigation-blocked-types (make-ahash-table))
27
42
(tm-define (navigation-toggle-bidirectional)
28
43
  (:synopsis "Toggle whether we may follow links in both directions.")
29
44
  (:check-mark "v" navigation-bidirectional?)
30
 
  (toggle! navigation-bidirectional-links?))
 
45
  (set-boolean-preference "bidirectional navigation"
 
46
                          (not navigation-bidirectional-links?)))
31
47
 
32
48
(define (navigation-external?) navigation-external-links?)
33
49
(tm-define (navigation-toggle-external)
34
50
  (:synopsis "Toggle whether we may follow links defined in other loci.")
35
51
  (:check-mark "v" navigation-external?)
36
 
  (toggle! navigation-external-links?))
 
52
  (set-boolean-preference "external navigation"
 
53
                          (not navigation-external-links?)))
37
54
 
38
55
(define (navigation-build-link-pages?) navigation-link-pages?)
39
56
(tm-define (navigation-toggle-build-link-pages)
40
57
  (:synopsis "Toggle whether we generate link pages.")
41
58
  (:check-mark "v" navigation-build-link-pages?)
42
 
  (toggle! navigation-link-pages?))
 
59
  (set-boolean-preference "link pages"
 
60
                          (not navigation-link-pages?)))
43
61
 
44
62
(define (navigation-allow-type? type)
45
63
  (not (ahash-ref navigation-blocked-types type)))
47
65
  (:synopsis "Toggle whether we may follow links of a given @type.")
48
66
  (:check-mark "v" navigation-allow-type?)
49
67
  (ahash-set! navigation-blocked-types type
50
 
              (not (ahash-ref navigation-blocked-types type))))
 
68
              (not (ahash-ref navigation-blocked-types type))))
51
69
 
52
70
(define (navigation-allow-no-types?)
53
71
  (with l (ahash-table->list navigation-blocked-types)
54
72
    (null? (list-difference (current-link-types)
55
 
                            (map car (list-filter l cdr))))))
 
73
                            (map car (list-filter l cdr))))))
56
74
(tm-define (navigation-allow-no-types)
57
75
  (:synopsis "Disallow any link types from being followed.")
58
76
  (:check-mark "v" navigation-allow-no-types?)
59
77
  (for-each (cut ahash-set! navigation-blocked-types <> #t)
60
 
            (current-link-types)))
 
78
            (current-link-types)))
61
79
 
62
80
(define (navigation-allow-all-types?)
63
81
  (with l (ahash-table->list navigation-blocked-types)
68
86
  (set! navigation-blocked-types (make-ahash-table)))
69
87
 
70
88
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
89
;; Navigation preferences
 
90
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
91
 
 
92
(define (notify-bidirectional-navigation var val)
 
93
  (set! navigation-bidirectional-links? (== val "on")))
 
94
 
 
95
(define (notify-external-navigation var val)
 
96
  (set! navigation-external-links? (== val "on")))
 
97
 
 
98
(define (notify-link-pages var val)
 
99
  (set! navigation-link-pages? (== val "on")))
 
100
 
 
101
(define-preferences
 
102
  ("bidirectional navigation" "off" notify-bidirectional-navigation)
 
103
  ("external navigation" "on" notify-external-navigation)
 
104
  ("link pages" "on" notify-link-pages))
 
105
 
 
106
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
71
107
;; Finding links in the form of "link lists". Items in such a list
72
108
;;   (id type attrs vertex-1 ... vertex-n)
73
109
;; where id is the identifier of the locus which triggered the creation
82
118
 
83
119
(define (id->link-list id)
84
120
  (let* ((lns (vertex->links `(id ,id)))
85
 
         (sts (map link-flatten lns)))
 
121
         (sts (map link-flatten lns)))
86
122
    (map (cut cons id <>) (map cdr sts))))
87
123
 
88
124
(tm-define (ids->link-list ids)
95
131
(define (exact-link-list-local t)
96
132
  (if (not (tm-func? t 'locus)) '()
97
133
      (let* ((id (locus-id t))
98
 
             (lc (list-filter (cdr (tree-children t)) (cut tm-func? <> 'link)))
99
 
             (lns (map link-flatten lc)))
100
 
        (map (cut cons id <>) (map cdr lns)))))
 
134
             (lc (list-filter (cdr (tree-children t)) (cut tm-func? <> 'link)))
 
135
             (lns (map link-flatten lc)))
 
136
        (map (cut cons id <>) (map cdr lns)))))
101
137
 
102
138
(define (filter-on-bidirectional item)
103
139
  (== (link-item-id item)
115
151
(define (filter-link-list l event)
116
152
  (let* ((f1 (if (navigation-bidirectional?) l
117
153
                 (list-filter l filter-on-bidirectional)))
118
 
         (f2 (list-filter l filter-on-type))
119
 
         (f3 (list-filter l (filter-on-event event))))
 
154
         (f2 (list-filter f1 filter-on-type))
 
155
         (f3 (list-filter f2 (filter-on-event event))))
120
156
    f3))
121
157
 
122
158
(tm-define (exact-link-list t filter?)
127
163
  ;;(display* "local : " (exact-link-list-local  t) "\n")
128
164
  ;;(display* "global: " (exact-link-list-global t) "\n")
129
165
  (with l (if (and filter? (not (navigation-external?)))
130
 
              (exact-link-list-local t)
131
 
              (exact-link-list-global t))
 
166
              (exact-link-list-local t)
 
167
              (exact-link-list-global t))
132
168
    (if filter? (filter-link-list l "click") l)))
133
169
 
134
170
(tm-define (upward-link-list t filter?)
137
173
  (:argument filter? "Filter on navigation mode?")
138
174
  (if (or (not t) (null? (tree->path t))) '()
139
175
      (with l (exact-link-list t filter?)
140
 
        (if (root? t) l
141
 
            (append l (upward-link-list (tree-up t) filter?))))))
 
176
        (if (root? t) l
 
177
            (append l (upward-link-list (tree-up t) filter?))))))
142
178
 
143
179
(tm-define (complete-link-list t filter?)
144
180
  (:synopsis "Build possibly filtered link list for @t and its descendants.")
146
182
  (:argument filter? "Filter on navigation mode?")
147
183
  (with l (exact-link-list t filter?)
148
184
    (if (tree-atomic? t) l
149
 
        (with ls (map (cut complete-link-list <> filter?) (tree-children t))
150
 
          (apply append (cons l ls))))))
 
185
        (with ls (map (cut complete-link-list <> filter?) (tree-children t))
 
186
          (apply append (cons l ls))))))
151
187
 
152
188
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
153
189
;; Prospect for active links
160
196
(define (link-active-upwards-sub t active-ids)
161
197
  (if (or (not t) (null? (tree->path t))) '()
162
198
      (let* ((ids (tree->ids t))
163
 
             (add? (nnull? (list-intersection ids active-ids)))
164
 
             (r (if add? (list t) '())))
165
 
        (if (root? t) r
166
 
            (append r (link-active-upwards-sub (tree-up t) active-ids))))))
 
199
             (add? (nnull? (list-intersection ids active-ids)))
 
200
             (r (if add? (list t) '())))
 
201
        (if (root? t) r
 
202
            (append r (link-active-upwards-sub (tree-up t) active-ids))))))
167
203
 
168
204
(tm-define (link-active-upwards t)
169
205
  (:synopsis "Return active ancestor trees for the tree @t.")
194
230
(define (navigation-list-sub type attrs nr source l)
195
231
  (if (null? l) l
196
232
      (let* ((head (list type attrs nr source (car l)))
197
 
             (tail (navigation-list-sub type attrs (+ nr 1) source (cdr l))))
198
 
        (if (== source (vertex->id (car l))) tail
199
 
            (cons head tail)))))
 
233
             (tail (navigation-list-sub type attrs (+ nr 1) source (cdr l))))
 
234
        (if (== source (vertex->id (car l))) tail
 
235
            (cons head tail)))))
200
236
 
201
237
(tm-define (link-list->navigation-list l)
202
238
  (:synopsis "Transforms the link list @t into a navigation list")
203
239
  (if (null? l) l
204
240
      (let* ((item (car l))
205
 
             (source (link-item-id item))
206
 
             (type (link-item-type item))
207
 
             (attrs (link-item-attributes item))
208
 
             (vertices (link-item-vertices item))
209
 
             (h (navigation-list-sub type attrs 0 source vertices))
210
 
             (r (link-list->navigation-list (cdr l))))
211
 
        (list-remove-duplicates (append h r)))))
 
241
             (source (link-item-id item))
 
242
             (type (link-item-type item))
 
243
             (attrs (link-item-attributes item))
 
244
             (vertices (link-item-vertices item))
 
245
             (h (navigation-list-sub type attrs 0 source vertices))
 
246
             (r (link-list->navigation-list (cdr l))))
 
247
        (list-remove-duplicates (append h r)))))
212
248
 
213
249
(tm-define (upward-navigation-list t)
214
250
  (link-list->navigation-list (upward-link-list t #t)))
215
251
 
216
252
(tm-define (navigation-list-filter l type nr jumpable?)
217
253
  (cond ((null? l) l)
218
 
        ((and (or (== type #t) (== (navigation-type (car l)) type))
219
 
              (or (== nr #t) (== (navigation-pos (car l)) nr))
220
 
              (or (not jumpable?)
221
 
                  (func? (navigation-target (car l)) 'id 1)
222
 
                  (func? (navigation-target (car l)) 'url 1)
223
 
                  (func? (navigation-target (car l)) 'script)))
224
 
         (cons (car l) (navigation-list-filter (cdr l) type nr jumpable?)))
225
 
        (else (navigation-list-filter (cdr l) type nr jumpable?))))
 
254
        ((and (or (== type #t) (== (navigation-type (car l)) type))
 
255
              (or (== nr #t) (== (navigation-pos (car l)) nr))
 
256
              (or (not jumpable?)
 
257
                  (func? (navigation-target (car l)) 'id 1)
 
258
                  (func? (navigation-target (car l)) 'url 1)
 
259
                  (func? (navigation-target (car l)) 'script)))
 
260
         (cons (car l) (navigation-list-filter (cdr l) type nr jumpable?)))
 
261
        (else (navigation-list-filter (cdr l) type nr jumpable?))))
226
262
 
227
263
(tm-define (navigation-list-types l)
228
264
  (list-remove-duplicates (map navigation-type l)))
229
265
 
230
266
(tm-define (navigation-list-xtypes l)
231
267
  (let* ((direct (navigation-list-filter l #t 1 #t))
232
 
         (inverse (navigation-list-filter l #t 0 #t))
233
 
         (dtypes (map navigation-type direct))
234
 
         (itypes (map (cut string-append <> "*")
235
 
                      (map navigation-type inverse))))
 
268
         (inverse (navigation-list-filter l #t 0 #t))
 
269
         (dtypes (map navigation-type direct))
 
270
         (itypes (map (cut string-append <> "*")
 
271
                      (map navigation-type inverse))))
236
272
    (list-remove-duplicates (append dtypes itypes))))
237
273
 
238
274
(tm-define (navigation-list-first-xtype l xtype)
239
275
  (let* ((inverse? (string-ends? xtype "*"))
240
 
         (type (if inverse? (string-drop-right xtype 1) xtype))
241
 
         (fl (navigation-list-filter l type (if inverse? 0 1) #t)))
 
276
         (type (if inverse? (string-drop-right xtype 1) xtype))
 
277
         (fl (navigation-list-filter l type (if inverse? 0 1) #t)))
242
278
    (and (nnull? fl) (navigation-type fl))))
243
279
 
244
280
(define (resolve-navigation-list l fun)
245
281
  (if (null? l) (fun)
246
282
      (let* ((id (vertex->id (navigation-target (car l))))
247
 
             (ok (or (nstring? id) (nnull? (id->trees id)))))
248
 
        (if ok (resolve-navigation-list (cdr l) fun)
249
 
            (begin
250
 
              (resolve-id id)
251
 
              (delayed (:idle 25) (resolve-navigation-list (cdr l) fun)))))))
 
283
             (ok (or (nstring? id) (nnull? (id->trees id)))))
 
284
        (if ok (resolve-navigation-list (cdr l) fun)
 
285
            (begin
 
286
              (resolve-id id)
 
287
              (delayed (:idle 25) (resolve-navigation-list (cdr l) fun)))))))
252
288
 
253
289
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
254
290
;; Link pages
256
292
 
257
293
(define (automatic-link-text back)
258
294
  (cond ((func? back 'id 1)
259
 
         (with ts (id->trees (vertex->id back))
260
 
           (and (nnull? ts) (tree->stree (car ts)))))
261
 
        ((func? back 'url 1)
262
 
         `(verbatim ,(vertex->url back)))
263
 
        ((func? back 'script)
264
 
         `(verbatim ,(vertex->script back)))
265
 
        (else #f)))
 
295
         (with ts (id->trees (vertex->id back))
 
296
           (and (nnull? ts) (tree->stree (car ts)))))
 
297
        ((func? back 'url 1)
 
298
         `(verbatim ,(vertex->url back)))
 
299
        ((func? back 'script)
 
300
         `(verbatim ,(vertex->script back)))
 
301
        (else #f)))
266
302
 
267
303
(tm-define (automatic-link back . opt)
268
304
  (let* ((broken-text (if (null? opt) "Broken" (car opt)))
269
 
         (id (create-unique-id))
270
 
         (text (automatic-link-text back)))
 
305
         (id (create-unique-id))
 
306
         (text (automatic-link-text back)))
271
307
    (if (not text) `(with "color" "red" ,broken-text)
272
 
        `(locus (id ,id) (link "automatic" (id ,id) ,back) ,text))))
 
308
        `(locus (id ,id) (link "automatic" (id ,id) ,back) ,text))))
273
309
 
274
310
(tm-define (build-enumeration l)
275
311
  (if (<= (length l) 1) l
276
312
      `((enumerate
277
 
         (document
278
 
          ,@(map (lambda (x) `(surround (item) "" ,x)) l))))))
 
313
         (document
 
314
          ,@(map (lambda (x) `(surround (item) "" ,x)) l))))))
279
315
 
280
316
(define (navigation-item->document item)
281
317
  (automatic-link (navigation-target item)))
282
318
 
283
319
(define (navigation-list-by-type->document type l)
284
320
  (cons `(strong ,type)
285
 
        (build-enumeration (map navigation-item->document l))))
 
321
        (build-enumeration (map navigation-item->document l))))
286
322
 
287
323
(define (navigation-list->document style l)
288
324
  (let* ((direct (navigation-list-filter l #t 1 #t))
289
 
         (inverse (navigation-list-filter l #t 0 #t))
290
 
         (direct-types (navigation-list-types direct))
291
 
         (inverse-types (navigation-list-types inverse))
292
 
         (direct-by-type (map (cut navigation-list-filter direct <> #t #f)
293
 
                              direct-types))
294
 
         (inverse-by-type (map (cut navigation-list-filter inverse <> #t #f)
295
 
                               inverse-types)))
 
325
         (inverse (navigation-list-filter l #t 0 #t))
 
326
         (direct-types (navigation-list-types direct))
 
327
         (inverse-types (navigation-list-types inverse))
 
328
         (direct-by-type (map (cut navigation-list-filter direct <> #t #f)
 
329
                              direct-types))
 
330
         (inverse-by-type (map (cut navigation-list-filter inverse <> #t #f)
 
331
                               inverse-types)))
296
332
    `(document
297
333
      (style ,style)
298
334
      (body (document
299
 
             (strong "Source")
300
 
             ,(automatic-link `(id ,(navigation-source (car l)))
301
 
                              "Unaccessible")
302
 
             ,@(append-map
303
 
                navigation-list-by-type->document
304
 
                (map (cut string-append "Direct " <>) direct-types)
305
 
                direct-by-type)
306
 
             ,@(append-map
307
 
                navigation-list-by-type->document
308
 
                (map (cut string-append "Inverse " <>) inverse-types)
309
 
                inverse-by-type))))))
 
335
             (strong "Source")
 
336
             ,(automatic-link `(id ,(navigation-source (car l)))
 
337
                              "Unaccessible")
 
338
             ,@(append-map
 
339
                navigation-list-by-type->document
 
340
                (map (cut string-append "Direct " <>) direct-types)
 
341
                direct-by-type)
 
342
             ,@(append-map
 
343
                navigation-list-by-type->document
 
344
                (map (cut string-append "Inverse " <>) inverse-types)
 
345
                inverse-by-type))))))
310
346
 
311
347
(define (build-navigation-page-sub style l)
312
348
  (with doc (navigation-list->document style l)
313
349
    (open-auxiliary "Link page" doc)))
314
350
 
315
 
(define (build-navigation-page l)
 
351
(tm-define (build-navigation-page l)
316
352
  (let* ((style (tree->stree (get-style-tree)))
317
 
         (fun (lambda () (build-navigation-page-sub style l))))
 
353
         (fun (lambda () (build-navigation-page-sub style l))))
318
354
    (resolve-navigation-list l fun)))
319
355
 
320
356
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
357
;; Jumping to different types of URLs is done in two stages. The load handler,
 
358
;; changing with the type of root of the url and the post-load handler, which
 
359
;; will tipically depend on the file format.
 
360
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
361
 
 
362
(define (url->item u)
 
363
  (with (base qry) (process-url u)
 
364
    (let* ((file (url->string u))
 
365
           (help? (and (== "texmacs-file" (file-format u)) 
 
366
                       (url-exists-in-help? file)))
 
367
           (text (if help? (help-file-title u) (basename (url->string base)))))
 
368
      ($link file text))))
 
369
 
 
370
(define (url-list->document l)
 
371
  ($tmdoc
 
372
    ($tmdoc-title "Link disambiguation")
 
373
    ($para "The link you followed points to several locations:")
 
374
    ($description-aligned
 
375
      (with c 0
 
376
        ($for (x l)
 
377
          ($describe-item 
 
378
              (number->string (begin (set! c (+ 1 c)) c)) (url->item x)))))))
 
379
 
 
380
(tm-define (build-disambiguation-page l)
 
381
  (open-auxiliary "Disambiguation page" (url-list->document l)))
 
382
 
 
383
; FIXME: many corner cases will get through 
 
384
;(inexistent relative paths for instance)
 
385
(define (default-filter-url u)
 
386
  (with (base qry) (process-url u)
 
387
    (or (== base "")
 
388
        (or (!= (url-root base) "default")
 
389
            (url-exists? base)))))
 
390
 
 
391
(define (default-root-disambiguator u)
 
392
 (with l (list-filter (url->list u) default-filter-url)
 
393
    (cond ((null? l) 
 
394
           (set-message `(verbatim ,(url->string u)) "Not found"))
 
395
          ((== 1 (length l)) (load-browse-buffer (car l)))
 
396
          (else (build-disambiguation-page l)))))
 
397
 
 
398
(define (process-url u)
 
399
  "Split a simple (not or'ed!!) url in base and query"
 
400
  (let* ((s (url->string u))
 
401
         (m (string-length s))
 
402
         (h (or (string-index s #\#) m))
 
403
         (a (or (string-index s #\?) m))
 
404
         (i (min m h a))
 
405
         (base (substring s 0 i))
 
406
         (qry (substring s (min m (+ 1 i)) m)))
 
407
    (if (< i m)  ; was there either a '?' or a '#' (with args)?
 
408
        (list (string->url (string-drop-right s (+ 1 (string-length qry))))
 
409
              (unescape-link-args qry))
 
410
        (list u ""))))
 
411
 
 
412
(define (texmacs-file-post qry)
 
413
  (if (and (string? qry) (not (string-null? qry)))
 
414
      (with dest (unescape-link-args qry)
 
415
        (go-to-label dest)
 
416
        (set-message (replace "At %1." dest) ""))))
 
417
 
 
418
(define generic-file-post texmacs-file-post)
 
419
 
 
420
(define (source-file-post qry)
 
421
  (let* ((lstr (or (query-ref qry "line") "0"))
 
422
         (cstr (or (query-ref qry "column") "0"))
 
423
         (sstr (or (query-ref qry "select") ""))
 
424
         (line (or (string->number lstr) 0))
 
425
         (column (or (string->number cstr) 0)))
 
426
    (go-to-line line)
 
427
    (go-to-column column)
 
428
    (set! column (or (select-word sstr (cursor-tree) column) 0))
 
429
    (set-message sstr (string-append lstr ":" (number->string column)))))
 
430
 
 
431
; FIXME? will this jump to HTML anchors?
 
432
(define html-file-post generic-file-post)
 
433
 
 
434
(define (default-post-handler u)
 
435
  (with (base qry) (process-url u)
 
436
    (with fm (file-format base)
 
437
      (cond ((== fm "texmacs-file") (texmacs-file-post qry))
 
438
            ((== fm "generic-file") (generic-file-post qry))
 
439
            ((== fm "scheme-file") (source-file-post qry))
 
440
            ((== fm "cpp-file") (source-file-post qry))
 
441
            ((== fm "html-file") (html-file-post qry))
 
442
            (else 
 
443
              (display* "Unhandled format for default queries: " fm "\n"))))))
 
444
 
 
445
(define (http-post-handler u)
 
446
  ; TODO: jump to anchors in HTML
 
447
  (noop))
 
448
 
 
449
(define (default-root-handler u)
 
450
  (if (url-or? (url-expand u))
 
451
      (default-root-disambiguator (url-expand u))
 
452
      (with (base qry) (process-url u)
 
453
        (if (!= "" (url->string base))
 
454
            (load-browse-buffer base)))))
 
455
 
 
456
(define (tmfs-root-handler u)
 
457
  (load-browse-buffer u))
 
458
 
 
459
(define (http-root-handler u)
 
460
  (load-browse-buffer u))
 
461
 
 
462
(define (url-handlers u)
 
463
  (with root (or (and (url-rooted? u) (url-root u)) "default")
 
464
    (cond ((== root "default") 
 
465
           (list default-root-handler default-post-handler))
 
466
          ((== root "tmfs") 
 
467
           (list tmfs-root-handler (lambda (x) (noop))))
 
468
          ((or (== root "http") (== root "https"))
 
469
           (list http-root-handler http-post-handler))
 
470
          (else (display* "Unhandled url root: " root "\n")
 
471
                (list default-root-handler default-post-handler)))))
 
472
 
 
473
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
321
474
;; Actual navigation
322
475
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
323
476
 
326
479
  (:argument opt-from "Optional path for the cursor history")
327
480
  (with l (id->trees id)
328
481
    (if (nnull? l)
329
 
        (begin
330
 
          (if (nnull? opt-from) (cursor-history-add (car opt-from)))
331
 
          (tree-go-to (car l) :end)
332
 
          (if (nnull? opt-from) (cursor-history-add (cursor-path))))
333
 
        (and (resolve-id id)
334
 
             (delayed (:idle 25) (apply go-to-id (cons id opt-from)))))))
335
 
 
336
 
(define (decompose-url s)
337
 
  (with i (string-index s #\#)
338
 
    (if (not i) (list s "")
339
 
        (list (substring s 0 i) (substring s (+ i 1) (string-length s))))))
340
 
 
341
 
(tm-define (go-to-url name-label . opt-from)
342
 
  (:synopsis "Jump to the url @name-label.")
 
482
        (begin
 
483
          (if (nnull? opt-from) (cursor-history-add (car opt-from)))
 
484
          (tree-go-to (car l) :end)
 
485
          (if (nnull? opt-from) (cursor-history-add (cursor-path))))
 
486
        (and (resolve-id id)
 
487
             (delayed (:idle 25) (apply go-to-id (cons id opt-from)))))))
 
488
 
 
489
(tm-define (go-to-url u . opt-from)
 
490
  (:synopsis "Jump to the url @u")
343
491
  (:argument opt-from "Optional path for the cursor history")
344
492
  (if (nnull? opt-from) (cursor-history-add (car opt-from)))
345
 
  (with (name label) (decompose-url name-label)
346
 
    (cond ((== name "") (go-to-label label))
347
 
          ((== label "")
348
 
           (with u (url-relative (buffer-master) name)
349
 
             (load-browse-buffer u)))
350
 
          (else
351
 
           (with u (url-relative (buffer-master) name)
352
 
             (load-browse-buffer u)
353
 
             (go-to-label label)))))
 
493
  (if (string? u) (set! u (string->url u)))
 
494
  (with (action post) (url-handlers u) 
 
495
    (action u) (post u))
354
496
  (if (nnull? opt-from) (cursor-history-add (cursor-path))))
355
497
 
356
498
(define (execute-at cmd opt-location)
359
501
 
360
502
(tm-define (execute-script s secure-origin? . opt-location)
361
503
  (let* ((secure-s (string-append "(secure? '" s ")"))
362
 
         (ok? (or secure-origin? (eval (string->object secure-s))))
363
 
         (cmd-s (string-append "(lambda () " s ")"))
364
 
         (cmd (eval (string->object cmd-s))))
 
504
         (ok? (or secure-origin? (eval (string->object secure-s))))
 
505
         (cmd-s (string-append "(lambda () " s ")"))
 
506
         (cmd (eval (string->object cmd-s))))
365
507
    (cond ((or ok? (== (get-preference "security") "accept all scripts"))
366
 
           (execute-at cmd opt-location))
367
 
          ((== (get-preference "security") "prompt on scripts")
368
 
           (user-confirm `(concat "Execute " ,s "?") #f
369
 
             (lambda (answ)
370
 
               (when answ (execute-at cmd opt-location)))))
371
 
          (else (set-message "Unsecure script refused" "Evaluate script")))))
 
508
           (execute-at cmd opt-location))
 
509
          ((== (get-preference "security") "prompt on scripts")
 
510
           (user-confirm `(concat "Execute " ,s "?") #f
 
511
             (lambda (answ)
 
512
               (when answ (execute-at cmd opt-location)))))
 
513
          (else (set-message "Unsecure script refused" "Evaluate script")))))
372
514
 
373
515
(define (go-to-vertex v attrs)
374
516
  (cond ((func? v 'id 1) (go-to-id (cadr v) (cursor-path)))
375
 
        ((func? v 'url 1) (go-to-url (cadr v) (cursor-path)))
376
 
        ((func? v 'script)
377
 
         (with ok? (== (assoc-ref attrs "secure") "true")
378
 
           (apply execute-script (cons* (cadr v) ok? (cddr v)))))
379
 
        (else (noop))))
 
517
        ((func? v 'url 1) (go-to-url (escape-link-args (cadr v)) (cursor-path)))
 
518
        ((func? v 'script)
 
519
         (with ok? (== (assoc-ref attrs "secure") "true")
 
520
           (apply execute-script (cons* (cadr v) ok? (cddr v)))))
 
521
        (else (noop))))
380
522
 
381
523
(define (vertex-linked-ids v)
382
524
  (let* ((lns (vertex->links v))
383
 
         (vs (list-difference (append-map link-vertices lns) (list v))))
 
525
         (vs (list-difference (append-map link-vertices lns) (list v))))
384
526
    (list-remove-duplicates (filter-map vertex->id vs))))
385
527
 
386
528
(define (id-update id)
387
529
  (let* ((ts1 (id->trees id))
388
 
         (ts2 (id->trees (string-append "&" id)))
389
 
         (pl (filter-map tree->path (append ts1 ts2))))
 
530
         (ts2 (id->trees (string-append "&" id)))
 
531
         (pl (filter-map tree->path (append ts1 ts2))))
390
532
    (for-each update-all-path pl)))
391
533
 
392
534
(define (id-set-visited id)
400
542
 
401
543
(define (navigation-item-follow hit)
402
544
  (let* ((source (navigation-source hit))
403
 
         (target (navigation-target hit)))
 
545
         (target (navigation-target hit)))
404
546
    (id-set-visited source)
405
547
    (and-with target-id (vertex->id target)
406
548
      (id-set-visited target-id))
421
563
  (:synopsis "Follow one of the links in the navigation list @nl.")
422
564
  (with types (navigation-list-types nl)
423
565
    (if (and (>= (length types) 2) (in? "automatic" types))
424
 
        (with auto-nl (navigation-list-filter nl "automatic" #t #f)
425
 
          (set! nl (list-difference nl auto-nl))))
 
566
        (with auto-nl (navigation-list-filter nl "automatic" #t #f)
 
567
          (set! nl (list-difference nl auto-nl))))
426
568
    (with xtypes (navigation-list-xtypes nl)
427
569
      (cond ((null? xtypes) (noop))
428
 
            ((and (navigation-build-link-pages?) (>= (length nl) 2))
429
 
             (id-set-visited (navigation-source (car nl)))
430
 
             (build-navigation-page nl))
431
 
            ((null? (cdr xtypes)) (navigation-item-follow (car nl)))
432
 
            (else
433
 
             (set! the-navigation-list nl)
434
 
             (interactive navigation-list-follow-xtyped))))))
 
570
            ((and (navigation-build-link-pages?) (>= (length nl) 2))
 
571
             (id-set-visited (navigation-source (car nl)))
 
572
             (build-navigation-page nl))
 
573
            ((null? (cdr xtypes)) (navigation-item-follow (car nl)))
 
574
            (else
 
575
             (set! the-navigation-list nl)
 
576
             (interactive navigation-list-follow-xtyped))))))
435
577
 
436
578
(tm-define (link-follow-ids ids event)
437
579
  (:synopsis "Follow one of the links for identifiers in @ids.")
442
584
(tm-define (locus-link-follow)
443
585
  (:synopsis "Follow one of the links in the current locus.")
444
586
  (let* ((ts (link-active-upwards (cursor-tree)))
445
 
         (ids (append-map tree->ids ts)))
 
587
         (ids (append-map tree->ids ts)))
446
588
    (link-follow-ids ids "click")))