snip-decorated.rkt (6074B)
1 #lang racket/base 2 (require racket/class 3 racket/gui/base 4 (only-in mzlib/string read-from-string) 5 racket/class/iop 6 macro-debugger/syntax-browser/interfaces 7 "controller.rkt" 8 "properties.rkt" 9 "prefs.rkt" 10 "util.rkt" 11 (except-in "snip.rkt" 12 snip-class)) 13 14 (provide decorated-syntax-snip% 15 snip-class) 16 17 (define top-aligned 18 (make-object style-delta% 'change-alignment 'top)) 19 20 (define-struct styled (contents style clickback)) 21 22 ;; clicky-snip% 23 (define clicky-snip% 24 (class* editor-snip% () 25 26 (init-field [open-style '(border)] 27 [closed-style '(tight-text-fit)]) 28 29 (inherit set-margin 30 set-inset 31 set-snipclass 32 set-tight-text-fit 33 show-border 34 get-admin) 35 36 (define -outer (new text%)) 37 (super-new (editor -outer) (with-border? #f)) 38 (set-margin 2 2 2 2) 39 (set-inset 2 2 2 2) 40 ;;(set-margin 3 0 0 0) 41 ;;(set-inset 1 0 0 0) 42 ;;(set-margin 0 0 0 0) 43 ;;(set-inset 0 0 0 0) 44 45 (define/public (closed-contents) null) 46 (define/public (open-contents) null) 47 48 (define open? #f) 49 50 (define/public (refresh-contents) 51 (with-unlock -outer 52 (send -outer erase) 53 (do-style (if open? open-style closed-style)) 54 (outer:insert (if open? (hide-icon) (show-icon)) 55 style:hyper 56 (if open? 57 (lambda _ 58 (set! open? #f) 59 (refresh-contents)) 60 (lambda _ 61 (set! open? #t) 62 (refresh-contents)))) 63 (for-each (lambda (s) (outer:insert s)) 64 (if open? (open-contents) (closed-contents))) 65 (send -outer change-style top-aligned 0 (send -outer last-position)))) 66 67 (define/private (do-style style) 68 (show-border (memq 'border style)) 69 (set-tight-text-fit (memq 'tight-text-fit style))) 70 71 (define/private outer:insert 72 (case-lambda 73 [(obj) 74 (if (styled? obj) 75 (outer:insert (styled-contents obj) 76 (styled-style obj) 77 (styled-clickback obj)) 78 (outer:insert obj style:normal))] 79 [(text style) 80 (outer:insert text style #f)] 81 [(text style clickback) 82 (let ([start (send -outer last-position)]) 83 (send -outer insert text) 84 (let ([end (send -outer last-position)]) 85 (send -outer change-style style start end #f) 86 (when clickback 87 (send -outer set-clickback start end clickback))))])) 88 89 (send -outer hide-caret #t) 90 (send -outer lock #t) 91 (refresh-contents) 92 )) 93 94 ;; decorated-syntax-snip% 95 (define decorated-syntax-snip% 96 (class* clicky-snip% (readable-snip<%>) 97 (init-field ((stx syntax))) 98 (init-field [controller (new controller%)]) 99 (init-field [config (new syntax-prefs%)]) 100 101 (inherit set-snipclass 102 refresh-contents) 103 104 (define the-syntax-snip 105 (new syntax-snip% 106 (syntax stx) 107 (controller controller) 108 (config config))) 109 (define the-summary 110 (let* ([t (new text%)] 111 [es (new editor-snip% (editor t) (with-border? #f))]) 112 (send es set-margin 0 0 0 0) 113 (send es set-inset 0 0 0 0) 114 (send t insert (format "~s" stx)) 115 es)) 116 117 (define properties-snip 118 (new properties-container-snip% 119 (controller controller))) 120 121 (define/override (closed-contents) 122 (list the-summary)) 123 124 (define/override (open-contents) 125 (list " " 126 the-syntax-snip 127 " " 128 properties-snip)) 129 130 ;; Snip methods 131 (define/override (copy) 132 (new decorated-syntax-snip% 133 (syntax stx) 134 (controller controller) 135 (config config))) 136 (define/override (write stream) 137 (send stream put 138 (string->bytes/utf-8 139 (format "~s" (marshall-syntax stx))))) 140 (define/public (read-special src line col pos) 141 (send the-syntax-snip read-special src line col pos)) 142 143 (send/i config config<%> listen-props-shown? 144 (lambda (?) (refresh-contents))) 145 146 (super-new) 147 (set-snipclass snip-class) 148 )) 149 150 (define properties-container-snip% 151 (class clicky-snip% 152 (init controller) 153 154 (define properties-snip 155 (new properties-snip% (controller controller))) 156 157 (define/override (open-contents) 158 (list #;(show-properties-icon) 159 properties-snip)) 160 161 (define/override (closed-contents) 162 (list (show-properties-icon))) 163 164 (super-new (open-style '()) 165 (closed-style '())))) 166 167 (define style:normal (make-object style-delta% 'change-normal)) 168 (define style:hyper 169 (let ([s (make-object style-delta% 'change-normal)]) 170 (send s set-delta 'change-toggle-underline) 171 (send s set-delta-foreground "blue") 172 s)) 173 (define style:green 174 (let ([s (make-object style-delta% 'change-normal)]) 175 (send s set-delta-foreground "darkgreen") 176 s)) 177 (define style:bold 178 (let ([s (make-object style-delta% 'change-normal)]) 179 (send s set-delta 'change-bold) 180 s)) 181 182 (define (show-icon) 183 (make-object image-snip% 184 (collection-file-path "turn-up.png" "icons"))) 185 (define (hide-icon) 186 (make-object image-snip% 187 (collection-file-path "turn-down.png" "icons"))) 188 189 (define (show-properties-icon) 190 (make-object image-snip% 191 (collection-file-path "syncheck.png" "icons"))) 192 193 194 ;; SNIPCLASS 195 196 ;; COPIED AND MODIFIED from mrlib/syntax-browser.rkt 197 (define decorated-syntax-snipclass% 198 (class snip-class% 199 (define/override (read stream) 200 (new decorated-syntax-snip% 201 (syntax (unmarshall-syntax 202 (read-from-string (send stream get-bytes)))))) 203 (super-new))) 204 205 (define snip-class (make-object decorated-syntax-snipclass%)) 206 (send snip-class set-version 2) 207 (send snip-class set-classname 208 (format "~s" '(lib "macro-debugger/syntax-browser/snip-decorated.rkt")))