258 lines
8.7 KiB
Scheme
258 lines
8.7 KiB
Scheme
|
|
#lang mzscheme
|
|
(require scheme/class
|
|
mred
|
|
framework/framework
|
|
scheme/list
|
|
scheme/match
|
|
mzlib/kw
|
|
syntax/boundmap
|
|
"interfaces.ss"
|
|
"params.ss"
|
|
"controller.ss"
|
|
"display.ss"
|
|
"keymap.ss"
|
|
"hrule-snip.ss"
|
|
"properties.ss"
|
|
"text.ss"
|
|
"util.ss")
|
|
(provide widget%
|
|
widget-keymap%
|
|
widget-context-menu%)
|
|
|
|
;; widget%
|
|
;; A syntax widget creates its own syntax-controller.
|
|
(define widget%
|
|
(class* object% (widget-hooks<%>)
|
|
(init parent)
|
|
(init-field config)
|
|
|
|
(define 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 props-percentage (send config pref:props-percentage))
|
|
|
|
(define/public (setup-keymap)
|
|
(new widget-keymap%
|
|
(editor -text)
|
|
(widget this)))
|
|
|
|
(send -text set-styles-sticky #f)
|
|
(send -text lock #t)
|
|
|
|
(send -split-panel set-percentages
|
|
(list (- 1 props-percentage) props-percentage))
|
|
|
|
;; syntax-properties-controller<%> methods
|
|
|
|
(define/public (props-shown?)
|
|
(send -props-panel is-shown?))
|
|
|
|
(define/public (toggle-props)
|
|
(show-props (not (send -props-panel is-shown?))))
|
|
|
|
(define/public (show-props show?)
|
|
(if show?
|
|
(unless (send -props-panel is-shown?)
|
|
(send -split-panel add-child -props-panel)
|
|
(send -split-panel set-percentages
|
|
(list (- 1 props-percentage) props-percentage))
|
|
(send -props-panel show #t))
|
|
(when (send -props-panel is-shown?)
|
|
(set! props-percentage
|
|
(cadr (send -split-panel get-percentages)))
|
|
(send -split-panel delete-child -props-panel)
|
|
(send -props-panel show #f))))
|
|
|
|
;;
|
|
|
|
(define/public (get-controller) controller)
|
|
|
|
;;
|
|
|
|
(define/public (get-main-panel) -main-panel)
|
|
|
|
(define/public (shutdown)
|
|
(unless (= props-percentage (send config pref:props-percentage))
|
|
(send config pref:props-percentage props-percentage)))
|
|
|
|
;; 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
|
|
(lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table [definites null]
|
|
hi2-color [hi2-stxs null])
|
|
(define (get-binder id)
|
|
(module-identifier-mapping-get alpha-table id (lambda () #f)))
|
|
(when (and (pair? hi-stxs) (not hi-color))
|
|
(error 'syntax-widget%::add-syntax "no highlight color specified"))
|
|
(let ([display (internal-add-syntax stx)]
|
|
[definite-table (make-hash-table)])
|
|
(when (and hi2-color (pair? hi2-stxs))
|
|
(send display highlight-syntaxes hi2-stxs hi2-color))
|
|
(when (and hi-color (pair? hi-stxs))
|
|
(send display highlight-syntaxes hi-stxs hi-color))
|
|
(for-each (lambda (x) (hash-table-put! definite-table x #t)) definites)
|
|
(when alpha-table
|
|
(let ([range (send display get-range)]
|
|
[start (send display get-start-position)])
|
|
(define (adjust n) (+ start n))
|
|
(for-each
|
|
(lambda (id)
|
|
#; ;; DISABLED
|
|
(match (identifier-binding id)
|
|
[(list src-mod src-name nom-mod nom-name _)
|
|
(for-each (lambda (id-r)
|
|
(send -text add-billboard
|
|
(adjust (car id-r))
|
|
(adjust (cdr id-r))
|
|
(string-append "from "
|
|
(mpi->string src-mod))
|
|
(if (hash-table-get definite-table id #f)
|
|
"blue"
|
|
"purple")))
|
|
(send range get-ranges id))]
|
|
[_ (void)])
|
|
|
|
(let ([binder (get-binder id)])
|
|
(when binder
|
|
(for-each
|
|
(lambda (binder-r)
|
|
(for-each (lambda (id-r)
|
|
(if (hash-table-get definite-table id #f)
|
|
(send -text add-arrow
|
|
(adjust (car binder-r))
|
|
(adjust (cdr binder-r))
|
|
(adjust (car id-r))
|
|
(adjust (cdr id-r))
|
|
"blue")
|
|
(send -text add-question-arrow
|
|
(adjust (car binder-r))
|
|
(adjust (cdr binder-r))
|
|
(adjust (car id-r))
|
|
(adjust (cdr id-r))
|
|
"purple")))
|
|
(send range get-ranges id)))
|
|
(send range get-ranges binder)))))
|
|
(send range get-identifier-list))))
|
|
display)))
|
|
|
|
(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 remove-all-syntax-displays))
|
|
|
|
(define/public (get-text) -text)
|
|
|
|
;; internal-add-syntax : syntax -> display
|
|
(define/private (internal-add-syntax stx)
|
|
(with-unlock -text
|
|
(parameterize ((current-default-columns (calculate-columns)))
|
|
(let ([display (print-syntax-to-editor stx -text controller)])
|
|
(send* -text
|
|
(insert "\n")
|
|
;(scroll-to-position current-position)
|
|
)
|
|
display))))
|
|
|
|
(define/private (calculate-columns)
|
|
(define style (code-style -text))
|
|
(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)))
|
|
|
|
(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 widget-keymap%
|
|
(class syntax-keymap%
|
|
(init-field widget)
|
|
(super-new (controller (send widget get-controller)))
|
|
(inherit add-function)
|
|
(inherit-field controller)
|
|
|
|
(define/override (get-context-menu%)
|
|
widget-context-menu%)
|
|
|
|
(add-function "show-syntax-properties"
|
|
(lambda (i e)
|
|
(send widget toggle-props)))
|
|
|
|
(define/public (get-widget) widget)))
|
|
|
|
(define widget-context-menu%
|
|
(class context-menu%
|
|
(inherit-field keymap)
|
|
(inherit-field props-menu)
|
|
|
|
(define/override (on-demand)
|
|
(send props-menu set-label
|
|
(if (send (send keymap get-widget) props-shown?)
|
|
"Hide syntax properties"
|
|
"Show syntax properties"))
|
|
(super on-demand))
|
|
(super-new)))
|
|
|
|
(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)))
|