1  #lang racket/base
 2  
 3  (require racket/gui/base racket/class)
 4  
 5  (provide snip-canvas%)
 6  
 7  (define snip-canvas%
 8    (class editor-canvas%
 9      (init parent
10            make-snip
11            [style null]
12            [label #f]
13            [horizontal-inset 5]
14            [vertical-inset 5]
15            [enabled #t]
16            [vert-margin 0]
17            [horiz-margin 0]
18            [min-width 0]
19            [min-height 0]
20            [stretchable-width #t]
21            [stretchable-height #t])
22      
23      (define snip #f)
24      (define text (new read-only-text%))
25      (send text set-writable #f)
26      
27      (define/public (get-snip) snip)
28      
29      (define/override (on-size w h)
30        (update-snip w h)
31        (super on-size w h))
32      
33      (define (update-snip w h)
34        (define snip-w (max 0 (- w (* 2 horizontal-inset))))
35        (define snip-h (max 0 (- h (* 2 vertical-inset))))
36        (cond [snip  (send snip resize snip-w snip-h)]
37              [else  (set-snip (make-snip snip-w snip-h))]))
38      
39      (define (set-snip s)
40        (unless (is-a? s snip%)
41          (raise-type-error 'set-snip "snip%" s))
42        (set! snip s)
43        (send text set-writable #t)
44        (send text begin-edit-sequence #f)
45        (send text erase)
46        (send text insert snip)
47        (send text end-edit-sequence)
48        (send text set-writable #f))
49      
50      (super-new [parent parent]
51                 [editor text]
52                 [horizontal-inset horizontal-inset]
53                 [vertical-inset vertical-inset]
54                 [label label]
55                 [enabled enabled]
56                 [style (list* 'no-hscroll 'no-vscroll style)]
57                 [vert-margin vert-margin]
58                 [horiz-margin horiz-margin]
59                 [min-width min-width]
60                 [min-height min-height]
61                 [stretchable-width stretchable-width]
62                 [stretchable-height stretchable-height])))
63  
64  (define read-only-text%
65    (class text%
66      (define writable? #t)
67      (define/public (set-writable w?) (set! writable? w?))
68      
69      (define/augment (can-change-style? start len) writable?)
70      (define/augment (can-delete? start len) writable?)
71      (define/augment (can-insert? start len) writable?)
72      (define/augment (can-load-file? filename format) writable?)
73      (define/augment (can-save-file? filename format) writable?)
74      (define/override (can-do-edit-operation? op [recursive? #t])
75        (case op
76          [(copy select-all)  #t]
77          [else    writable?]))
78      
79      (super-new)
80      (send this hide-caret #t)))