From 5f1c8da8f54c6771b4d2913b9c6ccff8838417b0 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 7 Jan 2007 03:48:22 +0000 Subject: [PATCH] test-suite is no longer maintained, profjBoxes are RIP too svn: r5240 --- collects/profjBoxes/info.ss | 5 - collects/profjBoxes/private/box-helpers.ss | 11 - collects/profjBoxes/private/example-box.ss | 252 ----------------- .../profjBoxes/private/interactions-box.ss | 254 ------------------ collects/profjBoxes/private/table.ss | 108 -------- collects/profjBoxes/tool.ss | 70 ----- 6 files changed, 700 deletions(-) delete mode 100644 collects/profjBoxes/info.ss delete mode 100644 collects/profjBoxes/private/box-helpers.ss delete mode 100644 collects/profjBoxes/private/example-box.ss delete mode 100644 collects/profjBoxes/private/interactions-box.ss delete mode 100644 collects/profjBoxes/private/table.ss delete mode 100644 collects/profjBoxes/tool.ss diff --git a/collects/profjBoxes/info.ss b/collects/profjBoxes/info.ss deleted file mode 100644 index 25558f9a46..0000000000 --- a/collects/profjBoxes/info.ss +++ /dev/null @@ -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 '())) diff --git a/collects/profjBoxes/private/box-helpers.ss b/collects/profjBoxes/private/box-helpers.ss deleted file mode 100644 index fe951fe184..0000000000 --- a/collects/profjBoxes/private/box-helpers.ss +++ /dev/null @@ -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)))) - ) \ No newline at end of file diff --git a/collects/profjBoxes/private/example-box.ss b/collects/profjBoxes/private/example-box.ss deleted file mode 100644 index cd29558aef..0000000000 --- a/collects/profjBoxes/private/example-box.ss +++ /dev/null @@ -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) - )) - )) - diff --git a/collects/profjBoxes/private/interactions-box.ss b/collects/profjBoxes/private/interactions-box.ss deleted file mode 100644 index 1120a395a5..0000000000 --- a/collects/profjBoxes/private/interactions-box.ss +++ /dev/null @@ -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) - )) - )) - diff --git a/collects/profjBoxes/private/table.ss b/collects/profjBoxes/private/table.ss deleted file mode 100644 index 857f6fb3e9..0000000000 --- a/collects/profjBoxes/private/table.ss +++ /dev/null @@ -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)) - )) - ) \ No newline at end of file diff --git a/collects/profjBoxes/tool.ss b/collects/profjBoxes/tool.ss deleted file mode 100644 index a42a5c66fd..0000000000 --- a/collects/profjBoxes/tool.ss +++ /dev/null @@ -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@))) - )