f61f0830e5
argument and uses that to order the buttons in the DrRacket panel. Also, order all of the buttons via these numbers in a more sane way
163 lines
6.4 KiB
Racket
163 lines
6.4 KiB
Racket
#lang racket/base
|
|
(provide (struct-out src-wrap)
|
|
files
|
|
sexp-files)
|
|
|
|
(require (for-syntax racket/base))
|
|
|
|
(define-struct src-wrap (obj srcloc)
|
|
#:transparent)
|
|
|
|
(define-syntax (retain-src stx)
|
|
|
|
(define (to-src-wrap stx)
|
|
(cond
|
|
[(syntax? stx)
|
|
#`(src-wrap #,(to-src-wrap (syntax-e stx))
|
|
(vector '#,(syntax-source stx)
|
|
#,(syntax-line stx)
|
|
#,(syntax-column stx)
|
|
#,(syntax-position stx)
|
|
#,(syntax-span stx)))]
|
|
[(pair? stx)
|
|
#`(cons #,(to-src-wrap (car stx))
|
|
#,(to-src-wrap (cdr stx)))]
|
|
[else
|
|
#`'#,stx]))
|
|
|
|
(syntax-case stx ()
|
|
[(_ args ...)
|
|
(with-syntax ([(args ...)
|
|
(map to-src-wrap
|
|
(syntax->list #'(args ...)))])
|
|
#'(list args ...))]))
|
|
|
|
(define files
|
|
(list (list "info.rkt"
|
|
(retain-src
|
|
setup/infotab
|
|
(define drracket-tools (list (list "tool.rkt")))))
|
|
(list "tool.rkt"
|
|
(retain-src
|
|
racket/base
|
|
(require drracket/tool
|
|
racket/class
|
|
racket/gui/base
|
|
racket/unit
|
|
mrlib/switchable-button)
|
|
(provide tool@)
|
|
|
|
(define secret-key "egg")
|
|
(define to-insert "easter ")
|
|
|
|
(define tool@
|
|
(unit
|
|
(import drracket:tool^)
|
|
(export drracket:tool-exports^)
|
|
|
|
(define easter-egg-mixin
|
|
(mixin ((class->interface text%)) ()
|
|
|
|
(inherit begin-edit-sequence
|
|
end-edit-sequence
|
|
insert
|
|
get-text)
|
|
|
|
(define/augment (on-insert start len)
|
|
(begin-edit-sequence))
|
|
(define/augment (after-insert start len)
|
|
(check-range (max 0 (- start (string-length secret-key)))
|
|
(+ start len))
|
|
(end-edit-sequence))
|
|
|
|
(define/augment (on-delete start len)
|
|
(begin-edit-sequence))
|
|
(define/augment (after-delete start len)
|
|
(check-range (max 0 (- start (string-length secret-key)))
|
|
start)
|
|
(end-edit-sequence))
|
|
|
|
(define/private (check-range start stop)
|
|
(let/ec k
|
|
(for ([x (in-range start stop)])
|
|
(define after-x
|
|
(get-text x (+ x (string-length secret-key))))
|
|
(when (string=? after-x secret-key)
|
|
(define before-x
|
|
(get-text (max 0 (- x (string-length to-insert))) x))
|
|
(unless (string=? before-x to-insert)
|
|
(insert to-insert x x)
|
|
(k (void)))))))
|
|
|
|
(super-new)))
|
|
|
|
(define reverse-button-mixin
|
|
(mixin (drracket:unit:frame<%>) ()
|
|
(super-new)
|
|
(inherit get-button-panel
|
|
get-definitions-text)
|
|
(inherit register-toolbar-button)
|
|
|
|
(let ([btn
|
|
(new switchable-button%
|
|
[label "Reverse Definitions"]
|
|
[callback (λ (button)
|
|
(reverse-content
|
|
(get-definitions-text)))]
|
|
[parent (get-button-panel)]
|
|
[bitmap reverse-content-bitmap])])
|
|
(register-toolbar-button btn #:number 11)
|
|
(send (get-button-panel) change-children
|
|
(λ (l)
|
|
(cons btn (remq btn l)))))))
|
|
|
|
(define reverse-content-bitmap
|
|
(let* ([bmp (make-bitmap 16 16)]
|
|
[bdc (make-object bitmap-dc% bmp)])
|
|
(send bdc erase)
|
|
(send bdc set-smoothing 'smoothed)
|
|
(send bdc set-pen "black" 1 'transparent)
|
|
(send bdc set-brush "blue" 'solid)
|
|
(send bdc draw-ellipse 2 2 8 8)
|
|
(send bdc set-brush "red" 'solid)
|
|
(send bdc draw-ellipse 6 6 8 8)
|
|
(send bdc set-bitmap #f)
|
|
bmp))
|
|
|
|
(define (reverse-content text)
|
|
(for ([x (in-range 1 (send text last-position))])
|
|
(send text split-snip x))
|
|
(define snips
|
|
(let loop ([snip (send text find-first-snip)])
|
|
(if snip
|
|
(cons snip (loop (send snip next)))
|
|
'())))
|
|
(define released-snips
|
|
(for/list ([snip (in-list snips)]
|
|
#:when (send snip release-from-owner))
|
|
snip))
|
|
(for ([x (in-list released-snips)])
|
|
(send text insert x 0 0)))
|
|
|
|
(define (phase1) (void))
|
|
(define (phase2) (void))
|
|
|
|
(drracket:get/extend:extend-definitions-text easter-egg-mixin)
|
|
(drracket:get/extend:extend-unit-frame reverse-button-mixin)))))))
|
|
|
|
|
|
(define (to-sexp x)
|
|
(let loop ([sw x])
|
|
(cond
|
|
[(src-wrap? sw)
|
|
(loop (src-wrap-obj sw))]
|
|
[(pair? sw)
|
|
(cons (loop (car sw)) (loop (cdr sw)))]
|
|
[else sw])))
|
|
|
|
(define sexp-files
|
|
(for/list ([file (in-list files)])
|
|
(list (list-ref file 0)
|
|
(to-sexp (car (list-ref file 1)))
|
|
(to-sexp (cdr (list-ref file 1))))))
|