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