265 lines
9.5 KiB
Racket
265 lines
9.5 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
racket/gui/base
|
|
racket/match
|
|
framework
|
|
syntax/id-table
|
|
unstable/class-iop
|
|
"interfaces.rkt"
|
|
"controller.rkt"
|
|
"display.rkt"
|
|
"keymap.rkt"
|
|
"hrule-snip.rkt"
|
|
"properties.rkt"
|
|
"text.rkt"
|
|
"util.rkt"
|
|
"../util/eomap.rkt"
|
|
"../util/mpi.rkt")
|
|
(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 canvas:color% (parent -split-panel) (editor -text)))
|
|
(define -props-panel
|
|
(new horizontal-panel% (parent -split-panel) (style '(deleted))))
|
|
(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 saved-props-percentage #f)
|
|
|
|
(define/private (internal-show-props show?)
|
|
(if show?
|
|
(unless (send -props-panel is-shown?)
|
|
(send -split-panel begin-container-sequence)
|
|
(let ([p (or saved-props-percentage
|
|
(send/i config config<%> get-props-percentage))])
|
|
(send -split-panel add-child -props-panel)
|
|
(update-props-percentage p))
|
|
(send -props-panel show #t)
|
|
(send -split-panel end-container-sequence))
|
|
(when (send -props-panel is-shown?)
|
|
(send -split-panel begin-container-sequence)
|
|
(set! saved-props-percentage
|
|
(cadr (send -split-panel get-percentages)))
|
|
(send -split-panel delete-child -props-panel)
|
|
(send -props-panel show #f)
|
|
(send -split-panel end-container-sequence))))
|
|
|
|
(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/i 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
|
|
#:binders [binders '#hash()]
|
|
#:shift-table [shift-table '#hash()]
|
|
#:definites [definites #f]
|
|
#:hi-colors [hi-colors null]
|
|
#:hi-stxss [hi-stxss null]
|
|
#:substitutions [substitutions null])
|
|
(define (get-shifted id) (hash-ref shift-table id null))
|
|
|
|
(with-unlock -text
|
|
(define display
|
|
(print-syntax-to-editor stx -text controller config
|
|
(calculate-columns)
|
|
(send -text last-position)))
|
|
(send -text insert "\n")
|
|
(define range (send/i display display<%> get-range))
|
|
(define offset (send/i display display<%> get-start-position))
|
|
(for ([subst (in-list substitutions)])
|
|
(for ([r (in-list (send/i range range<%> get-ranges (car subst)))])
|
|
(send -text insert (cdr subst)
|
|
(+ offset (car r))
|
|
(+ offset (cdr r))
|
|
#f)
|
|
(send -text change-style
|
|
(code-style -text (send/i config config<%> get-syntax-font-size))
|
|
(+ offset (car r))
|
|
(+ offset (cdr r))
|
|
#f)))
|
|
;; Apply highlighting
|
|
(for ([hi-stxs (in-list hi-stxss)] [hi-color (in-list hi-colors)])
|
|
(send/i display display<%> highlight-syntaxes hi-stxs hi-color))
|
|
;; Underline binders (and shifted binders)
|
|
(send/i display display<%> underline-syntaxes
|
|
(let ([binder-list (hash-map binders (lambda (k v) k))])
|
|
(append (apply append (map get-shifted binder-list))
|
|
binder-list)))
|
|
(send display refresh)
|
|
|
|
;; Make arrows (& billboards, when enabled)
|
|
(when (send config get-draw-arrows?)
|
|
(define (definite-phase id)
|
|
(and definites
|
|
(or (eomap-ref definites id #f)
|
|
(for/or ([shifted (in-list (hash-ref shift-table id null))])
|
|
(eomap-ref definites shifted #f)))))
|
|
|
|
(define phase-binder-table (make-hash))
|
|
(define (get-binder-table phase)
|
|
(hash-ref! phase-binder-table phase (lambda () (make-free-id-table #:phase phase))))
|
|
(for ([(binder phase) (in-hash binders)])
|
|
(free-id-table-set! (get-binder-table phase) binder binder))
|
|
|
|
(define (get-binders id phase)
|
|
(define (for-one-table table id)
|
|
(let ([binder (free-id-table-ref table id #f)])
|
|
(cond [(not binder) null]
|
|
[shift-table (cons binder (get-shifted binder))]
|
|
[else (list binder)])))
|
|
(cond [phase (for-one-table (get-binder-table phase) id)]
|
|
[else
|
|
(apply append
|
|
(for/list ([table (in-hash-values phase-binder-table)])
|
|
(for-one-table table id)))]))
|
|
|
|
(for ([id (in-list (send/i range range<%> get-identifier-list))])
|
|
(define phase (definite-phase id))
|
|
(when #f ;; DISABLED
|
|
(add-binding-billboard offset range id phase))
|
|
(for ([binder (in-list (get-binders id phase))])
|
|
(for ([binder-r (in-list (send/i range range<%> get-ranges binder))])
|
|
(for ([id-r (in-list (send/i range range<%> get-ranges id))])
|
|
(add-binding-arrow offset binder-r id-r phase))))))
|
|
(void)))
|
|
|
|
(define/private (add-binding-arrow start binder-r id-r phase)
|
|
;; phase = #f means not definite binding (ie, "?" arrow)
|
|
(send -text add-arrow
|
|
(+ start (car binder-r))
|
|
(+ start (cdr binder-r))
|
|
(+ start (car id-r))
|
|
(+ start (cdr id-r))
|
|
(if phase "blue" "purple")
|
|
(cond [(equal? phase 0) #f]
|
|
[phase (format "phase ~s" phase)]
|
|
[else "?"])
|
|
(if phase 'end 'start)))
|
|
|
|
(define/private (add-binding-billboard start range id definite?)
|
|
(match (identifier-binding id)
|
|
[(list-rest src-mod src-name nom-mod nom-name _)
|
|
(for ([id-r (in-list (send/i range range<%> get-ranges id))])
|
|
(send -text add-billboard
|
|
(+ start (car id-r))
|
|
(+ start (cdr id-r))
|
|
(string-append "from " (mpi->string src-mod))
|
|
(if definite? "blue" "purple")))]
|
|
[_ (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/i controller displays-manager<%> remove-all-syntax-displays))
|
|
|
|
(define/public (get-text) -text)
|
|
|
|
(define/private (calculate-columns)
|
|
(define style (code-style -text (send/i 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))))
|
|
|#
|
|
(let ([admin (send -text get-admin)]
|
|
[w-box (box 0.0)])
|
|
(send admin get-view #f #f w-box #f)
|
|
(sub1 (inexact->exact (floor (/ (unbox w-box) char-width))))))
|
|
|
|
;; Initialize
|
|
(super-new)
|
|
(setup-keymap)
|
|
|
|
(send/i config config<%> listen-props-shown?
|
|
(lambda (show?)
|
|
(show-props show?)))
|
|
(send/i config config<%> listen-props-percentage
|
|
(lambda (p)
|
|
(update-props-percentage p)))
|
|
(internal-show-props (send/i 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))
|