9595145d79
I picked "#<image>" not because I think it is a good way to print, but just so that there is something there to be easily changed later, when someone who has an opinion decides to change it.
1294 lines
57 KiB
Racket
1294 lines
57 KiB
Racket
#lang racket/unit
|
|
|
|
(require "drsig.rkt"
|
|
string-constants
|
|
|
|
;; NOTE: this module instantiates stacktrace itself, so we have
|
|
;; to be careful to not mix that instantiation with the one
|
|
;; drracket/private/debug.rkt does. errortrace-lib's is for the
|
|
;; compilation handling, DrRacket's is for profiling and test coverage
|
|
;; (which do not do compilation)
|
|
(prefix-in el: errortrace/errortrace-lib)
|
|
|
|
(prefix-in image-core: mrlib/image-core)
|
|
|
|
mzlib/pconvert
|
|
racket/pretty
|
|
mzlib/struct
|
|
racket/class
|
|
racket/file
|
|
racket/list
|
|
compiler/embed
|
|
launcher
|
|
mred
|
|
framework
|
|
mrlib/syntax-browser
|
|
compiler/distribute
|
|
compiler/bundle-dist
|
|
"rep.rkt")
|
|
|
|
(import [prefix drracket:debug: drracket:debug^]
|
|
[prefix drracket:tools: drracket:tools^]
|
|
[prefix drracket:rep: drracket:rep^]
|
|
[prefix drracket:help-desk: drracket:help-desk^])
|
|
(export drracket:language^)
|
|
|
|
(define original-output-port (current-output-port))
|
|
(define (oprintf . args) (apply fprintf original-output-port args))
|
|
|
|
(define-struct text/pos (text start end))
|
|
;; text/pos = (make-text/pos (instanceof text% number number))
|
|
;; this represents a portion of a text to be processed.
|
|
|
|
(define language<%>
|
|
(interface ()
|
|
marshall-settings
|
|
unmarshall-settings
|
|
default-settings
|
|
default-settings?
|
|
|
|
front-end/complete-program
|
|
front-end/finished-complete-program
|
|
front-end/interaction
|
|
config-panel
|
|
on-execute
|
|
extra-repl-information
|
|
|
|
first-opened
|
|
render-value/format
|
|
render-value
|
|
|
|
capability-value
|
|
|
|
create-executable
|
|
|
|
get-reader-module
|
|
get-metadata
|
|
metadata->settings
|
|
get-metadata-lines
|
|
|
|
get-language-position
|
|
get-language-name
|
|
get-style-delta
|
|
get-language-numbers
|
|
get-one-line-summary
|
|
get-language-url
|
|
get-comment-character))
|
|
|
|
(define module-based-language<%>
|
|
(interface ()
|
|
marshall-settings
|
|
unmarshall-settings
|
|
default-settings
|
|
default-settings?
|
|
|
|
get-module
|
|
get-transformer-module
|
|
use-namespace-require/copy?
|
|
use-namespace-require/copy-from-setting?
|
|
config-panel
|
|
|
|
get-reader
|
|
|
|
on-execute
|
|
get-init-code
|
|
use-mred-launcher
|
|
|
|
render-value/format
|
|
render-value
|
|
|
|
get-language-position
|
|
get-language-numbers
|
|
get-one-line-summary
|
|
get-language-url))
|
|
|
|
(define simple-module-based-language<%>
|
|
(interface ()
|
|
get-module
|
|
get-language-position
|
|
get-language-numbers
|
|
get-one-line-summary
|
|
get-language-url
|
|
get-reader))
|
|
|
|
|
|
(define simple-module-based-language%
|
|
(class* object% (simple-module-based-language<%>)
|
|
(init-field module
|
|
language-position
|
|
(language-numbers (map (λ (x) 0) language-position))
|
|
(one-line-summary "")
|
|
(language-url #f)
|
|
(documentation-reference #f)
|
|
(reader (λ (src port)
|
|
(let ([v (parameterize ([read-accept-reader #t])
|
|
(with-stack-checkpoint
|
|
(read-syntax src port)))])
|
|
(if (eof-object? v)
|
|
v
|
|
(namespace-syntax-introduce v)))))
|
|
(language-id (if (pair? language-position)
|
|
(car (last-pair language-position))
|
|
(error 'simple-module-based-language<%>
|
|
"expected non-empty list of strings, got ~e" language-position))))
|
|
(define/public (get-module) module)
|
|
(define/public (get-language-position) language-position)
|
|
(define/public (get-language-numbers) language-numbers)
|
|
(define/public (get-one-line-summary) one-line-summary)
|
|
(define/public (get-language-url) language-url)
|
|
(define/public (get-reader) reader)
|
|
(super-instantiate ())))
|
|
|
|
|
|
|
|
;; simple-module-based-language->module-based-language : module-based-language<%>
|
|
;; transforms a simple-module-based-language into a module-based-language<%>
|
|
(define simple-module-based-language->module-based-language-mixin
|
|
(mixin (simple-module-based-language<%>) (module-based-language<%>)
|
|
(define/public (get-transformer-module) 'mzscheme)
|
|
(define/public (use-namespace-require/copy?) #f)
|
|
(define/public (use-namespace-require/copy-from-setting? setting)
|
|
(use-namespace-require/copy?))
|
|
(define/public (use-mred-launcher) #t)
|
|
|
|
(inherit get-module)
|
|
(define/public (marshall-settings settings)
|
|
(simple-settings->vector settings))
|
|
(define/public (unmarshall-settings printable)
|
|
(and (vector? printable)
|
|
(= (vector-length printable)
|
|
(procedure-arity make-simple-settings))
|
|
(boolean? (vector-ref printable 0))
|
|
(memq (vector-ref printable 1) '(constructor quasiquote write trad-write print))
|
|
(memq (vector-ref printable 2)
|
|
'(mixed-fraction
|
|
mixed-fraction-e
|
|
repeating-decimal
|
|
repeating-decimal-e))
|
|
(boolean? (vector-ref printable 3))
|
|
(boolean? (vector-ref printable 4))
|
|
(memq (vector-ref printable 5) '(none debug debug/profile test-coverage))
|
|
(apply make-simple-settings (vector->list printable))))
|
|
(define/public (default-settings)
|
|
(make-simple-settings #t 'print 'mixed-fraction-e #f #t 'debug))
|
|
(define/public (default-settings? x)
|
|
(equal? (simple-settings->vector x)
|
|
(simple-settings->vector (default-settings))))
|
|
(define/public (config-panel parent)
|
|
(simple-module-based-language-config-panel parent))
|
|
|
|
(define/public (on-execute setting run-in-user-thread)
|
|
(initialize-simple-module-based-language setting run-in-user-thread))
|
|
(define/public (get-init-code setting)
|
|
(simple-module-based-language-get-init-code setting))
|
|
|
|
(define/public (render-value/format value settings port width)
|
|
(simple-module-based-language-render-value/format value settings port width))
|
|
(define/public (render-value value settings port)
|
|
(simple-module-based-language-render-value/format value settings port 'infinity))
|
|
(super-instantiate ())))
|
|
|
|
;; settings for a simple module based language
|
|
(define-struct simple-settings (case-sensitive
|
|
printing-style
|
|
fraction-style
|
|
show-sharing
|
|
insert-newlines
|
|
annotations))
|
|
;; case-sensitive : boolean
|
|
;; printing-style : (union 'print 'write 'trad-write 'constructor 'quasiquote)
|
|
;; fraction-style : (union 'mixed-fraction 'mixed-fraction-e 'repeating-decimal 'repeating-decimal-e)
|
|
;; show-sharing : boolean
|
|
;; insert-newlines : boolean
|
|
;; annotations : (union 'none 'debug 'debug/profile 'test-coverage)
|
|
(define simple-settings->vector (make-->vector simple-settings))
|
|
|
|
;; simple-module-based-language-config-panel :
|
|
;; parent [#:case-sensitive (union #f #t '?)]
|
|
;; -> (case-> (-> settings) (settings -> void))
|
|
(define (simple-module-based-language-config-panel
|
|
_parent
|
|
#:case-sensitive [*case-sensitive '?]
|
|
#:dynamic-panel-extras [dynamic-panel-extras void]
|
|
#:get-debugging-radio-box [get-debugging-radio-box void]
|
|
#:debugging-radio-box-callback [debugging-radio-box-callback void])
|
|
(letrec ([parent (instantiate vertical-panel% ()
|
|
(parent _parent)
|
|
(alignment '(center center)))]
|
|
|
|
[input-panel (and (eq? *case-sensitive '?)
|
|
(instantiate group-box-panel% ()
|
|
(label (string-constant input-syntax))
|
|
(parent parent)
|
|
(alignment '(left center))))]
|
|
|
|
[dynamic-panel (instantiate group-box-panel% ()
|
|
(label (string-constant dynamic-properties))
|
|
(parent parent)
|
|
(alignment '(left center)))]
|
|
|
|
[output-panel (instantiate group-box-panel% ()
|
|
(label (string-constant output-syntax))
|
|
(parent parent)
|
|
(alignment '(left center)))]
|
|
|
|
[case-sensitive (and input-panel
|
|
(make-object check-box%
|
|
(string-constant case-sensitive-label)
|
|
input-panel
|
|
void))]
|
|
[debugging-panel (new horizontal-panel%
|
|
[parent dynamic-panel]
|
|
[stretchable-height #f]
|
|
[alignment '(left center)])]
|
|
[debugging-left (new radio-box%
|
|
(label #f)
|
|
(choices
|
|
(list (string-constant no-debugging-or-profiling)
|
|
(string-constant debugging)))
|
|
(parent debugging-panel)
|
|
(callback
|
|
(λ (a b)
|
|
(send debugging-right set-selection #f)
|
|
(debugging-radio-box-callback a b))))]
|
|
[debugging-right (new radio-box%
|
|
(label #f)
|
|
(choices
|
|
(list (string-constant debugging-and-profiling)
|
|
(string-constant test-coverage)))
|
|
(parent debugging-panel)
|
|
(callback
|
|
(λ (a b)
|
|
(send debugging-left set-selection #f)
|
|
(debugging-radio-box-callback a b))))]
|
|
[output-style (make-object radio-box%
|
|
(string-constant output-style-label)
|
|
(list (string-constant constructor-printing-style)
|
|
(string-constant quasiquote-printing-style)
|
|
(string-constant write-printing-style)
|
|
(string-constant print-printing-style))
|
|
output-panel
|
|
(λ (rb evt) (enable-fraction-style))
|
|
'(horizontal vertical-label))]
|
|
[enable-fraction-style
|
|
(lambda ()
|
|
(let ([on? (member (send output-style get-selection) '(0 1))])
|
|
(send fraction-style enable on?)))]
|
|
[show-sharing (make-object check-box%
|
|
(string-constant sharing-printing-label)
|
|
output-panel
|
|
void)]
|
|
[insert-newlines (make-object check-box%
|
|
(string-constant use-pretty-printer-label)
|
|
output-panel
|
|
void)]
|
|
[fraction-style
|
|
(make-object check-box% (string-constant decimal-notation-for-rationals)
|
|
output-panel
|
|
void)])
|
|
(get-debugging-radio-box debugging-left debugging-right)
|
|
(dynamic-panel-extras dynamic-panel)
|
|
|
|
(case-lambda
|
|
[()
|
|
(make-simple-settings
|
|
(if case-sensitive
|
|
(send case-sensitive get-value)
|
|
(and *case-sensitive #t))
|
|
(case (send output-style get-selection)
|
|
[(0) 'constructor]
|
|
[(1) 'quasiquote]
|
|
[(2) 'trad-write]
|
|
[(3) 'print])
|
|
(if (send fraction-style get-value)
|
|
'repeating-decimal-e
|
|
'mixed-fraction-e)
|
|
(send show-sharing get-value)
|
|
(send insert-newlines get-value)
|
|
(case (send debugging-left get-selection)
|
|
[(0) 'none]
|
|
[(1) 'debug]
|
|
[(#f)
|
|
(case (send debugging-right get-selection)
|
|
[(0) 'debug/profile]
|
|
[(1) 'test-coverage])]))]
|
|
[(settings)
|
|
(when case-sensitive
|
|
(send case-sensitive set-value
|
|
(simple-settings-case-sensitive settings)))
|
|
(send output-style set-selection
|
|
(case (simple-settings-printing-style settings)
|
|
[(constructor) 0]
|
|
[(quasiquote) 1]
|
|
[(write trad-write) 2]
|
|
[(print) 3]))
|
|
(enable-fraction-style)
|
|
(send fraction-style set-value (eq? (simple-settings-fraction-style settings)
|
|
'repeating-decimal-e))
|
|
(send show-sharing set-value (simple-settings-show-sharing settings))
|
|
(send insert-newlines set-value (simple-settings-insert-newlines settings))
|
|
(case (simple-settings-annotations settings)
|
|
[(none) (send debugging-right set-selection #f) (send debugging-left set-selection 0)]
|
|
[(debug) (send debugging-right set-selection #f) (send debugging-left set-selection 1)]
|
|
[(debug/profile) (send debugging-left set-selection #f) (send debugging-right set-selection 0)]
|
|
[(test-coverage) (send debugging-left set-selection #f) (send debugging-right set-selection 1)])])))
|
|
|
|
;; simple-module-based-language-render-value/format : TST settings port (union #f (snip% -> void)) (union 'infinity number) -> void
|
|
(define (simple-module-based-language-render-value/format value settings port width)
|
|
(let-values ([(converted-value write?)
|
|
(call-with-values
|
|
(lambda ()
|
|
(simple-module-based-language-convert-value value settings))
|
|
(case-lambda
|
|
[(converted-value) (values converted-value #t)]
|
|
[(converted-value write?) (values converted-value write?)]))])
|
|
(let ([pretty-out (if write? pretty-write pretty-print)])
|
|
(setup-printing-parameters
|
|
(λ ()
|
|
(cond
|
|
[(simple-settings-insert-newlines settings)
|
|
(if (number? width)
|
|
(parameterize ([pretty-print-columns width])
|
|
(pretty-out converted-value port))
|
|
(pretty-out converted-value port))]
|
|
[else
|
|
(parameterize ([pretty-print-columns 'infinity])
|
|
(pretty-out converted-value port))
|
|
(newline port)]))
|
|
settings
|
|
width))))
|
|
|
|
(define default-pretty-print-current-style-table (pretty-print-current-style-table))
|
|
|
|
;; setup-printing-parameters : (-> void) simple-settings number -> void
|
|
(define (setup-printing-parameters thunk settings width)
|
|
(let ([use-number-snip?
|
|
(λ (x)
|
|
(and (number? x)
|
|
(exact? x)
|
|
(real? x)
|
|
(not (integer? x))))])
|
|
(parameterize (
|
|
;; these three handlers aren't used, but are set to override the user's settings
|
|
[pretty-print-print-line (λ (line-number op old-line dest-columns)
|
|
(when (and (not (equal? line-number 0))
|
|
(not (equal? dest-columns 'infinity)))
|
|
(newline op))
|
|
0)]
|
|
[pretty-print-pre-print-hook (λ (val port) (void))]
|
|
[pretty-print-post-print-hook (λ (val port) (void))]
|
|
[pretty-print-exact-as-decimal #f]
|
|
[pretty-print-depth #f]
|
|
[pretty-print-.-symbol-without-bars #f]
|
|
[pretty-print-show-inexactness #f]
|
|
[pretty-print-abbreviate-read-macros #t]
|
|
[pretty-print-current-style-table default-pretty-print-current-style-table]
|
|
[pretty-print-remap-stylable (λ (x) #f)]
|
|
[pretty-print-print-line
|
|
(lambda (line port offset width)
|
|
(when (and (number? width)
|
|
(not (eq? 0 line)))
|
|
(newline port))
|
|
0)]
|
|
|
|
[pretty-print-columns width]
|
|
[pretty-print-size-hook
|
|
(let ([oh (pretty-print-size-hook)])
|
|
(λ (value display? port)
|
|
(cond
|
|
[(not (port-writes-special? port)) (oh value display? port)]
|
|
[(is-a? value snip%) 1]
|
|
[(use-number-snip? value) 1]
|
|
[(syntax? value) 1]
|
|
[(to-snip-value? value) 1]
|
|
[else (oh value display? port)])))]
|
|
[pretty-print-print-hook
|
|
(let ([oh (pretty-print-print-hook)])
|
|
(λ (value display? port)
|
|
(cond
|
|
[(not (port-writes-special? port)) (oh value display? port)]
|
|
[(is-a? value snip%)
|
|
(cond
|
|
[(image-core:image? value)
|
|
|
|
;; do this computation here so that any failures
|
|
;; during drawing happen under the user's custodian
|
|
(image-core:compute-image-cache value)
|
|
(write-special value port)
|
|
1]
|
|
[else
|
|
(write-special value port)
|
|
1])]
|
|
[(use-number-snip? value)
|
|
(write-special
|
|
(case (simple-settings-fraction-style settings)
|
|
[(mixed-fraction)
|
|
(number-snip:make-fraction-snip value #f)]
|
|
[(mixed-fraction-e)
|
|
(number-snip:make-fraction-snip value #t)]
|
|
[(repeating-decimal)
|
|
(number-snip:make-repeating-decimal-snip value #f)]
|
|
[(repeating-decimal-e)
|
|
(number-snip:make-repeating-decimal-snip value #t)])
|
|
port)
|
|
1]
|
|
[(syntax? value)
|
|
(write-special (render-syntax/snip value) port)]
|
|
[(to-snip-value? value)
|
|
(write-special (value->snip value) port)]
|
|
[else (oh value display? port)])))]
|
|
[print-graph
|
|
;; only turn on print-graph when using `write' or `print' printing
|
|
;; style, because the sharing is being taken care of
|
|
;; by the print-convert sexp construction when using
|
|
;; other printing styles.
|
|
(and (memq (simple-settings-printing-style settings) '(write print))
|
|
(simple-settings-show-sharing settings))])
|
|
(thunk))))
|
|
|
|
;; drscheme-inspector : inspector
|
|
(define drscheme-inspector (current-inspector))
|
|
|
|
;; simple-module-based-language-convert-value : TST settings -> TST
|
|
(define (simple-module-based-language-convert-value value settings)
|
|
(case (simple-settings-printing-style settings)
|
|
[(print) (values value #f)]
|
|
[(write trad-write) value]
|
|
[(constructor)
|
|
(parameterize ([constructor-style-printing #t]
|
|
[show-sharing (simple-settings-show-sharing settings)]
|
|
[current-print-convert-hook (leave-snips-alone-hook (current-print-convert-hook))])
|
|
(print-convert value))]
|
|
[(quasiquote)
|
|
(parameterize ([constructor-style-printing #f]
|
|
[show-sharing (simple-settings-show-sharing settings)]
|
|
[current-print-convert-hook (leave-snips-alone-hook (current-print-convert-hook))])
|
|
(print-convert value))]))
|
|
|
|
;; leave-snips-alone-hook : any? (any? -> printable) any? -> printable
|
|
(define ((leave-snips-alone-hook sh) expr basic-convert sub-convert)
|
|
(if (or (is-a? expr snip%)
|
|
(to-snip-value? expr))
|
|
expr
|
|
(sh expr basic-convert sub-convert)))
|
|
|
|
;; initialize-simple-module-based-language : setting ((-> void) -> void)
|
|
(define (initialize-simple-module-based-language setting run-in-user-thread)
|
|
(run-in-user-thread
|
|
(λ ()
|
|
|
|
(let ([annotations (simple-settings-annotations setting)])
|
|
(case annotations
|
|
[(debug)
|
|
(current-compile (el:make-errortrace-compile-handler))
|
|
(error-display-handler
|
|
(drracket:debug:make-debug-error-display-handler
|
|
(error-display-handler)))
|
|
(use-compiled-file-paths
|
|
(cons (build-path "compiled" "errortrace")
|
|
(use-compiled-file-paths)))]
|
|
|
|
[(debug/profile)
|
|
(drracket:debug:profiling-enabled #t)
|
|
(error-display-handler
|
|
(drracket:debug:make-debug-error-display-handler
|
|
(error-display-handler)))
|
|
(current-eval (drracket:debug:make-debug-eval-handler (current-eval)))]
|
|
|
|
[(debug/profile test-coverage)
|
|
(drracket:debug:test-coverage-enabled #t)
|
|
(current-eval (drracket:debug:make-debug-eval-handler (current-eval)))]))
|
|
|
|
(global-port-print-handler
|
|
(λ (value port [depth 0])
|
|
(let-values ([(converted-value write?)
|
|
(call-with-values
|
|
(lambda () (simple-module-based-language-convert-value value setting))
|
|
(case-lambda
|
|
[(converted-value) (values converted-value #t)]
|
|
[(converted-value write?) (values converted-value write?)]))])
|
|
(setup-printing-parameters
|
|
(λ ()
|
|
(parameterize ([pretty-print-columns 'infinity])
|
|
((if write? pretty-write pretty-print) converted-value port)))
|
|
setting
|
|
'infinity))))
|
|
(current-inspector (make-inspector))
|
|
(read-case-sensitive (simple-settings-case-sensitive setting)))))
|
|
|
|
;; simple-module-based-language-get-init-code : setting -> sexp[module]
|
|
(define (simple-module-based-language-get-init-code setting)
|
|
`(module mod-name mzscheme
|
|
(require mzlib/pconvert
|
|
mzlib/pretty)
|
|
|
|
(provide init-code)
|
|
|
|
(define (executable-error-value->string-handler val size)
|
|
(let ([o (open-output-string)])
|
|
(render-value val o)
|
|
(let ([s (get-output-string o)])
|
|
(if ((string-length s) . <= . size)
|
|
s
|
|
(string-append
|
|
(substring s 0 (- size 3))
|
|
"...")))))
|
|
|
|
(define (render-value value port)
|
|
(parameterize ([pretty-print-columns 'infinity])
|
|
,(case (simple-settings-printing-style setting)
|
|
[(print) `(pretty-print value port)]
|
|
[(write trad-write) `(pretty-write value port)]
|
|
[(constructor)
|
|
`(parameterize ([constructor-style-printing #t]
|
|
[show-sharing ,(simple-settings-show-sharing setting)])
|
|
(pretty-write (print-convert value) port))]
|
|
[(quasiquote)
|
|
`(parameterize ([constructor-style-printing #f]
|
|
[show-sharing ,(simple-settings-show-sharing setting)])
|
|
(pretty-write (print-convert value) port))])))
|
|
|
|
,(if (memq (simple-settings-annotations setting) '(debug debug/profile test-coverage))
|
|
`(require errortrace)
|
|
`(void))
|
|
|
|
(define (init-code)
|
|
(current-inspector (make-inspector))
|
|
(error-value->string-handler executable-error-value->string-handler)
|
|
(read-case-sensitive ,(simple-settings-case-sensitive setting)))))
|
|
|
|
|
|
;; module-based-language->language : module-based-language -> language<%>
|
|
;; given a module-based-language, implements a language
|
|
(define module-based-language->language-mixin
|
|
(mixin (module-based-language<%>) (language<%>)
|
|
(inherit get-module get-transformer-module use-namespace-require/copy-from-setting?
|
|
get-init-code use-mred-launcher get-reader)
|
|
|
|
(define/public (front-end/finished-complete-program settings) (void))
|
|
(define/public (module-based-language->language-mixin settings) (void))
|
|
|
|
(define/pubment (capability-value s)
|
|
(inner (get-capability-default s) capability-value s))
|
|
|
|
(define/public (first-opened) (void))
|
|
(define/public (get-comment-character) (values "; " #\;))
|
|
|
|
(inherit get-language-position)
|
|
(define/public (get-language-name)
|
|
(let ([pos (get-language-position)])
|
|
(if (null? pos)
|
|
"<<unknown>>"
|
|
(car (last-pair pos)))))
|
|
(define/public (get-style-delta) #f)
|
|
(define/override (on-execute setting run-in-user-thread)
|
|
(super on-execute setting run-in-user-thread)
|
|
(initialize-module-based-language (use-namespace-require/copy-from-setting? setting)
|
|
(get-module)
|
|
(get-transformer-module)
|
|
run-in-user-thread))
|
|
(define/public (front-end/complete-program port settings)
|
|
(module-based-language-front-end port (get-reader)))
|
|
(define/public (front-end/interaction port settings)
|
|
(module-based-language-front-end port (get-reader)))
|
|
(define/public (create-executable setting parent program-filename)
|
|
(create-module-based-language-executable parent
|
|
program-filename
|
|
(get-module)
|
|
(get-transformer-module)
|
|
(get-init-code setting)
|
|
(use-mred-launcher)
|
|
(use-namespace-require/copy-from-setting? setting)))
|
|
(define/public (extra-repl-information _1 _2) (void))
|
|
(define/public (get-reader-module) #f)
|
|
(define/public (get-metadata a b) #f)
|
|
(define/public (metadata->settings m) #f)
|
|
(define/public (get-metadata-lines) #f)
|
|
|
|
(super-new)))
|
|
|
|
;; create-module-based-language-executable :
|
|
;; (is-a?/c area-container<%>) string (or #f module-spec) module-spec sexp (union boolean? 'ask) boolean?
|
|
;; -> void
|
|
(define (create-module-based-language-executable parent
|
|
program-filename
|
|
module-language-spec
|
|
transformer-module-language-spec
|
|
init-code
|
|
mred-launcher
|
|
use-copy?)
|
|
(let ([executable-specs (create-executable-gui parent
|
|
program-filename
|
|
#t
|
|
(if (boolean? mred-launcher)
|
|
(if mred-launcher
|
|
'mred
|
|
'mzscheme)
|
|
#t))])
|
|
(when executable-specs
|
|
(let* ([type (car executable-specs)]
|
|
[base (cadr executable-specs)]
|
|
[executable-filename (caddr executable-specs)]
|
|
[create-executable
|
|
(case type
|
|
[(launcher) create-module-based-launcher]
|
|
[(stand-alone) create-module-based-stand-alone-executable]
|
|
[(distribution) create-module-based-distribution])])
|
|
(create-executable
|
|
program-filename
|
|
executable-filename
|
|
module-language-spec
|
|
transformer-module-language-spec
|
|
init-code
|
|
(if (boolean? mred-launcher)
|
|
mred-launcher
|
|
(eq? base 'mred))
|
|
use-copy?)))))
|
|
|
|
|
|
;; create-executable-gui : (union #f (is-a?/c top-level-area-container<%>))
|
|
;; (union #f string?)
|
|
;; (union #t 'launcher 'stand-alone 'distribution)
|
|
;; (union #t 'mzscheme 'mred)
|
|
;; -> (union #f (list (union 'no-show 'launcher 'stand-alone 'distribution)
|
|
;; (union 'no-show 'mzscheme 'mred)
|
|
;; string[filename]))
|
|
(define (create-executable-gui parent program-filename show-type show-base)
|
|
(define dlg (make-object dialog% (string-constant create-executable-title) parent))
|
|
(define filename-panel (make-object horizontal-panel% dlg))
|
|
(define filename-text-field (new text-field%
|
|
[label (string-constant filename)]
|
|
[parent filename-panel]
|
|
[init-value (path->string
|
|
(default-executable-filename
|
|
program-filename
|
|
(if (eq? show-type #t) 'launcher show-type)
|
|
#f))]
|
|
[min-width 400]
|
|
[callback void]))
|
|
(define filename-browse-button (instantiate button% ()
|
|
(label (string-constant browse...))
|
|
(parent filename-panel)
|
|
(callback
|
|
(λ (x y) (browse-callback)))))
|
|
(define type/base-panel (instantiate vertical-panel% ()
|
|
(parent dlg)
|
|
(stretchable-width #f)))
|
|
(define type-panel (make-object horizontal-panel% type/base-panel))
|
|
(define type-rb (and (boolean? show-type)
|
|
(instantiate radio-box% ()
|
|
(label (string-constant executable-type))
|
|
(choices (list (string-constant launcher-explanatory-label)
|
|
(string-constant stand-alone-explanatory-label)
|
|
(string-constant distribution-explanatory-label)))
|
|
(parent type-panel)
|
|
(callback (lambda (rb e)
|
|
(preferences:set 'drracket:create-executable-gui-type
|
|
(case (send rb get-selection)
|
|
[(0) 'launcher]
|
|
[(1) 'stand-alone]
|
|
[(2) 'distribution]))
|
|
(reset-filename-suffix))))))
|
|
(define base-panel (make-object horizontal-panel% type/base-panel))
|
|
(define base-rb (and (boolean? show-base)
|
|
(instantiate radio-box% ()
|
|
(label (string-constant executable-base))
|
|
(choices (list "Racket" "GRacket"))
|
|
(parent base-panel)
|
|
(callback (lambda (rb e)
|
|
(preferences:set 'drracket:create-executable-gui-base
|
|
(case (send rb get-selection)
|
|
[(0) 'racket]
|
|
[(1) 'gracket]))
|
|
(reset-filename-suffix))))))
|
|
|
|
(define (reset-filename-suffix)
|
|
(let ([s (send filename-text-field get-value)])
|
|
(unless (string=? s "")
|
|
(let ([new-s (default-executable-filename
|
|
(string->path s)
|
|
(current-mode)
|
|
(not (currently-mzscheme-binary?)))])
|
|
(send filename-text-field set-value (path->string new-s))))))
|
|
|
|
(define button-panel (instantiate horizontal-panel% ()
|
|
(parent dlg)
|
|
(alignment '(right center))))
|
|
|
|
(define-values (ok-button cancel-button)
|
|
(gui-utils:ok/cancel-buttons
|
|
button-panel
|
|
(λ (x y)
|
|
(when (check-filename)
|
|
(set! cancelled? #f)
|
|
(send dlg show #f)))
|
|
(λ (x y) (send dlg show #f))
|
|
(string-constant create)
|
|
(string-constant cancel)))
|
|
|
|
(define (browse-callback)
|
|
(let ([ftf (send filename-text-field get-value)])
|
|
(let-values ([(base name _)
|
|
(if (path-string? ftf)
|
|
(split-path ftf)
|
|
(values (current-directory) "" #f))])
|
|
(let* ([mzscheme? (currently-mzscheme-binary?)]
|
|
[mode (current-mode)]
|
|
[filename
|
|
(put-executable/defaults
|
|
dlg
|
|
base
|
|
name
|
|
mode
|
|
(not mzscheme?)
|
|
(case mode
|
|
[(launcher)
|
|
(if mzscheme?
|
|
(string-constant save-a-mzscheme-launcher)
|
|
(string-constant save-a-mred-launcher))]
|
|
[(stand-alone)
|
|
(if mzscheme?
|
|
(string-constant save-a-mzscheme-stand-alone-executable)
|
|
(string-constant save-a-mred-stand-alone-executable))]
|
|
[(distribution)
|
|
(if mzscheme?
|
|
(string-constant save-a-mzscheme-distribution)
|
|
(string-constant save-a-mred-distribution))]))])
|
|
(when filename
|
|
(send filename-text-field set-value (path->string filename)))))))
|
|
|
|
(define (currently-mzscheme-binary?)
|
|
(cond
|
|
[base-rb
|
|
(= 0 (send base-rb get-selection))]
|
|
[else (eq? show-base 'mzscheme)]))
|
|
|
|
(define (current-mode)
|
|
(cond
|
|
[type-rb
|
|
(let ([s (send type-rb get-item-label (send type-rb get-selection))])
|
|
(cond
|
|
[(equal? s (string-constant launcher-explanatory-label)) 'launcher]
|
|
[(equal? s (string-constant stand-alone-explanatory-label)) 'stand-alone]
|
|
[(equal? s (string-constant distribution-explanatory-label)) 'distribution]))]
|
|
[else show-type]))
|
|
|
|
(define (check-filename)
|
|
(let ([filename-str (send filename-text-field get-value)]
|
|
[mred? (not (currently-mzscheme-binary?))]
|
|
[mode (current-mode)])
|
|
(let-values ([(extension style filters)
|
|
(mode->put-file-extension+style+filters mode mred?)])
|
|
(cond
|
|
[(string=? "" filename-str)
|
|
(message-box (string-constant drscheme)
|
|
(string-constant please-specify-a-filename)
|
|
dlg)
|
|
#f]
|
|
[(not (users-name-ok? mode extension dlg (string->path filename-str)))
|
|
#f]
|
|
[(or (directory-exists? filename-str)
|
|
(file-exists? filename-str))
|
|
(ask-user-can-clobber? filename-str)]
|
|
[else #t]))))
|
|
|
|
;; ask-user-can-clobber-directory? : (is-a?/c top-level-window<%>) string -> boolean
|
|
(define (ask-user-can-clobber? filename)
|
|
(eq? (message-box (string-constant drscheme)
|
|
(format (string-constant are-you-sure-delete?) filename)
|
|
dlg
|
|
'(yes-no))
|
|
'yes))
|
|
|
|
(define cancelled? #t)
|
|
(when type-rb
|
|
(send type-rb set-selection
|
|
(case (preferences:get 'drracket:create-executable-gui-type)
|
|
[(launcher) 0]
|
|
[(stand-alone) 1]
|
|
[(distribution) 2])))
|
|
(when base-rb
|
|
(send base-rb set-selection
|
|
(case (preferences:get 'drracket:create-executable-gui-base)
|
|
[(racket) 0]
|
|
[(gracket) 1])))
|
|
(reset-filename-suffix)
|
|
(send dlg show #t)
|
|
(cond
|
|
[cancelled? #f]
|
|
[else
|
|
(list
|
|
(if type-rb
|
|
(current-mode)
|
|
'no-show)
|
|
(if base-rb
|
|
(case (send base-rb get-selection)
|
|
[(0) 'mzscheme]
|
|
[(1) 'mred])
|
|
'no-show)
|
|
(send filename-text-field get-value))]))
|
|
|
|
(define (normalize-mode mode)
|
|
(case mode
|
|
[(launcher stand-alone distribution) mode]
|
|
;; Backward compatibility: interpret a boolean
|
|
[else (if mode 'launcher 'stand-alone)]))
|
|
|
|
;; put-executable : parent string (union boolean 'launcher 'stand-alone 'distribution) boolean -> (union false? string)
|
|
;; invokes the put-file dialog with arguments specific to building executables
|
|
(define (put-executable parent program-filename mode mred? title)
|
|
(let-values ([(base name dir) (split-path program-filename)])
|
|
(let ([mode (normalize-mode mode)])
|
|
(let ([default-name (default-executable-filename name mode mred?)])
|
|
(put-executable/defaults
|
|
parent
|
|
base
|
|
default-name
|
|
mode
|
|
mred?
|
|
title)))))
|
|
|
|
;; put-executable/defaults : parent string string symbol boolean -> (union false? string)
|
|
(define (put-executable/defaults parent default-dir default-name mode mred? title)
|
|
(let-values ([(extension style filters)
|
|
(mode->put-file-extension+style+filters mode mred?)])
|
|
(let* ([dir? (case mode
|
|
[(launcher)
|
|
(if mred?
|
|
(mred-launcher-is-directory?)
|
|
(mzscheme-launcher-is-directory?))]
|
|
[(stand-alone)
|
|
(embedding-executable-is-directory? mred?)]
|
|
[(distribution) #f])]
|
|
[users-name
|
|
(if dir?
|
|
(get-directory title
|
|
parent
|
|
default-dir
|
|
style)
|
|
(put-file title
|
|
parent
|
|
default-dir
|
|
default-name
|
|
extension
|
|
style
|
|
filters))])
|
|
(and users-name
|
|
(users-name-ok? mode extension parent users-name)
|
|
(or (not dir?)
|
|
(gui-utils:get-choice
|
|
(format (string-constant warning-directory-will-be-replaced)
|
|
users-name)
|
|
(string-constant yes)
|
|
(string-constant no)
|
|
(string-constant drscheme)
|
|
#f
|
|
parent))
|
|
users-name))))
|
|
|
|
;; users-name-ok? : symbol string (union #f frame% dialog%) path? -> boolean
|
|
;; returns #t if the string is an acceptable name for
|
|
;; a saved executable, and #f otherwise.
|
|
(define (users-name-ok? mode extension parent name)
|
|
(or (not extension)
|
|
(let ([suffix-m (regexp-match #rx"[.][^.]*$" (path->string name))])
|
|
(or (and suffix-m
|
|
(string=? (substring (car suffix-m) 1) extension))
|
|
(and
|
|
(message-box (string-constant drscheme)
|
|
(format
|
|
(string-constant ~a-must-end-with-~a)
|
|
(case mode
|
|
[(launcher) (string-constant launcher)]
|
|
[(stand-alone) (string-constant stand-alone)]
|
|
[(distribution) (string-constant distribution)])
|
|
name
|
|
extension)
|
|
parent)
|
|
#f)))))
|
|
|
|
;; default-executable-filename : path symbol boolean -> path
|
|
(define (default-executable-filename program-filename mode mred?)
|
|
(let ([ext (let-values ([(extension style filters)
|
|
(mode->put-file-extension+style+filters mode mred?)])
|
|
(if extension
|
|
(string->bytes/utf-8 (string-append "." extension))
|
|
#""))])
|
|
(path-replace-suffix program-filename ext)))
|
|
|
|
(define (mode->put-file-extension+style+filters mode mred?)
|
|
(case mode
|
|
[(launcher)
|
|
(if mred?
|
|
(mred-launcher-put-file-extension+style+filters)
|
|
(mzscheme-launcher-put-file-extension+style+filters))]
|
|
[(stand-alone)
|
|
(embedding-executable-put-file-extension+style+filters mred?)]
|
|
[(distribution)
|
|
(bundle-put-file-extension+style+filters)]))
|
|
|
|
;; create-module-based-stand-alone-executable : ... -> void (see docs)
|
|
(define (create-module-based-stand-alone-executable program-filename
|
|
executable-filename
|
|
module-language-spec
|
|
transformer-module-language-spec
|
|
init-code
|
|
gui?
|
|
use-copy?)
|
|
|
|
(with-handlers ([(λ (x) #f) ;exn:fail?
|
|
(λ (x)
|
|
(message-box
|
|
(string-constant drscheme)
|
|
(format "~a" (exn-message x)))
|
|
(void))])
|
|
(define init-code-tmp-filename (make-temporary-file "drs-standalone-exectable-init~a"))
|
|
(define bootstrap-tmp-filename (make-temporary-file "drs-standalone-exectable-bootstrap~a"))
|
|
(let ([init-code-mod-name
|
|
(let-values ([(base name dir?)
|
|
(split-path init-code-tmp-filename)])
|
|
(string->symbol (path->string name)))])
|
|
|
|
(call-with-output-file bootstrap-tmp-filename
|
|
(λ (port)
|
|
(write `(let () ;; cannot use begin, since it gets flattened to top-level (and re-compiled!)
|
|
,@(if module-language-spec
|
|
(if use-copy?
|
|
(list
|
|
`(namespace-require/copy ',module-language-spec))
|
|
(list
|
|
`(namespace-require/constant ',module-language-spec)))
|
|
'())
|
|
,@(if transformer-module-language-spec
|
|
(list `(namespace-require `(for-syntax ,transformer-module-language-spec)))
|
|
(list))
|
|
((dynamic-require ',init-code-mod-name 'init-code)))
|
|
port))
|
|
#:exists 'truncate
|
|
#:mode 'text)
|
|
|
|
(let ([new-init-code
|
|
(list*
|
|
(car init-code)
|
|
init-code-mod-name
|
|
(cddr init-code))])
|
|
(call-with-output-file init-code-tmp-filename
|
|
(λ (port)
|
|
(write new-init-code port))
|
|
#:exists 'truncate #:mode 'text)))
|
|
|
|
(let* ([pre-to-be-embedded-module-specs0
|
|
(cond
|
|
[(and module-language-spec transformer-module-language-spec)
|
|
(if (equal? module-language-spec transformer-module-language-spec)
|
|
(list module-language-spec)
|
|
(list module-language-spec transformer-module-language-spec))]
|
|
[module-language-spec
|
|
(list module-language-spec)]
|
|
[transformer-module-language-spec
|
|
(list transformer-module-language-spec)]
|
|
[else '()])]
|
|
[pre-to-be-embedded-module-specs1
|
|
(if gui?
|
|
(cons '(lib "mred/mred.rkt")
|
|
pre-to-be-embedded-module-specs0)
|
|
pre-to-be-embedded-module-specs0)]
|
|
[pre-to-be-embedded-module-specs2
|
|
(cons `(file ,(path->string init-code-tmp-filename))
|
|
pre-to-be-embedded-module-specs1)]
|
|
[pre-to-be-embedded-module-specs3
|
|
(filter (λ (x) (not (eq? x 'mzscheme)))
|
|
pre-to-be-embedded-module-specs2)]
|
|
[to-be-embedded-module-specs
|
|
(map (λ (x) (list #f x))
|
|
pre-to-be-embedded-module-specs3)])
|
|
|
|
(create-embedding-executable
|
|
executable-filename
|
|
#:mred? gui?
|
|
#:verbose? #f ;; verbose?
|
|
#:modules to-be-embedded-module-specs
|
|
#:literal-files (list
|
|
bootstrap-tmp-filename
|
|
program-filename)
|
|
#:cmdline (if gui?
|
|
(list "-mvqZ")
|
|
(list "-mvq"))))
|
|
(delete-file init-code-tmp-filename)
|
|
(delete-file bootstrap-tmp-filename)
|
|
(void)))
|
|
|
|
;; create-module-based-distribution : ... -> void (see docs)
|
|
(define (create-module-based-distribution program-filename
|
|
distribution-filename
|
|
module-language-spec
|
|
transformer-module-language-spec
|
|
init-code
|
|
gui?
|
|
use-copy?)
|
|
(create-distribution-for-executable
|
|
distribution-filename
|
|
gui?
|
|
(lambda (exe-name)
|
|
(create-module-based-stand-alone-executable program-filename
|
|
exe-name
|
|
module-language-spec
|
|
transformer-module-language-spec
|
|
init-code
|
|
gui?
|
|
use-copy?))))
|
|
|
|
;; create-distribution-for-executable : ... -> void (see docs)
|
|
(define (create-distribution-for-executable distribution-filename
|
|
gui?
|
|
make-executable)
|
|
;; Delete old file, if it exists:
|
|
(when (file-exists? distribution-filename)
|
|
(delete-file distribution-filename))
|
|
;; Figure out base name, and create working temp directory:
|
|
(let* ([base-name (let-values ([(base name dir?) (split-path distribution-filename)])
|
|
(path-replace-suffix name #""))]
|
|
[temp-dir
|
|
(make-temporary-file "drscheme-tmp-~a" 'directory)]
|
|
[c (make-custodian)]
|
|
[dialog (new dialog%
|
|
[label (string-constant distribution-progress-window-title)]
|
|
[width 400])]
|
|
[status-message
|
|
(new message%
|
|
[label (string-constant creating-executable-progress-status)]
|
|
[parent dialog]
|
|
[stretchable-width #t])]
|
|
[pane (new vertical-pane%
|
|
[parent dialog])]
|
|
[abort-button
|
|
(new button%
|
|
[parent pane]
|
|
[label (string-constant abort)]
|
|
[callback (lambda (_1 _2)
|
|
(custodian-shutdown-all c))])]
|
|
|
|
[exn #f]
|
|
|
|
[worker-thread
|
|
(parameterize ([current-custodian c])
|
|
(thread
|
|
(λ ()
|
|
(with-handlers ([exn? (λ (e) (set! exn e))])
|
|
;; Build the exe:
|
|
(make-directory (build-path temp-dir "exe"))
|
|
(let ([exe-name (build-path temp-dir "exe" (default-executable-filename base-name 'stand-alone gui?))])
|
|
(make-executable exe-name)
|
|
(when (or (file-exists? exe-name)
|
|
(directory-exists? exe-name))
|
|
(let ([dist-dir (build-path temp-dir base-name)])
|
|
;; Assemble the bundle directory:
|
|
(queue-callback
|
|
(λ ()
|
|
(send status-message set-label (string-constant assembling-distribution-files-progress-status))))
|
|
(assemble-distribution dist-dir (list exe-name))
|
|
;; Pack it:
|
|
(queue-callback
|
|
(λ ()
|
|
(send status-message set-label (string-constant packing-distribution-progress-status))))
|
|
(bundle-directory distribution-filename dist-dir #t))))))))])
|
|
|
|
;; create a thread that will trigger hiding the dialog and the return from `show'
|
|
;; when things are done (no matter if there was a kill, or just normal terminiation)
|
|
(thread
|
|
(λ ()
|
|
(thread-wait worker-thread)
|
|
(queue-callback (λ () (send dialog show #f)))))
|
|
|
|
(send dialog show #t)
|
|
|
|
;; Clean up:
|
|
(custodian-shutdown-all c)
|
|
(delete-directory/files temp-dir)
|
|
|
|
(when exn
|
|
(raise exn))))
|
|
|
|
|
|
(define (condense-scheme-code-string s)
|
|
(let ([i (open-input-string s)]
|
|
[o (open-output-string)])
|
|
(let loop ()
|
|
(let ([c (read-char i)])
|
|
(unless (eof-object? c)
|
|
(let ([next (λ ()
|
|
(display c o)
|
|
(loop))])
|
|
(case c
|
|
[(#\space)
|
|
(if (char=? #\( (peek-char i))
|
|
(loop)
|
|
(next))]
|
|
[(#\))
|
|
(if (eq? #\space (peek-char i))
|
|
(begin
|
|
(display #\) o)
|
|
(read-char i)
|
|
(loop))
|
|
(next))]
|
|
[(#\\)
|
|
(begin
|
|
(display #\\ o)
|
|
(display (read-char i) o)
|
|
(loop))]
|
|
[(#\" #\|)
|
|
(display c o)
|
|
(let loop ()
|
|
(let ([v (read-char i)])
|
|
(cond
|
|
[(eq? v c) (next)]
|
|
[(eq? v #\\)
|
|
(display v o)
|
|
(display (read-char i) o)
|
|
(loop)]
|
|
[else (display v o)
|
|
(loop)])))]
|
|
[else (next)])))))
|
|
(get-output-string o)))
|
|
|
|
(define (create-module-based-launcher program-filename
|
|
executable-filename
|
|
module-language-spec
|
|
transformer-module-language-spec
|
|
init-code
|
|
gui?
|
|
use-copy?)
|
|
|
|
(with-handlers ([(λ (x) #f) ;exn:fail?
|
|
(λ (x)
|
|
(message-box
|
|
(string-constant drscheme)
|
|
(format "~a" (exn-message x)))
|
|
(void))])
|
|
|
|
((if gui? make-mred-launcher make-mzscheme-launcher)
|
|
(list
|
|
(path->string
|
|
(collection-file-path (if gui?
|
|
"launcher-mred-bootstrap.rkt"
|
|
"launcher-mz-bootstrap.rkt")
|
|
"drracket" "private"))
|
|
(condense-scheme-code-string (format "~s" init-code))
|
|
(path->string program-filename)
|
|
(format "~s" module-language-spec)
|
|
(format "~s" transformer-module-language-spec)
|
|
(format "~s" use-copy?))
|
|
(if (path? executable-filename)
|
|
(path->string executable-filename)
|
|
executable-filename))))
|
|
|
|
;; initialize-module-based-language : boolean (or #f module-spec) module-spec ((-> void) -> void)
|
|
(define (initialize-module-based-language use-copy?
|
|
module-spec
|
|
transformer-module-spec
|
|
run-in-user-thread)
|
|
(run-in-user-thread
|
|
(λ ()
|
|
(with-handlers ([(λ (x) #t)
|
|
(λ (x)
|
|
(display (if (exn? x)
|
|
(exn-message x)
|
|
(format "~s" x)))
|
|
(newline))])
|
|
(when module-spec
|
|
(if use-copy?
|
|
(namespace-require/copy module-spec)
|
|
(namespace-require/constant module-spec)))
|
|
(when transformer-module-spec
|
|
(namespace-require `(for-syntax ,transformer-module-spec)))))))
|
|
|
|
;; module-based-language-front-end : (port reader -> (-> (union sexp syntax eof)))
|
|
;; type reader = type-spec-of-read-syntax (see mz manual for details)
|
|
(define (module-based-language-front-end port reader)
|
|
(λ ()
|
|
(let ([s (reader (object-name port) port)])
|
|
(if (syntax? s)
|
|
(namespace-syntax-introduce
|
|
(datum->syntax
|
|
#f
|
|
(cons '#%top-interaction s)
|
|
s))
|
|
s))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; snip/value extensions
|
|
;;
|
|
|
|
(define to-snips null)
|
|
(define-struct to-snip (predicate? >value setup-thunk))
|
|
(define add-snip-value
|
|
(lambda (predicate constructor [setup-thunk void])
|
|
(set! to-snips (cons (make-to-snip predicate constructor setup-thunk) to-snips))))
|
|
|
|
(define (value->snip v)
|
|
(ormap (λ (to-snip) (and ((to-snip-predicate? to-snip) v)
|
|
((to-snip->value to-snip) v)))
|
|
to-snips))
|
|
(define (to-snip-value? v)
|
|
(ormap (λ (to-snip) ((to-snip-predicate? to-snip) v)) to-snips))
|
|
(define (setup-setup-values)
|
|
(for-each (λ (t) ((to-snip-setup-thunk t))) to-snips))
|
|
|
|
|
|
(define capabilities '())
|
|
(define (capability-registered? x) (and (assoc x capabilities) #t))
|
|
(define (register-capability name contract default)
|
|
(when (capability-registered? name)
|
|
(error 'register-capability "already registered capability ~s" name))
|
|
(set! capabilities (cons (list name default contract) capabilities)))
|
|
(define (get-capability-default name)
|
|
(let ([l (assoc name capabilities)])
|
|
(unless l
|
|
(error 'get-capability-default "name not bound ~s" name))
|
|
(cadr l)))
|
|
(define (get-capability-contract name)
|
|
(let ([l (assoc name capabilities)])
|
|
(unless l
|
|
(error 'get-capability-contract "name not bound ~s" name))
|
|
(caddr l)))
|
|
|
|
|
|
;
|
|
;
|
|
; ;;;;;; ;
|
|
; ; ; ;
|
|
; ; ; ;; ;; ;;;;; ;;; ;; ;; ;;;; ;;; ;;; ;; ;; ;;;;
|
|
; ;;; ; ; ; ; ; ;; ; ; ; ; ; ; ;; ; ; ;
|
|
; ; ; ;; ; ;;;;; ; ; ;;; ; ; ; ; ; ;;;
|
|
; ; ;; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;;;;;; ;; ;; ;;; ;;;; ;;; ;;; ;;;; ;;;;; ;;; ;;; ;;; ;;;;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
|
|
|
|
|
|
(define language-extensions null)
|
|
(define (get-language-extensions)
|
|
(drracket:tools:only-in-phase
|
|
'drracket:language:get-default-mixin
|
|
'phase2)
|
|
language-extensions)
|
|
|
|
(define (default-mixin x) x)
|
|
(define (get-default-mixin)
|
|
(drracket:tools:only-in-phase
|
|
'drracket:language:get-default-mixin
|
|
'phase2)
|
|
default-mixin)
|
|
|
|
(define (extend-language-interface extension<%> default-impl)
|
|
(drracket:tools:only-in-phase
|
|
'drracket:language:extend-language-interface
|
|
'phase1)
|
|
(set! default-mixin (compose default-impl default-mixin))
|
|
(set! language-extensions (cons extension<%> language-extensions)))
|