racket-breadcrumb/main.rkt at master · telephil/racket-breadcrumb · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
#lang racket/gui

(provide breadcrumb%
         breadcrumb-separator-slash
         breadcrumb-separator-arrow
         breadcrumb-separator-quote
         breadcrumb-separator-double-quote)

(define breadcrumb-separator-slash "/")
(define breadcrumb-separator-arrow "▶")
(define breadcrumb-separator-quote "❯")
(define breadcrumb-separator-double-quote "»")

(define breadcrumb%
  (class editor-canvas%
    (init-field
     [callback values]
     [separator breadcrumb-separator-quote])

    (define editor (new text%))

    ;; Private methods
    (define/private (add-path-button label path)
      (define start (send editor last-position))
      (send editor insert label)
      (send editor set-clickback start (send editor last-position)
            (λ (t s e) (callback path))))

    (define/private (insert-path-separator)
      (send editor insert (~a " " separator " ")))

    ;; Public methods
    (define/public (set-path! path)
      (send editor erase)
      (for ([elt path]
            [count (in-naturals 1)])
           (when (> count 1)
             (insert-path-separator))
           (add-path-button (~a elt) (take path count))))

    ;; New
    (super-new [editor editor]
               [style '(no-border no-focus no-vscroll no-hscroll)]
               [vertical-inset 0]
               [line-count 1]
               [stretchable-height #f])
    (send editor set-cursor (make-object cursor% 'arrow))))