hiding-panel.rkt (10942B)
1 #lang racket/base 2 (require racket/class 3 racket/gui/base 4 racket/match 5 racket/class/iop 6 "interfaces.rkt" 7 macro-debugger/model/hiding-policies 8 macro-debugger/util/mpi 9 framework/notify) 10 (provide macro-hiding-prefs-widget%) 11 12 (define mode:disable "Disable") 13 (define mode:standard "Standard") 14 (define mode:custom "Custom ...") 15 16 #| 17 18 TODO 19 20 - allow entry of more policies 21 - visual feedback on rules applying to selected identifier 22 (need to switch from list to editor) 23 24 |# 25 26 ;; macro-hiding-prefs-widget% 27 (define macro-hiding-prefs-widget% 28 (class* object% (hiding-prefs<%>) 29 (init parent) 30 (init-field/i (stepper widget<%>)) 31 (init-field config) 32 33 (define/public (get-policy) 34 (let ([mode (get-mode)]) 35 (cond [(not (macro-hiding-enabled?)) #f] 36 [(equal? mode mode:standard) standard-policy] 37 [(equal? mode mode:custom) (get-custom-policy)]))) 38 39 (define/private (get-custom-policy) 40 (let ([hide-racket? (send box:hide-racket get-value)] 41 [hide-libs? (send box:hide-libs get-value)] 42 [hide-contracts? (send box:hide-contracts get-value)] 43 [hide-transformers? (send box:hide-phase1 get-value)] 44 [specialized-policies (get-specialized-policies)]) 45 (policy->predicate 46 `(custom ,hide-racket? 47 ,hide-libs? 48 ,hide-contracts? 49 ,hide-transformers? 50 ,specialized-policies)))) 51 52 (define super-panel 53 (new vertical-panel% 54 (parent parent) 55 (stretchable-height #f))) 56 (define top-line-panel 57 (new horizontal-panel% 58 (parent super-panel) 59 (alignment '(left center)) 60 (stretchable-height #f))) 61 (define customize-panel 62 (new horizontal-panel% 63 (parent super-panel) 64 (stretchable-height #f) 65 (alignment '(left top)) 66 (style '(deleted)))) 67 (define left-pane 68 (new vertical-pane% 69 (parent customize-panel) 70 (stretchable-width #f) 71 (alignment '(left top)))) 72 (define right-pane 73 (new vertical-pane% 74 (parent customize-panel))) 75 76 (define mode-selector 77 (notify:choice/notify-box 78 top-line-panel 79 "Macro hiding: " 80 (list mode:disable mode:standard mode:custom) 81 (get-field macro-hiding-mode config))) 82 (define top-line-inner-panel 83 (new horizontal-panel% 84 (parent top-line-panel) 85 (alignment '(right center)) 86 (style '(deleted)))) 87 88 (define/private (get-mode) 89 (send/i config config<%> get-macro-hiding-mode)) 90 91 (define/private (macro-hiding-enabled?) 92 (let ([mode (get-mode)]) 93 (or (equal? mode mode:standard) 94 (and (equal? mode mode:custom) 95 (send box:hiding get-value))))) 96 97 (define/private (ensure-custom-mode) 98 (unless (equal? (get-mode) mode:custom) 99 (send/i config config<%> set-macro-hiding-mode mode:custom))) 100 101 (define/private (update-visibility) 102 (let ([customizing (equal? (get-mode) mode:custom)]) 103 (send top-line-panel change-children 104 (lambda (children) 105 (append (remq top-line-inner-panel children) 106 (if customizing (list top-line-inner-panel) null)))) 107 (send super-panel change-children 108 (lambda (children) 109 (append (remq customize-panel children) 110 (if (and customizing (send box:edit get-value)) 111 (list customize-panel) 112 null)))))) 113 114 (send/i config config<%> listen-macro-hiding-mode 115 (lambda (value) 116 (update-visibility) 117 (force-refresh))) 118 119 (define box:hiding 120 (new check-box% 121 (label "Enable macro hiding") 122 (value #t) 123 (parent top-line-inner-panel) 124 (callback (lambda (c e) (force-refresh))))) 125 (define box:edit 126 (new check-box% 127 (label "Show policy editor") 128 (parent top-line-inner-panel) 129 (value #t) 130 (callback (lambda (c e) (update-visibility))))) 131 132 (define box:hide-racket 133 (new check-box% 134 (label "Hide racket syntax") 135 (parent left-pane) 136 (value #t) 137 (callback (lambda (c e) (refresh))))) 138 (define box:hide-libs 139 (new check-box% 140 (label "Hide library syntax") 141 (parent left-pane) 142 (value #t) 143 (callback (lambda (c e) (refresh))))) 144 (define box:hide-contracts 145 (new check-box% 146 (label "Hide contracts (heuristic)") 147 (parent left-pane) 148 (value #t) 149 (callback (lambda (c e) (refresh))))) 150 (define box:hide-phase1 151 (new check-box% 152 (label "Hide phase>0") 153 (parent left-pane) 154 (value #t) 155 (callback (lambda (c e) (refresh))))) 156 157 (define look-ctl 158 (new list-box% (parent right-pane) (label "") 159 (choices null) (style '(extended)) 160 (callback 161 (lambda (c e) 162 (send delete-ctl enable (pair? (send c get-selections))))))) 163 164 (define look-button-pane 165 (new horizontal-pane% (parent right-pane) (stretchable-width #f))) 166 167 (define delete-ctl 168 (new button% (parent look-button-pane) (label "Delete rule") (enabled #f) 169 (callback (lambda _ (delete-selected) (refresh))))) 170 (define add-hide-id-button 171 (new button% (parent look-button-pane) (label "Hide macro") (enabled #f) 172 (callback (lambda _ (add-hide-identifier) (refresh))))) 173 (define add-show-id-button 174 (new button% (parent look-button-pane) (label "Show macro") (enabled #f) 175 (callback (lambda _ (add-show-identifier) (refresh))))) 176 ;;(new grow-box-spacer-pane% (parent right-pane)) 177 178 ;; Methods 179 180 (define stx #f) 181 182 ;; refresh : -> void 183 (define/public (refresh) 184 (when (macro-hiding-enabled?) 185 (send/i stepper widget<%> refresh/resynth))) 186 187 ;; force-refresh : -> void 188 (define/private (force-refresh) 189 (send/i stepper widget<%> refresh/resynth)) 190 191 ;; set-syntax : syntax/#f -> void 192 (define/public (set-syntax lstx) 193 (set! stx (and (identifier? lstx) lstx)) 194 (send add-show-id-button enable (identifier? lstx)) 195 (send add-hide-id-button enable (identifier? lstx))) 196 197 ;; A PolicyLine is an Entry 198 ;; Entry is defined in ../model/hiding-policies 199 200 ;; identifier-policies : (listof Entry) 201 (define identifier-policies null) 202 203 ;; get-specialized-policies : -> (listof Entry) 204 (define/private (get-specialized-policies) 205 identifier-policies) 206 207 (define/public (add-hide-identifier) 208 (when (identifier? stx) 209 (add-policy-line 'hide-if `(free=? ,stx)))) 210 211 (define/public (add-show-identifier) 212 (when (identifier? stx) 213 (add-policy-line 'show-if `(free=? ,stx)))) 214 215 ;; add-policy-line : 'show-if/'hide-if Condition -> void 216 (define/private (add-policy-line action condition) 217 (set! identifier-policies 218 (cons `(,action ,condition) 219 (remove-policy/condition condition identifier-policies))) 220 (update-list-view) 221 (ensure-custom-mode)) 222 223 ;; update-list-view : -> void 224 (define/private (update-list-view) 225 (send look-ctl set null) 226 (for ([policy identifier-policies]) 227 (send look-ctl append (policy->string policy) policy))) 228 229 ;; delete-selected : -> void 230 (define/private (delete-selected) 231 (define to-delete (sort (send look-ctl get-selections) <)) 232 (set! identifier-policies 233 (let loop ([i 0] [policies identifier-policies] [to-delete to-delete]) 234 (cond [(null? to-delete) policies] 235 [(= i (car to-delete)) 236 (loop (add1 i) (cdr policies) (cdr to-delete))] 237 [else 238 (cons (car policies) 239 (loop (add1 i) (cdr policies) to-delete))]))) 240 (update-list-view)) 241 242 (super-new) 243 (update-visibility))) 244 245 246 (define (remove-policy/condition condition policies) 247 (filter (lambda (p) (not (same-condition? (cadr p) condition))) 248 policies)) 249 250 251 ;; ---- 252 253 (define (policy->string policy) 254 (string-limit 200 255 (string-append 256 (case (car policy) 257 ((show-if) "show ") 258 ((hide-if) "hide ")) 259 (condition->string (cadr policy))))) 260 261 (define (string-limit size s) 262 (cond [(> (string-length s) size) 263 (string-append (substring s 0 (- size 3)) "...")] 264 [else s])) 265 266 (define (condition->string condition) 267 (match condition 268 [`(free=? ,id) 269 (let ([b (identifier-binding id)]) 270 (or #| (identifier->string id) |# 271 (cond [(list? b) 272 (let ([mod (caddr b)] 273 [name (cadddr b)]) 274 (if (self-mpi? mod) 275 (format "'~a' defined in this module" name) 276 (format "'~s' imported from ~a" name (mpi->string mod))))] 277 [else 278 (symbol->string (syntax-e id))])))] 279 [_ 280 "<condition>"])) 281 282 #| 283 (require scribble/xref 284 scribble/manual-struct 285 setup/xref) 286 287 (define xref-p (delay (load-collections-xref))) 288 289 (define (identifier->string id) 290 (define binding-info (identifier-binding id)) 291 (define xref (force xref-p)) 292 (define definition-tag 293 (and xref 294 (xref-binding->definition-tag xref binding-info #f))) 295 (and definition-tag 296 (let-values ([(path tag) (xref-tag->path+anchor xref definition-tag)]) 297 (define index-entry 298 (and path (xref-tag->index-entry xref definition-tag))) 299 (define desc 300 (and index-entry (entry-desc index-entry))) 301 (and desc 302 (let ([name (exported-index-desc-name desc)] 303 [libs (exported-index-desc-from-libs desc)]) 304 (format "'~a' from ~a" 305 name 306 (mpi->string (car libs)))))))) 307 |# 308 309 310 311 #| 312 (define (get-id-key id) 313 id 314 #; ;; FIXME 315 (let ([binding (identifier-binding id)]) 316 (get-id-key/binding id binding))) 317 318 (define (get-id-key/binding id binding) 319 (cond [(pair? binding) 320 (list (car binding) (cadr binding))] 321 [else id])) 322 323 (define (key=? key1 key2) 324 (cond [(and (identifier? key1) (identifier? key2)) 325 (free-identifier=? key1 key2)] 326 [(and (pair? key1) (pair? key2)) 327 (and (equal? (car key1) (car key2)) 328 (equal? (cadr key1) (cadr key2)))] 329 [else #f])) 330 331 (define (key->text key) 332 (cond [(pair? key) 333 (let ([name (cadddr key)] 334 [mod (caddr key)]) 335 (format "'~s' from ~a" 336 name 337 (mpi->string mod)))] 338 [else (symbol->string (syntax-e key))])) 339 |#