249 lines
8.3 KiB
Scheme
249 lines
8.3 KiB
Scheme
|
|
#lang scheme/base
|
|
(require scheme/class
|
|
mred
|
|
framework/framework
|
|
scheme/list
|
|
scheme/match
|
|
syntax/boundmap
|
|
macro-debugger/util/class-iop
|
|
"interfaces.ss"
|
|
"controller.ss"
|
|
"display.ss"
|
|
"keymap.ss"
|
|
"hrule-snip.ss"
|
|
"properties.ss"
|
|
"text.ss"
|
|
"util.ss"
|
|
"../util/mpi.ss")
|
|
(provide widget%)
|
|
|
|
;; widget%
|
|
;; A syntax widget creates its own syntax-controller.
|
|
(define widget%
|
|
(class* object% (syntax-browser<%> widget-hooks<%>)
|
|
(init parent)
|
|
(init-field config)
|
|
|
|
(field [controller (new controller%)])
|
|
|
|
(define -main-panel
|
|
(new vertical-panel% (parent parent)))
|
|
(define -split-panel
|
|
(new panel:horizontal-dragable% (parent -main-panel)))
|
|
(define -text (new browser-text%))
|
|
(define -ecanvas
|
|
(new editor-canvas% (parent -split-panel) (editor -text)))
|
|
(define -props-panel (new horizontal-panel% (parent -split-panel)))
|
|
(define props
|
|
(new properties-view%
|
|
(parent -props-panel)
|
|
(controller controller)))
|
|
|
|
(define/public (setup-keymap)
|
|
(new syntax-keymap%
|
|
(editor -text)
|
|
(controller controller)
|
|
(config config)))
|
|
|
|
(send -text set-styles-sticky #f)
|
|
(send -text lock #t)
|
|
|
|
(define/public (show-props show?)
|
|
(internal-show-props show?))
|
|
|
|
(define/private (internal-show-props show?)
|
|
(if show?
|
|
(unless (send -props-panel is-shown?)
|
|
(let ([p (send: config config<%> get-props-percentage)])
|
|
(send -split-panel add-child -props-panel)
|
|
(update-props-percentage p))
|
|
(send -props-panel show #t))
|
|
(when (send -props-panel is-shown?)
|
|
(send -split-panel delete-child -props-panel)
|
|
(send -props-panel show #f))))
|
|
|
|
(define/private (update-props-percentage p)
|
|
(send -split-panel set-percentages
|
|
(list (- 1 p) p)))
|
|
|
|
(define/private (props-panel-shown?)
|
|
(send -props-panel is-shown?))
|
|
|
|
;;
|
|
|
|
(define/public (get-controller)
|
|
controller)
|
|
|
|
;;
|
|
|
|
(define/public (get-main-panel)
|
|
-main-panel)
|
|
|
|
(define/public (shutdown)
|
|
(when (props-panel-shown?)
|
|
(send: config config<%> set-props-percentage
|
|
(cadr (send -split-panel get-percentages)))))
|
|
|
|
;; syntax-browser<%> Methods
|
|
|
|
(define/public (add-text text)
|
|
(with-unlock -text
|
|
(send -text insert text)))
|
|
|
|
(define/public (add-error-text text)
|
|
(with-unlock -text
|
|
(let ([a (send -text last-position)])
|
|
(send -text insert text)
|
|
(let ([b (send -text last-position)])
|
|
(send -text change-style error-text-style a b)))))
|
|
|
|
(define/public (add-clickback text handler)
|
|
(with-unlock -text
|
|
(let ([a (send -text last-position)])
|
|
(send -text insert text)
|
|
(let ([b (send -text last-position)])
|
|
(send -text set-clickback a b handler)
|
|
(send -text change-style clickback-style a b)))))
|
|
|
|
(define/public (add-syntax stx
|
|
#:binder-table [alpha-table #f]
|
|
#:shift-table [shift-table #f]
|
|
#:definites [definites null]
|
|
#:hi-colors [hi-colors null]
|
|
#:hi-stxss [hi-stxss null])
|
|
(define (get-binders id)
|
|
(define binder
|
|
(module-identifier-mapping-get alpha-table id (lambda () #f)))
|
|
(if shift-table
|
|
(cons binder (hash-ref shift-table binder null))
|
|
(list binder)))
|
|
(let ([display (internal-add-syntax stx)]
|
|
[definite-table (make-hasheq)])
|
|
(for-each (lambda (hi-stxs hi-color)
|
|
(send: display display<%>
|
|
highlight-syntaxes hi-stxs hi-color))
|
|
hi-stxss
|
|
hi-colors)
|
|
(for ([definite definites])
|
|
(hash-set! definite-table definite #t)
|
|
(when shift-table
|
|
(for ([shifted-definite (hash-ref shift-table definite null)])
|
|
(hash-set! definite-table shifted-definite #t))))
|
|
(when alpha-table
|
|
(let ([range (send: display display<%> get-range)]
|
|
[start (send: display display<%> get-start-position)])
|
|
(let* ([binders0
|
|
(module-identifier-mapping-map alpha-table (lambda (k v) k))]
|
|
[binders
|
|
(apply append (map get-binders binders0))])
|
|
(send: display display<%> underline-syntaxes binders))
|
|
(for ([id (send: range range<%> get-identifier-list)])
|
|
(define definite? (hash-ref definite-table id #f))
|
|
(when #f ;; DISABLED
|
|
(add-binding-billboard start range id definite?))
|
|
(for ([binder (get-binders id)])
|
|
(for ([binder-r (send: range range<%> get-ranges binder)])
|
|
(for ([id-r (send: range range<%> get-ranges id)])
|
|
(add-binding-arrow start binder-r id-r definite?)))))))
|
|
(void)))
|
|
|
|
(define/private (add-binding-arrow start binder-r id-r definite?)
|
|
(if definite?
|
|
(send -text add-arrow
|
|
(+ start (car binder-r))
|
|
(+ start (cdr binder-r))
|
|
(+ start (car id-r))
|
|
(+ start (cdr id-r))
|
|
"blue")
|
|
(send -text add-question-arrow
|
|
(+ start (car binder-r))
|
|
(+ start (cdr binder-r))
|
|
(+ start (car id-r))
|
|
(+ start (cdr id-r))
|
|
"purple")))
|
|
|
|
(define/private (add-binding-billboard start range id definite?)
|
|
(match (identifier-binding id)
|
|
[(list-rest src-mod src-name nom-mod nom-name _)
|
|
(for-each (lambda (id-r)
|
|
(send -text add-billboard
|
|
(+ start (car id-r))
|
|
(+ start (cdr id-r))
|
|
(string-append "from " (mpi->string src-mod))
|
|
(if definite? "blue" "purple")))
|
|
(send: range range<%> get-ranges id))]
|
|
[_ (void)]))
|
|
|
|
(define/public (add-separator)
|
|
(with-unlock -text
|
|
(send* -text
|
|
(insert (new hrule-snip%))
|
|
(insert "\n"))))
|
|
|
|
(define/public (erase-all)
|
|
(with-unlock -text
|
|
(send -text erase)
|
|
(send -text delete-all-drawings))
|
|
(send: controller displays-manager<%> remove-all-syntax-displays))
|
|
|
|
(define/public (get-text) -text)
|
|
|
|
;; internal-add-syntax : syntax -> display
|
|
(define/private (internal-add-syntax stx)
|
|
(with-unlock -text
|
|
(let ([display
|
|
(print-syntax-to-editor stx -text controller config
|
|
(calculate-columns)
|
|
(send -text last-position))])
|
|
(send* -text
|
|
(insert "\n")
|
|
;;(scroll-to-position current-position)
|
|
)
|
|
display)))
|
|
|
|
(define/private (calculate-columns)
|
|
(define style (code-style -text (send: config config<%> get-syntax-font-size)))
|
|
(define char-width (send style get-text-width (send -ecanvas get-dc)))
|
|
(define-values (canvas-w canvas-h) (send -ecanvas get-client-size))
|
|
(sub1 (inexact->exact (floor (/ canvas-w char-width)))))
|
|
|
|
;; Initialize
|
|
(super-new)
|
|
(setup-keymap)
|
|
|
|
(send: config config<%> listen-props-shown?
|
|
(lambda (show?)
|
|
(show-props show?)))
|
|
(send: config config<%> listen-props-percentage
|
|
(lambda (p)
|
|
(update-props-percentage p)))
|
|
(internal-show-props (send: config config<%> get-props-shown?))))
|
|
|
|
|
|
(define clickback-style
|
|
(let ([sd (new style-delta%)])
|
|
(send sd set-delta 'change-toggle-underline)
|
|
(send sd set-delta-foreground "blue")
|
|
sd))
|
|
|
|
(define error-text-style
|
|
(let ([sd (new style-delta%)])
|
|
(send sd set-delta 'change-italic)
|
|
(send sd set-delta-foreground "red")
|
|
sd))
|
|
|
|
;; Specialized classes for widget
|
|
|
|
(define browser-text%
|
|
(class (text:arrows-mixin
|
|
(text:tacking-mixin
|
|
(text:mouse-drawings-mixin
|
|
(text:hover-mixin
|
|
(text:hide-caret/selection-mixin
|
|
(editor:standard-style-list-mixin text:basic%))))))
|
|
(inherit set-autowrap-bitmap)
|
|
(define/override (default-style-name) "Basic")
|
|
(super-new (auto-wrap #t))
|
|
(set-autowrap-bitmap #f)))
|