235 lines
8.5 KiB
Scheme
235 lines
8.5 KiB
Scheme
|
|
#lang scheme/base
|
|
(require scheme/class
|
|
scheme/unit
|
|
scheme/list
|
|
scheme/file
|
|
scheme/match
|
|
scheme/gui
|
|
framework/framework
|
|
syntax/boundmap
|
|
"interfaces.ss"
|
|
"stepper.ss"
|
|
"prefs.ss"
|
|
"warning.ss"
|
|
"hiding-panel.ss"
|
|
(prefix-in sb: "../syntax-browser/embed.ss")
|
|
(prefix-in sb: "../syntax-browser/params.ss")
|
|
"../model/deriv.ss"
|
|
"../model/deriv-util.ss"
|
|
"../model/trace.ss"
|
|
"../model/hide.ss"
|
|
"../model/steps.ss"
|
|
"cursor.ss"
|
|
"../util/notify.ss")
|
|
(provide macro-stepper-frame-mixin)
|
|
|
|
(define (macro-stepper-frame-mixin base-frame%)
|
|
(class base-frame%
|
|
(init-field config)
|
|
(init-field (filename #f))
|
|
|
|
(define obsoleted? #f)
|
|
|
|
(inherit get-area-container
|
|
set-label
|
|
get-menu%
|
|
get-menu-item%
|
|
get-menu-bar
|
|
get-file-menu
|
|
get-edit-menu
|
|
get-help-menu)
|
|
|
|
(super-new (label (make-label))
|
|
(width (send config get-width))
|
|
(height (send config get-height)))
|
|
|
|
(define/private (make-label)
|
|
(if filename
|
|
(string-append (path->string
|
|
(file-name-from-path filename))
|
|
(if obsoleted? " (old)" "")
|
|
" - Macro stepper")
|
|
"Macro stepper"))
|
|
|
|
(define/override (on-size w h)
|
|
(send config set-width w)
|
|
(send config set-height h)
|
|
(send widget update/preserve-view))
|
|
|
|
(override/return-false file-menu:create-new?
|
|
file-menu:create-open?
|
|
file-menu:create-open-recent?
|
|
file-menu:create-revert?
|
|
file-menu:create-save?
|
|
file-menu:create-save-as?
|
|
;file-menu:create-print?
|
|
edit-menu:create-undo?
|
|
edit-menu:create-redo?
|
|
;edit-menu:create-cut?
|
|
;edit-menu:create-paste?
|
|
edit-menu:create-clear?
|
|
;edit-menu:create-find?
|
|
;edit-menu:create-find-again?
|
|
edit-menu:create-replace-and-find-again?)
|
|
|
|
(define file-menu (get-file-menu))
|
|
(define edit-menu (get-edit-menu))
|
|
(define stepper-menu
|
|
(new (get-menu%) (parent (get-menu-bar)) (label "Stepper")))
|
|
(define help-menu (get-help-menu))
|
|
|
|
(define warning-panel
|
|
(new horizontal-panel%
|
|
(parent (get-area-container))
|
|
(stretchable-height #f)
|
|
(style '(deleted))))
|
|
|
|
(define/public (get-macro-stepper-widget%)
|
|
macro-stepper-widget%)
|
|
|
|
(define widget
|
|
(new (get-macro-stepper-widget%)
|
|
(parent (get-area-container))
|
|
(config config)))
|
|
|
|
(define/public (get-widget) widget)
|
|
|
|
(define/public (add-obsoleted-warning)
|
|
(unless obsoleted?
|
|
(set! obsoleted? #t)
|
|
(new warning-canvas%
|
|
(warning
|
|
(string-append
|
|
"Warning: This macro stepper session is obsolete. "
|
|
"The program may have changed."))
|
|
(parent warning-panel))
|
|
(set-label (make-label))
|
|
(send (get-area-container) change-children
|
|
(lambda (children)
|
|
(cons warning-panel
|
|
(remq warning-panel children))))))
|
|
|
|
;; Set up menus
|
|
|
|
(menu-option/notify-box stepper-menu
|
|
"Show syntax properties"
|
|
(get-field show-syntax-properties? config))
|
|
|
|
;; FIXME: rewrite with notify-box
|
|
(let ([id-menu
|
|
(new (get-menu%)
|
|
(label "Identifier=?")
|
|
(parent stepper-menu))])
|
|
(for-each (lambda (p)
|
|
(let ([this-choice
|
|
(new checkable-menu-item%
|
|
(label (car p))
|
|
(parent id-menu)
|
|
(callback
|
|
(lambda _
|
|
(send (send widget get-controller)
|
|
set-identifier=? p))))])
|
|
(send (send widget get-controller)
|
|
listen-identifier=?
|
|
(lambda (name+func)
|
|
(send this-choice check
|
|
(eq? (car name+func) (car p)))))))
|
|
(sb:identifier=-choices)))
|
|
(let ([identifier=? (send config get-identifier=?)])
|
|
(when identifier=?
|
|
(let ([p (assoc identifier=? (sb:identifier=-choices))])
|
|
(send (send widget get-controller) set-identifier=? p))))
|
|
|
|
(new (get-menu-item%)
|
|
(label "Clear selection")
|
|
(parent stepper-menu)
|
|
(callback
|
|
(lambda _ (send (send widget get-controller) select-syntax #f))))
|
|
(new separator-menu-item% (parent stepper-menu))
|
|
|
|
(menu-option/notify-box stepper-menu
|
|
"Show macro hiding panel"
|
|
(get-field show-hiding-panel? config))
|
|
#;
|
|
(new (get-menu-item%)
|
|
(label "Show in new frame")
|
|
(parent stepper-menu)
|
|
(callback (lambda _ (send widget show-in-new-frame))))
|
|
(new (get-menu-item%)
|
|
(label "Remove selected term")
|
|
(parent stepper-menu)
|
|
(callback (lambda _ (send widget remove-current-term))))
|
|
(new (get-menu-item%)
|
|
(label "Reset mark numbering")
|
|
(parent stepper-menu)
|
|
(callback (lambda _ (send widget reset-primary-partition))))
|
|
(let ([extras-menu
|
|
(new (get-menu%)
|
|
(label "Extra options")
|
|
(parent stepper-menu))])
|
|
(new checkable-menu-item%
|
|
(label "Always suffix marked identifiers")
|
|
(parent extras-menu)
|
|
(callback
|
|
(lambda (i e)
|
|
(sb:current-suffix-option
|
|
(if (send i is-checked?)
|
|
'always
|
|
'over-limit))
|
|
(send widget update/preserve-view))))
|
|
(menu-option/notify-box extras-menu
|
|
"Highlight redex/contractum"
|
|
(get-field highlight-foci? config))
|
|
(menu-option/notify-box extras-menu
|
|
"Highlight frontier"
|
|
(get-field highlight-frontier? config))
|
|
(menu-option/notify-box extras-menu
|
|
"Include renaming steps"
|
|
(get-field show-rename-steps? config))
|
|
(menu-option/notify-box extras-menu
|
|
"One term at a time"
|
|
(get-field one-by-one? config))
|
|
(menu-option/notify-box extras-menu
|
|
"Suppress warnings"
|
|
(get-field suppress-warnings? config))
|
|
(menu-option/notify-box extras-menu
|
|
"Extra navigation"
|
|
(get-field extra-navigation? config))
|
|
(menu-option/notify-box extras-menu
|
|
"Force block->letrec transformation"
|
|
(get-field force-letrec-transformation? config))
|
|
(menu-option/notify-box extras-menu
|
|
"(Debug) Catch internal errors?"
|
|
(get-field debug-catch-errors? config)))
|
|
|
|
(frame:reorder-menus this)))
|
|
|
|
;; Stolen from stepper
|
|
|
|
(define warning-color "yellow")
|
|
(define warning-font normal-control-font)
|
|
|
|
(define warning-canvas%
|
|
(class canvas%
|
|
(init-field warning)
|
|
(inherit get-dc get-client-size)
|
|
(define/override (on-paint)
|
|
(let ([dc (get-dc)])
|
|
(send dc set-font warning-font)
|
|
(let-values ([(cw ch) (get-client-size)]
|
|
[(tw th dont-care dont-care2) (send dc get-text-extent warning)])
|
|
(send dc set-pen (send the-pen-list find-or-create-pen warning-color 1 'solid))
|
|
(send dc set-brush (send the-brush-list find-or-create-brush warning-color 'solid))
|
|
(send dc draw-rectangle 0 0 cw ch)
|
|
(send dc draw-text
|
|
warning
|
|
(- (/ cw 2) (/ tw 2))
|
|
(- (/ ch 2) (/ th 2))))))
|
|
(super-new)
|
|
(inherit min-width min-height stretchable-height)
|
|
(let-values ([(tw th dc dc2) (send (get-dc) get-text-extent warning warning-font)])
|
|
(min-width (+ 2 (inexact->exact (ceiling tw))))
|
|
(min-height (+ 2 (inexact->exact (ceiling th)))))
|
|
(stretchable-height #f)))
|