(module diva-link mzscheme
(require (lib "etc.ss")
(lib "list.ss")
(lib "class.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "struct.ss")
(lib "plt-match.ss")
(lib "errortrace-lib.ss" "errortrace")
"interpreter.ss"
"dot-processing.ss"
"mred-state.ss"
"mred-callback.ss"
"command-keymap.ss"
"insert-keymap.ss"
"structures.ss"
"utilities.ss"
"diva-central.ss"
"rope.ss"
"cworld.ss"
"gui/clipboard.ss"
(prefix preferences: "diva-preferences.ss"))
(provide diva-link:frame-mixin)
(provide diva-link:text-mixin)
(provide diva-link:interactions-text-mixin)
(define (diva-link:frame-mixin super%)
(class super%
(inherit get-diva-central
get-definitions-text
get-interactions-text)
(define started? #f)
(super-new)
(define (initialize)
(send (get-diva-central) add-listener handle-diva-central-evt)
(queue-callback
(lambda ()
(when (and (send (get-diva-central) diva-on?)
(not started?))
(startup)))))
(define (startup)
(send this diva-panel-show)
(send (get-definitions-text) to-command-mode)
(send (get-interactions-text) to-command-mode)
(set! started? #t))
(define (shutdown)
(send this diva-panel-hide)
(send (get-definitions-text) to-normal-mode)
(send (get-interactions-text) to-normal-mode)
(set! started? #f))
(define (refresh-keymaps)
(send (get-definitions-text) refresh-keymaps)
(send (get-interactions-text) refresh-keymaps))
(define/augment (on-tab-change from-tab to-tab)
(inner (void) on-tab-change from-tab to-tab)
(when started?
(send (send from-tab get-defs) diva:-on-loss-focus)
(send (send from-tab get-ints) diva:-on-loss-focus)
(send (send to-tab get-defs) diva:-on-loss-focus)
(send (send to-tab get-ints) diva:-on-loss-focus)
(send (send from-tab get-defs) to-normal-mode)
(send (send from-tab get-ints) to-normal-mode)
(send (send to-tab get-defs) to-command-mode)
(send (send to-tab get-ints) to-command-mode)))
(define (handle-diva-central-evt evt)
(match evt
[(struct diva-switch-on-evt ()) (startup)]
[(struct diva-switch-off-evt ()) (shutdown)]
[(struct diva-keymap-changed-evt ()) (refresh-keymaps)]
[else (void)]))
(define/augment (on-close)
(inner (void) on-close)
(send (get-diva-central) remove-listener handle-diva-central-evt))
(initialize)))
(define (apply-callback-mixins super%)
(set-position/preserving-marks-callback-mixin
(insert-and-delete-callback-mixin
(focus-callback-mixin
super%))))
(define (diva-link:text-mixin super%)
(class (apply-callback-mixins super%)
(inherit get-top-level-window
get-keymap
get-canvas
begin-edit-sequence
end-edit-sequence
diva:-get-rope
diva:-set-on-loss-focus
diva:-on-loss-focus
diva:-set-after-insert-callback
diva:-set-after-delete-callback
get-diva-central
set-position)
(super-instantiate ())
(define/override (set-surrogate surrogate)
(cond
[(send (get-diva-central) diva-on?)
(diva:-on-loss-focus)
(uninstall-command-keymap)
(super set-surrogate surrogate)
(cond
[(is-a? surrogate scheme:text-mode%)
(diva-message "")
(install-command-keymap)]
[else
(diva-message "Disabled: not in scheme mode")])]
[else
(super set-surrogate surrogate)]))
(define (diva-label label)
(when (get-top-level-window)
(send (get-top-level-window) diva-label label)))
(define/public (diva-message msg)
(when (get-top-level-window)
(send (get-top-level-window) diva-message msg)))
(define (error-exn exn)
(printf "~s~n" exn)
(let ([err-msg (format "DivaScheme Error: ~a" exn)])
(print-error-trace (current-error-port) exn)
(diva-message err-msg)))
(define (error-message str)
(and str (diva-message str)))
(define (diva-question question default cancel answer)
(send (get-top-level-window) diva-question question default cancel answer))
(define current-mred
(make-object MrEd-state% this))
(define central-world
(new-cworld (send current-mred pull-world (make-fresh-world))))
(define/public (get-current-world)
(cworld-world central-world))
(define (set-current-world! new-world)
(send-cworld-op (make-op:replace-world new-world)))
(define central-world-mailbox (make-channel))
(thread (lambda ()
(let loop ()
(let ([new-op (channel-get central-world-mailbox)])
(set! central-world (cworld-apply-op central-world new-op)))
(loop))))
(define/public (send-cworld-op an-op)
(channel-put central-world-mailbox an-op))
(define/augment (after-load-file success?)
(set! last-action-load? true)
(inner void after-load-file success?))
(define last-action-load? false)
(define (push-callback callback)
(parameterize ([current-eventspace (send (get-top-level-window) get-eventspace)])
(queue-callback callback)))
(define (pull-from-mred)
(print-mem
'get-mred
(lambda ()
(let ([new-world
(success-message (send current-mred pull-world (get-current-world))
"")])
(cond
[(rope=? (World-rope new-world)
(World-rope (get-current-world)))
new-world]
[last-action-load?
(set! last-action-load? false)
(copy-struct World new-world
[World-undo #f])]
[else
(copy-struct World new-world
[World-undo (get-current-world)])])))))
(define (push-into-mred world)
(unless (World? world)
(error 'push-into-mred))
(with-handlers ([voice-exn?
(lambda (exn)
(error-message (voice-exn-message exn)))]
[(lambda args true)
(lambda (exn)
(error-exn exn))])
(dynamic-wind
(lambda ()
(begin-edit-sequence))
(lambda ()
(send current-mred push-world world)
(let
([new-world
(foldl
(lambda (fn world)
(with-divascheme-handlers
world
(lambda ()
(fn world this
(lambda (w)
(send current-mred pull-world w))
(lambda (w)
(send current-mred push-world w))))))
world
(reverse (World-imperative-actions world)))])
(set-current-world! (copy-struct World new-world
[World-imperative-actions empty]))))
(lambda ()
(end-edit-sequence)))))
(define (with-divascheme-handlers default-world-on-exn thunk)
(dynamic-wind
(lambda ()
(begin-edit-sequence))
(lambda ()
(with-handlers ([voice-exn?
(lambda (exn)
(error-message (voice-exn-message exn))
default-world-on-exn)]
[voice-exn/world?
(lambda (exn)
(error-message (voice-exn/world-message exn))
(voice-exn/world-world exn))]
[(lambda args true)
(lambda (exn)
(error-exn exn)
default-world-on-exn)])
(thunk)))
(lambda ()
(end-edit-sequence))))
(define (interpreter/imperative ast world)
(match (interpreter ast world)
[(struct SwitchWorld (path inner-ast))
(let ([frame (handler:edit-file path)])
(when (eq? this (send frame get-editor))
(push-into-mred (pull-from-mred)))
(send (send frame get-editor) diva-ast-put inner-ast))
(pull-from-mred)]
[new-world
new-world]))
(define/public (diva-ast-put ast)
(push-callback
(lambda ()
(let ([world (pull-from-mred)])
(diva-ast-put/wait+world world ast)))))
(define (diva-ast-put/wait+world world ast)
(push-into-mred
(with-divascheme-handlers
world
(lambda ()
(interpreter/imperative ast world)))))
(define (check-good-syntax)
(cond
[(and (get-current-world)
(rope=? (diva:-get-rope)
(World-rope (get-current-world))))
(void (World-syntax-list (get-current-world)))]
[else
(void (rope-parse-syntax (diva:-get-rope)))]))
(define to-insert-mode
(case-lambda
[(edit? on-entry on-exit)
(to-insert-mode edit? on-entry on-exit #f)]
[(edit? on-entry on-exit cmd)
(with-divascheme-handlers
#f
(lambda ()
(on-entry)
(void
(make-insert-mode this (lambda (msg) (diva-message msg)) (lambda () (pull-from-mred)) (lambda (world) (push-into-mred world)) (lambda (callback)
(diva:-set-on-loss-focus callback))
(lambda (callback)
(diva:-set-after-insert-callback callback))
(lambda (callback)
(diva:-set-after-delete-callback callback))
(lambda (world ast)
(diva-ast-put/wait+world world ast))
on-exit cmd edit? ))))]))
(define (new-command-keymap)
(local ( (define (get-check-syntax-button)
(cond
[(and (send this get-tab)
(send (send this get-tab) get-frame)
(method-in-interface?
'syncheck:get-button
(object-interface (send (send this get-tab) get-frame))))
(send (send (send this get-tab) get-frame)
syncheck:get-button)]
[else #f]))
(define was-button-enabled? #t)
(define (on-entry)
(diva-label "DivaScheme: insertion mode")
(diva-message "")
(check-good-syntax)
(when (get-check-syntax-button)
(set! was-button-enabled? (send (get-check-syntax-button) is-enabled?))
(send (get-check-syntax-button) enable #f)))
(define (on-exit)
(diva-label "DivaScheme: command mode")
(when (get-check-syntax-button)
(send (get-check-syntax-button) enable was-button-enabled?))))
(make-command-keymap this
(lambda (edit?)
(to-insert-mode edit? on-entry on-exit))
(lambda (edit? command)
(to-insert-mode edit? on-entry on-exit command))
(lambda (msg)
(diva-message msg))
diva-question
(lambda (ast)
(diva-ast-put/wait+world (pull-from-mred) ast)))))
(define command-keymap (new-command-keymap))
(define (install-command-keymap)
(send (get-keymap) chain-to-keymap command-keymap #t))
(define (uninstall-command-keymap)
(send (get-keymap) remove-chained-keymap command-keymap))
(define/public (to-command-mode)
(install-command-keymap)
(with-divascheme-handlers
#f
(lambda ()
(check-good-syntax))))
(define/public (to-normal-mode)
(diva:-on-loss-focus)
(uninstall-command-keymap)
(diva-label false))
(define (new-f4-keymap)
(define f4-keymap (new keymap:aug-keymap%))
(send f4-keymap add-function "diva:toggle"
(lambda (any event)
(send (get-diva-central) switch-toggle)))
(preferences:install-global-bindings f4-keymap)
f4-keymap)
(define (uninstall-f4-keymap)
(send (get-keymap) remove-chained-keymap f4-keymap))
(define (install-f4-keymap)
(send (get-keymap) chain-to-keymap f4-keymap #t))
(define f4-keymap (new-f4-keymap))
(install-f4-keymap)
(define/public (refresh-keymaps)
(uninstall-f4-keymap)
(set! f4-keymap (new-f4-keymap))
(install-f4-keymap)
(cond
[(send (get-diva-central) diva-on?)
(diva:-on-loss-focus)
(uninstall-command-keymap)
(set! command-keymap (new-command-keymap))
(install-command-keymap)]
[else
(set! command-keymap (new-command-keymap))]))
(define/public diva:set-selection-position
(case-lambda
[(start end)
(set-position start end #f #t 'local)]
[(start)
(set-position start 'same #f #t 'local)]))))
(define (diva-link:interactions-text-mixin super%)
(class super%
(super-new)
(inherit get-start-position
get-end-position
submit-to-port?
diva:-on-loss-focus)
(define/augment (on-submit)
(inner (void) on-submit))
(define/override (on-local-char key)
(let ([start (get-start-position)]
[end (get-end-position)]
[code (send key get-key-code)])
(cond
[(not (or (eq? code 'numpad-enter)
(equal? code #\return)
(equal? code #\newline)))
(super on-local-char key)]
[(and (= start end)
(submit-to-port? key))
(diva:-on-loss-focus)
(super on-local-char key)]
[else
(super on-local-char key)]))))))