305 lines
11 KiB
Scheme
305 lines
11 KiB
Scheme
#|
|
|
|
|
CODE COPIED (with permission ...) from syntax-browser.ss
|
|
desperately seeking abstraction.
|
|
|
|
Marshalling (and hence the 'read' method of the snipclass omitted for fast prototyping
|
|
|
|
|#
|
|
|
|
(module bindings-browser mzscheme
|
|
(require (lib "pretty.ss")
|
|
(lib "list.ss")
|
|
(lib "class.ss")
|
|
(lib "mred.ss" "mred")
|
|
(lib "match.ss")
|
|
(lib "string.ss")
|
|
(lib "marks.ss" "stepper" "private")
|
|
(lib "contract.ss"))
|
|
|
|
(provide render-bindings/snip)
|
|
|
|
(define (render-bindings/snip stx) (make-object bindings-snip% stx))
|
|
|
|
(define bindings-snipclass%
|
|
(class snip-class%
|
|
|
|
; not overriding read
|
|
(super-instantiate ())))
|
|
|
|
(define bindings-snipclass (make-object bindings-snipclass%))
|
|
(send bindings-snipclass set-version 1)
|
|
(send bindings-snipclass set-classname "drscheme:bindings-snipclass%")
|
|
(send (get-the-snip-class-list) add bindings-snipclass)
|
|
|
|
(define bindings-snip%
|
|
(class editor-snip%
|
|
(init-field bindings)
|
|
|
|
(unless ((flat-contract-predicate (listof (list/c syntax? any/c))) bindings)
|
|
(error 'bindings-snip% "expected bindings association list, given ~v" bindings))
|
|
|
|
(define/public (get-bindings) bindings)
|
|
|
|
(define/override (copy) (make-object bindings-snip% bindings))
|
|
(define/override (write stream)
|
|
(error 'bindings-snip "'write' not implemented for bindings-snip"))
|
|
|
|
(define output-text (make-object text%))
|
|
(define output-port (make-text-port output-text))
|
|
|
|
(define/private (make-modern text)
|
|
(send text change-style
|
|
(make-object style-delta% 'change-family 'modern)
|
|
0
|
|
(send text last-position)))
|
|
|
|
(begin (parameterize ([current-output-port output-port]
|
|
[pretty-print-columns 30])
|
|
(for-each
|
|
(λ (binding-pair)
|
|
(let* ([stx (car binding-pair)]
|
|
[value (cadr binding-pair)])
|
|
; this totally destroys the 'output-port' abstraction. I don't know
|
|
; how to enrich the notion of an output-port to get 'bold'ing to
|
|
; work otherwise...
|
|
(let* ([before (send output-text last-position)])
|
|
(pretty-print (syntax-object->datum stx))
|
|
(let* ([post-newline (send output-text last-position)])
|
|
(send output-text delete post-newline) ; delete the trailing \n. yuck!
|
|
(send output-text insert " ")
|
|
(send output-text change-style
|
|
(make-object style-delta% 'change-bold)
|
|
before (- post-newline 1)))
|
|
(pretty-print value))))
|
|
bindings))
|
|
(send output-text delete (send output-text last-position)) ; delete final trailing \n
|
|
(make-modern output-text))
|
|
|
|
(define outer-t (make-object text%))
|
|
|
|
(super-new
|
|
(editor outer-t)
|
|
(with-border? #f)
|
|
(left-margin 3)
|
|
(top-margin 0)
|
|
(right-margin 0)
|
|
(bottom-margin 0)
|
|
(left-inset 1)
|
|
(top-inset 0)
|
|
(right-inset 0)
|
|
(bottom-inset 0))
|
|
|
|
(define inner-t (make-object text%))
|
|
(define inner-es (instantiate editor-snip% ()
|
|
(editor inner-t)
|
|
(with-border? #f)
|
|
(left-margin 0)
|
|
(top-margin 0)
|
|
(right-margin 0)
|
|
(bottom-margin 0)
|
|
(left-inset 0)
|
|
(top-inset 0)
|
|
(right-inset 0)
|
|
(bottom-inset 0)))
|
|
|
|
(define details-shown? #t)
|
|
|
|
(inherit show-border set-tight-text-fit)
|
|
(define/private (hide-details)
|
|
(when details-shown?
|
|
(send outer-t lock #f)
|
|
(show-border #f)
|
|
(set-tight-text-fit #t)
|
|
(send outer-t release-snip inner-es)
|
|
(send outer-t delete (send outer-t last-position))
|
|
(send outer-t lock #t)
|
|
(set! details-shown? #f)))
|
|
|
|
(define/private (show-details)
|
|
(unless details-shown?
|
|
(send outer-t lock #f)
|
|
(show-border #t)
|
|
(set-tight-text-fit #f)
|
|
(send outer-t insert #\newline
|
|
(send outer-t last-position)
|
|
(send outer-t last-position))
|
|
(send outer-t insert inner-es
|
|
(send outer-t last-position)
|
|
(send outer-t last-position))
|
|
(send outer-t lock #t)
|
|
(set! details-shown? #t)))
|
|
|
|
(send outer-t insert (make-object turn-snip%
|
|
(λ () (hide-details))
|
|
(λ () (show-details))))
|
|
(send outer-t insert (format "bindings\n"))
|
|
(send outer-t insert inner-es)
|
|
(make-modern outer-t)
|
|
|
|
(send inner-t insert (instantiate editor-snip% ()
|
|
(editor output-text)
|
|
(with-border? #f)
|
|
(left-margin 0)
|
|
(top-margin 0)
|
|
(right-margin 0)
|
|
(bottom-margin 0)
|
|
(left-inset 0)
|
|
(top-inset 0)
|
|
(right-inset 0)
|
|
(bottom-inset 0)))
|
|
(send inner-t change-style (make-object style-delta% 'change-alignment 'top) 0 2)
|
|
|
|
(send output-text hide-caret #t)
|
|
(send inner-t hide-caret #t)
|
|
(send outer-t hide-caret #t)
|
|
(send output-text lock #t)
|
|
(send inner-t lock #t)
|
|
(send outer-t lock #t)
|
|
|
|
(hide-details)
|
|
|
|
(inherit set-snipclass)
|
|
(set-snipclass bindings-snipclass)))
|
|
|
|
(define black-style-delta (make-object style-delta% 'change-normal-color))
|
|
(define green-style-delta (make-object style-delta%))
|
|
(send green-style-delta set-delta-foreground "forest green")
|
|
|
|
(define turn-snip%
|
|
(class snip%
|
|
|
|
(init-field on-up on-down)
|
|
|
|
;; state : (union 'up 'down 'up-click 'down-click))
|
|
(init-field [state 'up])
|
|
|
|
(define/override (copy)
|
|
(instantiate turn-snip% ()
|
|
(on-up on-up)
|
|
(on-down on-down)
|
|
(state state)))
|
|
|
|
(define/override (draw dc x y left top right bottom dx dy draw-caret)
|
|
(let ([bitmap (case state
|
|
[(up) up-bitmap]
|
|
[(down) down-bitmap]
|
|
[(up-click) up-click-bitmap]
|
|
[(down-click) down-click-bitmap])])
|
|
(cond
|
|
[(send bitmap ok?)
|
|
(send dc draw-bitmap bitmap x y)]
|
|
[(send dc draw-rectangle x y 10 10)
|
|
(send dc drawline x y 10 10)])))
|
|
|
|
|
|
(define/override (get-extent dc x y w h descent space lspace rspace)
|
|
(set-box/f! descent 0)
|
|
(set-box/f! space 0)
|
|
(set-box/f! lspace 0)
|
|
(set-box/f! rspace 0)
|
|
(set-box/f! w arrow-snip-width)
|
|
(set-box/f! h arrow-snip-height))
|
|
|
|
(define/override (on-event dc x y editorx editory evt)
|
|
(let ([snip-evt-x (- (send evt get-x) x)]
|
|
[snip-evt-y (- (send evt get-y) y)])
|
|
(cond
|
|
[(send evt button-down? 'left)
|
|
(set-state (case state
|
|
[(up) 'up-click]
|
|
[(down) 'down-click]
|
|
[else 'down-click]))]
|
|
[(and (send evt button-up? 'left)
|
|
(<= 0 snip-evt-x arrow-snip-width)
|
|
(<= 0 snip-evt-y arrow-snip-height))
|
|
(set-state (case state
|
|
[(up up-click)
|
|
(on-down)
|
|
'down]
|
|
[(down down-click)
|
|
(on-up)
|
|
'up]
|
|
[else 'down]))]
|
|
[(send evt button-up? 'left)
|
|
(set-state (case state
|
|
[(up up-click) 'up]
|
|
[(down down-click) 'down]
|
|
[else 'up]))]
|
|
[(and (send evt get-left-down)
|
|
(send evt dragging?)
|
|
(<= 0 snip-evt-x arrow-snip-width)
|
|
(<= 0 snip-evt-y arrow-snip-height))
|
|
(set-state (case state
|
|
[(up up-click) 'up-click]
|
|
[(down down-click) 'down-click]
|
|
[else 'up-click]))]
|
|
[(and (send evt get-left-down)
|
|
(send evt dragging?))
|
|
(set-state (case state
|
|
[(up up-click) 'up]
|
|
[(down down-click) 'down]
|
|
[else 'up-click]))]
|
|
[else
|
|
(super on-event dc x y editorx editory evt)])))
|
|
|
|
(inherit get-admin)
|
|
(define/private (set-state new-state)
|
|
(unless (eq? state new-state)
|
|
(set! state new-state)
|
|
(let ([admin (get-admin)])
|
|
(when admin
|
|
(send admin needs-update this 0 0 arrow-snip-width arrow-snip-height)))))
|
|
|
|
(define/override (adjust-cursor dc x y editorx editory event) arrow-snip-cursor)
|
|
|
|
(super-instantiate ())
|
|
|
|
(inherit get-flags set-flags)
|
|
(set-flags (cons 'handles-events (get-flags)))))
|
|
|
|
(define (set-box/f! b v) (when (box? b) (set-box! b v)))
|
|
|
|
(define down-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-down.png")))
|
|
(define up-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-up.png")))
|
|
(define down-click-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-down-click.png")))
|
|
(define up-click-bitmap (make-object bitmap% (build-path (collection-path "icons") "turn-up-click.png")))
|
|
(define arrow-snip-height
|
|
(max 10
|
|
(send up-bitmap get-height)
|
|
(send down-bitmap get-height)
|
|
(send up-click-bitmap get-height)
|
|
(send down-click-bitmap get-height)))
|
|
(define arrow-snip-width
|
|
(max 10
|
|
(send up-bitmap get-width)
|
|
(send down-bitmap get-width)
|
|
(send up-click-bitmap get-width)
|
|
(send down-click-bitmap get-width)))
|
|
(define arrow-snip-cursor (make-object cursor% 'arrow))
|
|
|
|
;; make-text-port : text -> port
|
|
;; builds a port from a text object.
|
|
(define (make-text-port text)
|
|
(make-output-port #f
|
|
always-evt
|
|
(λ (s start end flush?)
|
|
(send text insert (substring s start end)
|
|
(send text last-position)
|
|
(send text last-position))
|
|
(- end start))
|
|
void)))
|
|
|
|
; one trivial test case:
|
|
;
|
|
;(require bindings-browser)
|
|
;
|
|
;(let ([es (render-bindings/snip `((,#`a 3) (,#`b 4) (,#`c (1 3 4))))])
|
|
; (define f (make-object frame% "frame" #f 850 500))
|
|
; (define mb (make-object menu-bar% f))
|
|
; (define edit-menu (make-object menu% "Edit" mb))
|
|
; (define t (make-object text%))
|
|
; (define ec (make-object editor-canvas% f t))
|
|
; (append-editor-operation-menu-items edit-menu)
|
|
; (send t insert es)
|
|
; (send f show #t)) |