diff --git a/collects/framework/collapsed-snipclass.ss b/collects/framework/collapsed-snipclass.ss new file mode 100644 index 00000000..3d8fe25f --- /dev/null +++ b/collects/framework/collapsed-snipclass.ss @@ -0,0 +1,31 @@ +(module collapsed-snipclass mzscheme + (require (lib "mred.ss" "mred") + (lib "class.ss") + "private/collapsed-snipclass-helpers.ss") + + (provide snip-class) + + (define simple-sexp-snip% + (class* snip% (readable-snip<%>) + (init-field left-bracket right-bracket saved-snips) + (define/public (read-one-special index file line col pos) + (let ([text (make-object text%)]) + (for-each + (lambda (s) (send text insert (send s copy) + (send text last-position) + (send text last-position))) + saved-snips) + (values (datum->syntax-object + #f + (read (open-input-text-editor text)) + (list file line col pos 1)) + 1 + #t))) + (super-instantiate ()))) + + (define sexp-snipclass% (make-sexp-snipclass% simple-sexp-snip%)) + + (define snip-class (make-object sexp-snipclass%)) + (send snip-class set-classname (format "~s" '(lib "collapsed-snipclass.ss" "framework"))) + (send snip-class set-version 0) + (send (get-the-snip-class-list) add snip-class)) diff --git a/collects/framework/gui-utils.ss b/collects/framework/gui-utils.ss index d4136fa7..bcd1c426 100644 --- a/collects/framework/gui-utils.ss +++ b/collects/framework/gui-utils.ss @@ -635,7 +635,7 @@ (define unsaved-warning (opt-lambda (filename action-anyway (can-save-now? #f) (parent #f)) - (let* ([result (void)] + (let* ([result 'cancel] [unsaved-dialog% (class dialog% (inherit show center) diff --git a/collects/framework/private/collapsed-snipclass-helpers.ss b/collects/framework/private/collapsed-snipclass-helpers.ss new file mode 100644 index 00000000..49dc3b30 --- /dev/null +++ b/collects/framework/private/collapsed-snipclass-helpers.ss @@ -0,0 +1,27 @@ +(module collapsed-snipclass-helpers mzscheme + (require (lib "mred.ss" "mred") + (lib "class.ss")) + + (provide make-sexp-snipclass%) + + (define (make-sexp-snipclass% sexp-snip%) + (class snip-class% + (define/override (read in) + (let* ([left-bracket (string-ref (send in get-string) 0)] + [right-bracket (string-ref (send in get-string) 0)] + [snip-count (send in get-exact)] + [saved-snips + (let loop ([n snip-count]) + (cond + [(zero? n) null] + [else + (let* ([classname (send in get-string)] + [snipclass (send (get-the-snip-class-list) find classname)]) + (cons (send snipclass read in) + (loop (- n 1))))]))]) + (instantiate sexp-snip% () + (left-bracket left-bracket) + (right-bracket right-bracket) + (saved-snips saved-snips)))) + (super-instantiate ())))) + \ No newline at end of file