From 3f74e662ed510b5e1bb4f91ec017322605688418 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Wed, 15 Dec 2010 08:17:57 +0100 Subject: [PATCH] Add tool.rkt needed for "Disable Signature Check". I'd screwed up previously. --- collects/deinprogramm/signature/info.rkt | 5 +- collects/deinprogramm/signature/tool.rkt | 127 +++++++++++++++++++++++ 2 files changed, 129 insertions(+), 3 deletions(-) create mode 100644 collects/deinprogramm/signature/tool.rkt diff --git a/collects/deinprogramm/signature/info.rkt b/collects/deinprogramm/signature/info.rkt index eaf11d7499..3c0c483d9f 100644 --- a/collects/deinprogramm/signature/info.rkt +++ b/collects/deinprogramm/signature/info.rkt @@ -2,6 +2,5 @@ (define name "DeinProgramm - Signatures") -;; Disable until "too.rkt" is added (or otherwise fixed) -;(define drracket-tools '("tool.rkt")) -;(define drracket-tool-names '("Signatures")) +(define drracket-tools '("tool.rkt")) +(define drracket-tool-names '("Signatures")) diff --git a/collects/deinprogramm/signature/tool.rkt b/collects/deinprogramm/signature/tool.rkt new file mode 100644 index 0000000000..8db8ac2eda --- /dev/null +++ b/collects/deinprogramm/signature/tool.rkt @@ -0,0 +1,127 @@ +#lang racket/base + +(require racket/file racket/class racket/unit racket/contract + drracket/tool + mred framework + string-constants) +(provide tool@) + +(define tool@ + (unit (import drracket:tool^) (export drracket:tool-exports^) + + (define (phase1) (void)) + (define (phase2) (void)) + + (define (signatures-frame-mixin %) + (class* % () + (inherit get-current-tab) + + (inherit register-capability-menu-item get-language-menu) + + (define/private (signatures-menu-init) + (let ([language-menu (get-language-menu)] + [enable-label (string-constant signature-enable-checks)] + [disable-label (string-constant signature-disable-checks)]) + + (make-object separator-menu-item% language-menu) + (register-capability-menu-item 'signatures:signatures-menu language-menu) + (letrec ([enable-menu-item% + (class menu:can-restore-menu-item% + (define enabled? #t) + (define/public (is-signature-checking-enabled?) enabled?) + (define/public (set-signature-checking-enabled?! e) (set! enabled? e)) + (inherit set-label) + (define/public (enable-signature-checking) + (unless enabled? + (set! enabled? #t) + (set-label disable-label) + (put-preferences '(signatures:enable-checking?) '(#t)))) + (define/public (disable-signature-checking) + (when enabled? + (set! enabled? #f) + (set-label enable-label) + (put-preferences '(signatures:enable-checking?) '(#f)))) + (super-instantiate ()))] + [enable? (get-preference 'signatures:enable-checking? (lambda () #t))] + [enable-menu-item (make-object enable-menu-item% + (if enable? disable-label enable-label) + language-menu + (lambda (_1 _2) + (if (send _1 is-signature-checking-enabled?) + (send _1 disable-signature-checking) + (send _1 enable-signature-checking))) #f)]) + + (send enable-menu-item set-signature-checking-enabled?! enable?) + (register-capability-menu-item 'signatures:signatures-menu language-menu)))) + + (unless (drracket:language:capability-registered? 'signatures:signatures-menu) + (drracket:language:register-capability 'signatures:signatures-menu (flat-contract boolean?) #f)) + (super-instantiate ()) + (signatures-menu-init) + )) + + (drracket:get/extend:extend-unit-frame signatures-frame-mixin) + ))#lang racket/base + +(require racket/file racket/class racket/unit racket/contract + drracket/tool + mred framework + string-constants) +(provide tool@) + +(define tool@ + (unit (import drracket:tool^) (export drracket:tool-exports^) + + (define (phase1) (void)) + (define (phase2) (void)) + + (define (signatures-frame-mixin %) + (class* % () + (inherit get-current-tab) + + (inherit register-capability-menu-item get-language-menu) + + (define/private (signatures-menu-init) + (let ([language-menu (get-language-menu)] + [enable-label (string-constant signature-enable-checks)] + [disable-label (string-constant signature-disable-checks)]) + + (make-object separator-menu-item% language-menu) + (register-capability-menu-item 'signatures:signatures-menu language-menu) + (letrec ([enable-menu-item% + (class menu:can-restore-menu-item% + (define enabled? #t) + (define/public (is-signature-checking-enabled?) enabled?) + (define/public (set-signature-checking-enabled?! e) (set! enabled? e)) + (inherit set-label) + (define/public (enable-signature-checking) + (unless enabled? + (set! enabled? #t) + (set-label disable-label) + (put-preferences '(signatures:enable-checking?) '(#t)))) + (define/public (disable-signature-checking) + (when enabled? + (set! enabled? #f) + (set-label enable-label) + (put-preferences '(signatures:enable-checking?) '(#f)))) + (super-instantiate ()))] + [enable? (get-preference 'signatures:enable-checking? (lambda () #t))] + [enable-menu-item (make-object enable-menu-item% + (if enable? disable-label enable-label) + language-menu + (lambda (_1 _2) + (if (send _1 is-signature-checking-enabled?) + (send _1 disable-signature-checking) + (send _1 enable-signature-checking))) #f)]) + + (send enable-menu-item set-signature-checking-enabled?! enable?) + (register-capability-menu-item 'signatures:signatures-menu language-menu)))) + + (unless (drracket:language:capability-registered? 'signatures:signatures-menu) + (drracket:language:register-capability 'signatures:signatures-menu (flat-contract boolean?) #f)) + (super-instantiate ()) + (signatures-menu-init) + )) + + (drracket:get/extend:extend-unit-frame signatures-frame-mixin) + ))