test-suite is no longer maintained, profjBoxes are RIP too
svn: r5240
This commit is contained in:
Eli Barzilay
parent
f2a8dbbb53
commit
5f1c8da8f5
|
|
@ -1,5 +0,0 @@
|
|||
(module info (lib "infotab.ss" "setup")
|
||||
(define name "ProfJ Boxes")
|
||||
(define tools '(("tool.ss")))
|
||||
(define tool-names (list "ProfJ Boxes"))
|
||||
#;(define tool-icons '()))
|
||||
|
|
@ -1,11 +0,0 @@
|
|||
(module box-helpers mzscheme
|
||||
|
||||
(require (lib "list.ss")
|
||||
(lib "etc.ss"))
|
||||
|
||||
(provide last)
|
||||
|
||||
(define (last alist)
|
||||
(with-handlers ([void (lambda (error) false)])
|
||||
(first (last-pair alist))))
|
||||
)
|
||||
|
|
@ -1,252 +0,0 @@
|
|||
(module example-box mzscheme
|
||||
|
||||
(require
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "class.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
(lib "embedded-gui.ss" "embedded-gui")
|
||||
(lib "match.ss")
|
||||
(lib "unit.ss")
|
||||
(lib "tool.ss" "drscheme")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "parser.ss" "profj")
|
||||
(lib "readerr.ss" "syntax")
|
||||
(lib "make-snipclass.ss" "test-suite" "private")
|
||||
(lib "string-constant.ss" "string-constants")
|
||||
"table.ss"
|
||||
"box-helpers.ss")
|
||||
|
||||
(provide example-box@ example-box^)
|
||||
|
||||
;; This is wrong but it's a good enough prototype
|
||||
(define re:java-id (regexp "[A-Za-z_]+"))
|
||||
(define min-field-width 50)
|
||||
|
||||
(define-signature example-box^ (example-box%))
|
||||
(define-unit example-box@
|
||||
(import drscheme:tool^)
|
||||
(export example-box^)
|
||||
|
||||
;; A readable-snip<%> of an examples box to allow GUI contruction of data examples.
|
||||
(define example-box%
|
||||
(class* (decorated-editor-snip-mixin editor-snip%) (readable-snip<%>)
|
||||
(inherit set-snipclass)
|
||||
|
||||
(init [examples-to-copy #f])
|
||||
|
||||
#;(any? (union integer? false?) (union integer? false?) (union integer? false?)
|
||||
. -> .
|
||||
any?)
|
||||
;; Called to get the syntax object representing this box
|
||||
(define/public read-special
|
||||
(opt-lambda (source (line false) (column false) (position false))
|
||||
#;(((is-a?/c text%))
|
||||
(natural-number? (union natural-number? false?))
|
||||
. opt-> .
|
||||
id?)
|
||||
;; Make an id out of the given text
|
||||
;; STATUS: I'm parsing the ID with a regexp that's probablly not
|
||||
;; the correct Java variable regexp. Furthermore, I need to parse
|
||||
;; it differently if it's a class name vs. field name.
|
||||
;;EDITED BY KATHY:: Commented this out because the result reading the example box
|
||||
;;is much different than Mike expected it would be
|
||||
#;(define (text->java-id atext)
|
||||
(let ([str (send atext get-text)])
|
||||
(match (regexp-match-positions re:java-id str 0 false)
|
||||
[((m-start . m-end))
|
||||
(datum->syntax-object
|
||||
false
|
||||
(string->symbol (substring str m-start m-end))
|
||||
(list atext
|
||||
1
|
||||
m-start
|
||||
(add1 m-start)
|
||||
(- m-end m-start)))]
|
||||
;; STATUS: Here I need to provide for a better form of
|
||||
;; highlighting using the GUI because there won't always
|
||||
;; be text in the box to highlight.
|
||||
[else (raise-read-error
|
||||
(string-constant profjBoxes-bad-java-id-error)
|
||||
atext 1 1 1 (send atext last-position))])))
|
||||
;;EDITED BY KATHY:: Same reason as stated above
|
||||
#;#`(begin #,@(send examples map-children
|
||||
(lambda (example)
|
||||
(with-syntax ([name (text->java-id
|
||||
(send example get-name))]
|
||||
[value (parse-expression
|
||||
(open-input-text-editor
|
||||
(send example get-value))
|
||||
(send example get-value)
|
||||
level)])
|
||||
#'(define name value)))))
|
||||
(syntax-property #`(parse-example-box (list #,@(send examples map-children
|
||||
(lambda (example)
|
||||
(with-syntax ([type (send example get-type)]
|
||||
[id (send example get-name)]
|
||||
[value (send example get-value)])
|
||||
#'(list type id value))))))
|
||||
'example-box #t)
|
||||
))
|
||||
|
||||
#;(-> void?)
|
||||
;; Gives this box the cursor focus
|
||||
(define/public (take-caret)
|
||||
(let ([first-box (send (send examples get-first-child) get-type)])
|
||||
(send pb set-caret-owner
|
||||
(send (send first-box get-admin) get-snip)
|
||||
'display)))
|
||||
|
||||
;;;;;;;;;;
|
||||
;; Saving and copying
|
||||
|
||||
#;((is-a?/c editor-stream-out%) . -> . void?)
|
||||
;; Writes the examples box to file
|
||||
(define/override (write f)
|
||||
(send examples write f))
|
||||
|
||||
#;((is-a?/c editor-stream-in%) . -> . void?)
|
||||
;; Reads the examples state in from an editor-stream
|
||||
(define/public (read-from-file f)
|
||||
(send examples read-from-file f))
|
||||
|
||||
#;(-> (is-a?/c test-case-box%))
|
||||
;; Makes a copy of this example box.
|
||||
(define/override (copy)
|
||||
(new example-box% (examples-to-copy examples)))
|
||||
|
||||
;;;;;;;;;;
|
||||
;; Layout
|
||||
|
||||
(define/override (get-color) "purple")
|
||||
|
||||
(field [pb (new aligned-pasteboard%)])
|
||||
(send pb lock-alignment true)
|
||||
(field [main (new vertical-alignment% (parent pb))]
|
||||
[header (new horizontal-alignment% (parent main))])
|
||||
|
||||
;; Since I don't have an icon I'll just center this for now and leave out the image
|
||||
(new horizontal-alignment% (parent header)) ; left spacer
|
||||
#;(new snip-wrapper% (parent header) (snip (make-object image-snip%)))
|
||||
(new embedded-message%
|
||||
(parent header)
|
||||
(label (string-constant profjBoxes-examples-label)))
|
||||
(new horizontal-alignment% (parent header)) ; right spacer
|
||||
|
||||
(field
|
||||
[examples (new (table example%)
|
||||
(parent main)
|
||||
(copy-constructor examples-to-copy))]
|
||||
[button-bar (new horizontal-alignment% (parent main))]
|
||||
[add-button (new embedded-text-button%
|
||||
(parent button-bar)
|
||||
(label (string-constant profjBoxes-add-new-example-button))
|
||||
(callback (lambda (b e) (send examples add-new))))])
|
||||
(super-new (editor pb))
|
||||
(unless examples-to-copy
|
||||
(send examples add-new))
|
||||
(send pb lock-alignment false)
|
||||
(set-snipclass sc)))
|
||||
|
||||
(define sc (make-snipclass example-box% "example-box%"))
|
||||
|
||||
;; An example layed out in a horizontal manner. Allows access to the pieces of an example.
|
||||
(define example%
|
||||
(class* horizontal-alignment% (table-item<%>)
|
||||
(inherit get-parent get-pasteboard next prev)
|
||||
(init (copy-constructor #f))
|
||||
|
||||
(field
|
||||
[program-editor%
|
||||
(cue-text-mixin
|
||||
(tabbable-text-mixin
|
||||
((drscheme:unit:get-program-editor-mixin)
|
||||
(editor:keymap-mixin text:basic%))))]
|
||||
[type (new (single-line-text-mixin program-editor%)
|
||||
(cue-text (if copy-constructor "" (string-constant profjBoxes-type)))
|
||||
(behavior '(on-char)))]
|
||||
[name (new (single-line-text-mixin program-editor%)
|
||||
(cue-text (if copy-constructor "" (string-constant profjBoxes-name)))
|
||||
(behavior '(on-char)))]
|
||||
[value (new program-editor%
|
||||
(cue-text (if copy-constructor "" (string-constant profjBoxes-value)))
|
||||
(behavior '(on-char)))])
|
||||
|
||||
#;(-> (is-a?/c text%))
|
||||
;; The first text in the item that can be typed into
|
||||
(define/public (get-first-text) (get-type))
|
||||
|
||||
(define/public (get-type) type)
|
||||
(define/public (get-name) name)
|
||||
(define/public (get-value) value)
|
||||
|
||||
#;((is-a?/c editor-stream-out%) . -> . void?)
|
||||
;; Write the example to file
|
||||
(define/public (write f)
|
||||
(for-each (lambda (t)
|
||||
(send* t
|
||||
(begin-edit-sequence)
|
||||
(clear-cue-text)
|
||||
(write-to-file f)
|
||||
(end-edit-sequence)))
|
||||
(list type name value)))
|
||||
|
||||
#;((is-a?/c editor-stream-out%) . -> . void?)
|
||||
;; Read the state of the example in from file
|
||||
(define/public (read-from-file f)
|
||||
(for-each (lambda (t)
|
||||
(send* t
|
||||
(begin-edit-sequence)
|
||||
(clear-cue-text)
|
||||
(read-from-file f)
|
||||
(end-edit-sequence)))
|
||||
(list type name value)))
|
||||
|
||||
(super-new)
|
||||
|
||||
(when copy-constructor
|
||||
(send (send copy-constructor get-type) copy-self-to type)
|
||||
(send (send copy-constructor get-name) copy-self-to name)
|
||||
(send (send copy-constructor get-value) copy-self-to value))
|
||||
|
||||
;;;;;;;;;;
|
||||
;; Tabbing
|
||||
|
||||
(when (is-a? (prev) example%)
|
||||
(set-tabbing (send (prev) get-value) type))
|
||||
(set-tabbing type name value)
|
||||
(if (is-a? (next) example%)
|
||||
(set-tabbing value (send (next) get-type))
|
||||
(send value set-ahead (lambda ()
|
||||
(send (get-parent) add-new))))
|
||||
|
||||
;;;;;;;;;;
|
||||
;; Layout
|
||||
|
||||
(send (get-pasteboard) lock-alignment true)
|
||||
(new snip-wrapper%
|
||||
(parent this)
|
||||
(snip (new editor-snip%
|
||||
(editor type)
|
||||
(min-width min-field-width))))
|
||||
(new snip-wrapper%
|
||||
(parent this)
|
||||
(snip (new editor-snip%
|
||||
(editor name)
|
||||
(min-width min-field-width))))
|
||||
(new embedded-message% (parent this) (label " = "))
|
||||
(new snip-wrapper%
|
||||
(parent this)
|
||||
(snip (new editor-snip%
|
||||
(editor value)
|
||||
(min-width min-field-width))))
|
||||
(new embedded-message% (parent this) (label " ; "))
|
||||
(new horizontal-alignment% (parent this)) ; spacer
|
||||
(new embedded-text-button%
|
||||
(parent this)
|
||||
(label "Delete")
|
||||
(callback (lambda (b e) (send (get-parent) delete-child this))))
|
||||
(send (get-pasteboard) lock-alignment false)
|
||||
))
|
||||
))
|
||||
|
||||
|
|
@ -1,254 +0,0 @@
|
|||
(module interactions-box mzscheme
|
||||
|
||||
(require
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "class.ss")
|
||||
(lib "etc.ss")
|
||||
(lib "list.ss")
|
||||
(lib "embedded-gui.ss" "embedded-gui")
|
||||
(lib "match.ss")
|
||||
(lib "unit.ss")
|
||||
(lib "tool.ss" "drscheme")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "readerr.ss" "syntax")
|
||||
(lib "parser.ss" "profj")
|
||||
(lib "string-constant.ss" "string-constants")
|
||||
(lib "text-syntax-object.ss" "test-suite" "private")
|
||||
(lib "print-to-text.ss" "test-suite" "private")
|
||||
(lib "make-snipclass.ss" "test-suite" "private")
|
||||
"table.ss")
|
||||
|
||||
(provide interactions-box@
|
||||
interactions-box^)
|
||||
|
||||
(define-signature interactions-box^ (interactions-box%))
|
||||
|
||||
(define-unit interactions-box@
|
||||
(import drscheme:tool^ text->syntax-object^)
|
||||
(export interactions-box^)
|
||||
(define interactions-box%
|
||||
(class* editor-snip% (readable-snip<%>)
|
||||
(inherit set-snipclass)
|
||||
(init [interactions-to-copy #f])
|
||||
|
||||
#;(any? (union integer? false?) (union integer? false?) (union integer? false?) . -> . any?)
|
||||
;; Called to get the syntax object representing this box
|
||||
(define/public read-special
|
||||
(opt-lambda (source (line false) (column false) (position false))
|
||||
#;((is-a?/c text%) . -> . syntax-object?)
|
||||
(define (text->syntax-object text)
|
||||
(match (text->syntax-objects text)
|
||||
[() (raise-read-error
|
||||
(string-constant profjBoxes-empty-error)
|
||||
source line #f position 1)]
|
||||
[(stx) stx]
|
||||
[(stx next rest-stx ...)
|
||||
(raise-read-error (string-constant profjBoxes-too-many-expressions-error)
|
||||
text
|
||||
(syntax-line next)
|
||||
(syntax-column next)
|
||||
(syntax-position next)
|
||||
(syntax-span next))]))
|
||||
;(lambda (level class-loc box-pos input-spec)
|
||||
(let ([level 'beginner] [class-loc #f] [box-pos #f] [input-spec #f])
|
||||
#`(begin
|
||||
#,@(send interactions map-children
|
||||
(lambda (interaction)
|
||||
(if (is-a? interaction interaction%)
|
||||
(with-syntax ([display-output
|
||||
(lambda (value)
|
||||
(send interaction display-output value))])
|
||||
#`(display-output
|
||||
#,(text->syntax-object (send interaction get-input))
|
||||
;#,(parse-interactions
|
||||
; (open-input-text-editor (send interaction get-input))
|
||||
; (send interaction get-input)
|
||||
; level)
|
||||
))
|
||||
#'(void))))))))
|
||||
|
||||
#;(-> void)
|
||||
;; tells the test-box to take the caret
|
||||
(define/public (take-caret)
|
||||
(let ([first-box (send (send interactions get-first-child) get-input)])
|
||||
(send pb set-caret-owner
|
||||
(send (send first-box get-admin) get-snip)
|
||||
'display)))
|
||||
|
||||
;;;;;;;;;;
|
||||
;; Reading/Writing
|
||||
|
||||
#;(-> (is-a?/c interactions-box%))
|
||||
;; Make an interaction box that is a copy of this interaction box
|
||||
(define/override (copy)
|
||||
(new interactions-box% (interactions-to-copy interactions)))
|
||||
|
||||
#;((is-a?/c editor-stream-out%) . -> . void?)
|
||||
;; Writes this interactions box to file
|
||||
(define/override (write f)
|
||||
(send interactions write f))
|
||||
|
||||
#;((is-a?/c editor-stream-in%) . -> . void?)
|
||||
;; Reads interactions from file
|
||||
(define/public (read-from-file f)
|
||||
(send interactions read-from-file f))
|
||||
|
||||
;;;;;;;;;;
|
||||
;; Layout
|
||||
|
||||
(field
|
||||
[pb (new aligned-pasteboard%)]
|
||||
[main (new vertical-alignment% (parent pb))]
|
||||
[header (new horizontal-alignment% (parent main))])
|
||||
|
||||
(new horizontal-alignment% (parent header)) ; left spacer
|
||||
(new snip-wrapper%
|
||||
(snip (make-object string-snip%
|
||||
(string-constant profjBoxes-interactions-label)))
|
||||
(parent header))
|
||||
(new horizontal-alignment% (parent header)) ; right spacer
|
||||
|
||||
(field [interactions (new (table interaction%)
|
||||
(parent main)
|
||||
(copy-constructor interactions-to-copy))])
|
||||
|
||||
(super-new (editor pb))
|
||||
(unless interactions-to-copy
|
||||
(send interactions add-new))
|
||||
(set-snipclass sc)))
|
||||
|
||||
(define sc (make-snipclass interactions-box% "interactions-box%"))
|
||||
|
||||
;; One interaction laid out horizontally
|
||||
(define interaction%
|
||||
(class* horizontal-alignment% (table-item<%>)
|
||||
(inherit get-parent next)
|
||||
(init [copy-constructor #f])
|
||||
|
||||
#;(-> (is-a?/c text%))
|
||||
;; The first text in the item that can be typed into
|
||||
(define/public (get-first-text) (get-input))
|
||||
|
||||
#;(-> (is-a?/c text%))
|
||||
;; The input of this interaction
|
||||
(define/public (get-input) input-text)
|
||||
|
||||
#;(-> void?)
|
||||
;; Resets the interaction to an inital state
|
||||
(define/public (reset)
|
||||
(send* output-text
|
||||
(lock false)
|
||||
(erase)
|
||||
(lock true))
|
||||
(send output show false))
|
||||
|
||||
#;(string? . -> . void?)
|
||||
;; Sets the output to the given value
|
||||
(define/public (display-output val)
|
||||
(let ([blue-text (new style-delta%)])
|
||||
(send blue-text set-delta-foreground "blue")
|
||||
(send* output-text
|
||||
(lock false)
|
||||
(change-style blue-text 'start 'end #f))
|
||||
;(print-to-text output-text (list val))
|
||||
(send* output-text
|
||||
(lock true))
|
||||
(send output show true)))
|
||||
|
||||
#;(-> void?)
|
||||
;; Insert a new interaction after this interaction
|
||||
(define/public (make-new)
|
||||
(send (get-parent) add-new this)
|
||||
(send (send (next) get-input) set-caret-owner false 'global))
|
||||
|
||||
#;((is-a?/c editor-stream-out%) . -> . void?)
|
||||
;; Writes the interaction to file
|
||||
(define/public (write f)
|
||||
(send input-text write-to-file f))
|
||||
|
||||
#;((is-a?/c editor-stream-in%) . -> . void?)
|
||||
;; Reads the interaction from file
|
||||
(define/public (read-from-file f)
|
||||
(send input-text read-from-file f))
|
||||
|
||||
(super-new)
|
||||
|
||||
(define program-editor%
|
||||
((drscheme:unit:get-program-editor-mixin)
|
||||
(interaction-text this)))
|
||||
|
||||
(field [input-text (new program-editor%)]
|
||||
[output-text (new text%)])
|
||||
|
||||
(when copy-constructor
|
||||
(send (send copy-constructor get-input) copy-self-to input-text))
|
||||
|
||||
(field [io (new vertical-alignment% (parent this))]
|
||||
[input (new horizontal-alignment% (parent io))])
|
||||
(new embedded-message% (label " > ") (parent input))
|
||||
(new snip-wrapper%
|
||||
(snip (new stretchable-editor-snip%
|
||||
(editor input-text)
|
||||
(stretchable-height false)
|
||||
(with-border? false)
|
||||
(min-width 100)))
|
||||
(parent input))
|
||||
(new embedded-text-button%
|
||||
(parent input)
|
||||
(label "Ctrl + Enter")
|
||||
(callback (lambda (b e) (make-new))))
|
||||
|
||||
(field [output (new vertical-alignment% (parent io) (show? false))])
|
||||
(new snip-wrapper%
|
||||
(snip (new stretchable-editor-snip%
|
||||
(editor output-text)
|
||||
(stretchable-height false)
|
||||
(with-border? false)))
|
||||
(parent output))
|
||||
))
|
||||
|
||||
#;((is-a? interaction%) . -> . (is-a?/c text%))
|
||||
;; A text that is a program editor and also has keybindings that move around the
|
||||
;; interactions from the given interaction
|
||||
(define (interaction-text interaction)
|
||||
(class scheme:text%
|
||||
|
||||
#;((is-a?/c interaction%) . -> . void?)
|
||||
;; Send the mouse cursor to the given interaction's input field
|
||||
;; NOTE: This function not considered harmful.
|
||||
(define (goto inter)
|
||||
(when (is-a? inter interaction%)
|
||||
(let ([text (send inter get-input)])
|
||||
(send text set-caret-owner false 'global))))
|
||||
|
||||
(field [movement-keymap (make-object keymap%)])
|
||||
|
||||
(send* movement-keymap
|
||||
(add-function "goto-next-interaction"
|
||||
(lambda (ignored event)
|
||||
(goto (send interaction next))))
|
||||
(map-function ":c:right" "goto-next-interaction")
|
||||
(add-function "goto-prev-interaction"
|
||||
(lambda (ignored event)
|
||||
(goto (send interaction prev))))
|
||||
(map-function ":c:left" "goto-prev-interaction")
|
||||
(add-function "make-new"
|
||||
(lambda (ignored event)
|
||||
(send interaction make-new)))
|
||||
(map-function ":c:return" "make-new")
|
||||
(add-function "delete"
|
||||
(lambda (ignored event)
|
||||
(let ([next (send interaction next)])
|
||||
(send (send interaction get-parent) delete-child interaction)
|
||||
(goto next))))
|
||||
(map-function ":c:delete" "delete"))
|
||||
|
||||
#;(-> (listof keymap%))
|
||||
;; the list of keymaps associated with this text
|
||||
(define/override (get-keymaps)
|
||||
(cons movement-keymap (super get-keymaps)))
|
||||
|
||||
(super-new)
|
||||
))
|
||||
))
|
||||
|
||||
|
|
@ -1,108 +0,0 @@
|
|||
(module table mzscheme
|
||||
|
||||
(require
|
||||
(lib "class.ss")
|
||||
(lib "embedded-gui.ss" "embedded-gui")
|
||||
(lib "etc.ss")
|
||||
(lib "contract.ss"))
|
||||
|
||||
;; An interface for things that can be items of a table
|
||||
(define table-item<%>
|
||||
(interface ()
|
||||
#;(-> (is-a?/c text%))
|
||||
;; The first text in the item that can be typed into
|
||||
get-first-text
|
||||
|
||||
#;((is-a?/c editor-stream-out%) . -> . void?)
|
||||
;; Writes the interaction to file
|
||||
write
|
||||
|
||||
#;((is-a?/c editor-stream-in%) . -> . void?)
|
||||
;; Reads the interaction from file
|
||||
read-from-file))
|
||||
|
||||
(provide/contract
|
||||
(table ((implementation?/c table-item<%>) . -> . (implementation?/c alignment<%>)))
|
||||
(table-item<%> interface?))
|
||||
|
||||
;; A table for holding element that must be accessed end writen to file
|
||||
(define (table table-item-class%)
|
||||
(class vertical-alignment%
|
||||
(inherit get-pasteboard)
|
||||
(inherit-field head tail)
|
||||
(init [copy-constructor #f])
|
||||
|
||||
;;;;;;;;;;
|
||||
;; Accessors
|
||||
|
||||
#;(-> (is-a?/c example%))
|
||||
;; The first example in the example field
|
||||
(define/public (get-first-child)
|
||||
(send head next))
|
||||
|
||||
#;(((is-a?/c example%) . -> . any?) . -> . (listof any?))
|
||||
;; A list of the results of applying f to each example in the examples field.
|
||||
(define/public (map-children f)
|
||||
(send head map-to-list f))
|
||||
|
||||
#;(((is-a?/c example%) . -> . void?) . -> . void?)
|
||||
;; For eaches over the children
|
||||
(define/public (for-each-child f)
|
||||
(send head for-each f))
|
||||
|
||||
;;;;;;;;;;
|
||||
;; Reading/Writing
|
||||
|
||||
#;((is-a?/c editor-stream-out%) . -> . void?)
|
||||
;; Write the examples to file
|
||||
(define/public (write f)
|
||||
(let ([num-items (length (map-children void))])
|
||||
(send f put num-items)
|
||||
(for-each-child (lambda (c) (send c write f)))))
|
||||
|
||||
#;((is-a?/c editor-stream-in%) . -> . void?)
|
||||
;; Reads the examples field's state in from the stream
|
||||
(define/public (read-from-file f)
|
||||
(send (get-pasteboard) lock-alignment true)
|
||||
;; Delete all examples
|
||||
(send head for-each (lambda (c) (send c show false)))
|
||||
(send head next tail)
|
||||
(send tail prev head)
|
||||
;; Read in all the examples to the file.
|
||||
(let* ([num-examples (box 0)])
|
||||
(send f get num-examples)
|
||||
(let loop ([n (unbox num-examples)])
|
||||
(unless (zero? n)
|
||||
(let ([example (new table-item-class% (parent this))])
|
||||
(send example read-from-file f)
|
||||
(loop (sub1 n))))))
|
||||
(send (get-pasteboard) lock-alignment false))
|
||||
|
||||
;;;;;;;;;;
|
||||
;; Adding
|
||||
|
||||
#;(-> (is-a?/c alignment<%>))
|
||||
;; Adds a new example to the examples field.
|
||||
(define/public add-new
|
||||
(opt-lambda ((after #f))
|
||||
(let ([item (new table-item-class% (parent this) (after after))])
|
||||
(send (send item get-first-text) set-caret-owner false 'global)
|
||||
item)))
|
||||
|
||||
#;((is-a?/c example%) . -> . (is-a?/c example%))
|
||||
;; Adds a new example that is a copy of the given example
|
||||
(define (add-new-copy example-to-copy)
|
||||
(new table-item-class%
|
||||
(parent this)
|
||||
(copy-constructor example-to-copy)))
|
||||
|
||||
;;;;;;;;;;
|
||||
;; Constructor
|
||||
|
||||
(super-new)
|
||||
(when copy-constructor
|
||||
(send (get-pasteboard) lock-alignment true)
|
||||
(send copy-constructor for-each-child add-new-copy)
|
||||
(send (get-pasteboard) lock-alignment false))
|
||||
))
|
||||
)
|
||||
|
|
@ -1,70 +0,0 @@
|
|||
(module tool mzscheme
|
||||
|
||||
(provide tool@)
|
||||
|
||||
(require
|
||||
(lib "class.ss") (lib "contract.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "unit.ss")
|
||||
(lib "string-constant.ss" "string-constants")
|
||||
(lib "tool.ss" "drscheme")
|
||||
"private/example-box.ss"
|
||||
"private/interactions-box.ss"
|
||||
(lib "text-syntax-object.ss" "test-suite" "private"))
|
||||
|
||||
(define-unit extentions@
|
||||
(import drscheme:tool^ example-box^ interactions-box^)
|
||||
(export drscheme:tool-exports^)
|
||||
(define (phase1) (void))
|
||||
(define (phase2) (void))
|
||||
|
||||
(define (frame-mixin %)
|
||||
(class %
|
||||
(inherit get-edit-target-object get-special-menu register-capability-menu-item)
|
||||
|
||||
;; this function is copied from the drscheme/private/unit.ss file
|
||||
(define (has-editor-on-demand menu-item)
|
||||
(let ([edit (get-edit-target-object)])
|
||||
(send menu-item enable (and edit (is-a? edit editor<%>)))))
|
||||
|
||||
(super-new)
|
||||
|
||||
(new menu-item%
|
||||
(label (string-constant profjBoxes-insert-java-examples))
|
||||
(parent (get-special-menu))
|
||||
(callback
|
||||
(lambda (menu event)
|
||||
(let ([box (new example-box%)]
|
||||
[text (get-edit-target-object)])
|
||||
(when text
|
||||
(send text begin-edit-sequence)
|
||||
(send text insert box)
|
||||
(send box take-caret)
|
||||
(send text end-edit-sequence)))))
|
||||
(demand-callback has-editor-on-demand))
|
||||
(register-capability-menu-item 'profj:special:java-examples-box (get-special-menu))
|
||||
|
||||
#;(new menu-item%
|
||||
(label (string-constant profjBoxes-insert-java-interactions))
|
||||
(parent (get-special-menu))
|
||||
(callback
|
||||
(lambda (menu event)
|
||||
(let ([box (new interactions-box%)]
|
||||
[text (get-edit-target-object)])
|
||||
(when text
|
||||
(send text begin-edit-sequence)
|
||||
(send text insert box)
|
||||
(send box take-caret)
|
||||
(send text end-edit-sequence)))))
|
||||
(demand-callback has-editor-on-demand))
|
||||
))
|
||||
|
||||
(drscheme:get/extend:extend-unit-frame frame-mixin)
|
||||
(drscheme:language:register-capability 'profj:special:java-examples-box (flat-contract boolean?) #f))
|
||||
|
||||
(define tool@
|
||||
(compound-unit/infer
|
||||
(import drscheme:tool^)
|
||||
(export drscheme:tool-exports^)
|
||||
(link extentions@ example-box@ interactions-box@ text->syntax-object@)))
|
||||
)
|
||||
Loading…
Reference in New Issue
Block a user