infrastrure for capabilities added (and added first capabilities)

svn: r3119

collects/algol60/info.ss

@@ -3,3 +3,4 @@
   (define doc.txt "doc.txt")
   (define tools '(("tool.ss")))
   (define tool-names '("Algol 60")))
+

collects/algol60/tool.ss

@@ -49,6 +49,7 @@
 
       (define lang%
         (class* object% (drscheme:language:language<%>)
+          (define/public (capability-value s) (drscheme:language:get-capability-default s))
           (define/public (first-opened) (void))
           (define/public (config-panel parent)
             (case-lambda

collects/drscheme/private/drsig.ss

@@ -227,6 +227,11 @@
      
      add-snip-value
 
+     register-capability
+     capability-registered?
+     get-capability-default
+     get-capability-contract
+     
      language<%>
      module-based-language<%>
      simple-module-based-language<%>

collects/drscheme/private/language.ss

@@ -53,6 +53,8 @@
           render-value/format
           render-value
           
+          capability-value
+          
           create-executable
           
           get-language-position
@@ -504,6 +506,9 @@
 	  (inherit get-module get-transformer-module use-namespace-require/copy?
                    get-init-code use-mred-launcher get-reader)
           
+          (define/pubment (capability-value s) 
+            (inner (get-capability-default s) capability-value))
+          
           (define/public (first-opened) (void))
           (define/public (get-comment-character) (values ";  " #\;))
           (define/public (order-manuals x) (values x #t))
@@ -1018,7 +1023,22 @@
         (ormap (λ (to-snip) ((to-snip-predicate? to-snip) v)) to-snips))
       
       
-
+      (define capabilities '())
+      (define (capability-registered? x) (and (assoc x capabilities) #t))
+      (define (register-capability name contract default)
+        (when (capability-registered? name)
+          (error 'register-capability "already registered capability ~s" name))
+        (set! capabilities (cons (list name default contract) capabilities)))
+      (define (get-capability-default name)
+        (let ([l (assoc name capabilities)])
+          (unless l
+            (error 'get-capability-default "name not bound ~s" name))
+          (cadr l)))
+      (define (get-capability-contract name)
+        (let ([l (assoc name capabilities)])
+          (unless l
+            (error 'get-capability-contract "name not bound ~s" name))
+          (caddr l)))
         
                                              ;                        
                 ;                                                     

collects/drscheme/private/main.ss

@@ -3,6 +3,7 @@
   (require (lib "string-constant.ss" "string-constants")
            (lib "unitsig.ss")
            (lib "cmdline.ss")
+           (lib "contract.ss")
            "drsig.ss"
 	   (lib "mred.ss" "mred")
            (lib "framework.ss" "framework")
@@ -243,6 +244,10 @@
       (drscheme:debug:add-prefs-panel)
       (install-help-browser-preference-panel)
       
+      (drscheme:language:register-capability 'drscheme:define-popup
+                                             (or/c (cons/c string? string?) false/c)
+                                             (cons "(define" "(define ...)"))
+
       (handler:current-create-new-window
        (let ([drscheme-current-create-new-window
 	      (λ (filename)

collects/drscheme/private/rep.ss

@@ -1386,7 +1386,7 @@ TODO
                                click-delta)))
             (unless (is-default-settings? user-language-settings)
               (insert/delta this (string-append " " (string-constant custom)) dark-green-delta))
-            (insert/delta this (format ".~n") welcome-delta)
+            (insert/delta this ".\n" welcome-delta)
             
             (for-each
              (λ (fn)
@@ -1394,7 +1394,7 @@ TODO
                              (string-append (string-constant teachpack) ": ")
                              welcome-delta)
                (insert/delta this fn dark-green-delta)
-               (insert/delta this (format ".~n") welcome-delta))
+               (insert/delta this ".\n" welcome-delta))
              (map path->string 
                   (drscheme:teachpack:teachpack-cache-filenames 
                    user-teachpack-cache)))
@@ -1415,7 +1415,7 @@ TODO
             (insert/delta this (string-append (string-constant welcome-to) " ") welcome-delta)
             (let-values ([(before after)
                           (insert/delta this (string-constant drscheme) click-delta drs-font-delta)])
-              (insert/delta this (format (string-append ", " (string-constant version) " ~a.~n") (version:version))
+              (insert/delta this (format (string-append ", " (string-constant version) " ~a.\n") (version:version))
                             welcome-delta)
               (set-clickback before after 
                              (λ args (drscheme:app:about-drscheme))

collects/drscheme/private/tool-contracts.ss

@@ -898,6 +898,42 @@
    "does not have the details and on the right-hand side shows the manual"
    "ordering for the chosen language. This is used in Help Desk.")
   
+  (drscheme:language:register-capability
+   (->r ([s symbol?]
+         [contract contract?]
+         [default contract])
+        void?)
+   (s contract default)
+   "Registers a new capability with a default value for each language"
+   "and a contract on the values the capability might have."
+   ""
+   "By default, these capabilities are registered as DrScheme starts up:"
+   "\\begin{itemize}"
+   "\\item \\scheme|(drscheme:language:register-capability 'drscheme:define-popup (or/c (cons/c string? string?) false/c) (cons \"(define\" \"(define ...)\"))|"
+   " --- specifies the prefix that the define popup should look for and what label it should have,"
+   "or \\scheme|#f| if it should not appear at all."
+   "\\item \\scheme|(drscheme:language:register-capability 'drscheme:special:insert-fraction (flat-contract boolean?) #t)|"
+   " --- determines if the insert fraction menu item in the special menu is visible"
+   "\\item \\scheme|(drscheme:language:register-capability 'drscheme:special:insert-lambda (flat-contract boolean?) #t)|"
+   " --- determines if the insert lambda menu item in the special menu is visible"
+   "\\item \\scheme|(drscheme:language:register-capability 'drscheme:special:insert-large-letters (flat-contract boolean?) #t)|"
+   " --- determines if the insert large letters menu item in the special menu is visible"
+   "\\item \\scheme|()|"
+   "\\item \\scheme|()|"
+   "\\end{itemize}")
+  (drscheme:language:capability-registered? 
+   (-> symbol? boolean?)
+   (s)
+   "Indicates if"
+   "@flink drscheme:langauge:register-capability"
+   "has been called with \\var{s}.")
+  (drscheme:language:get-capability-default
+   (->d (and/c symbol? drscheme:language:capability-registered?)
+        (λ (s) (drscheme:language:get-capability-contract s)))
+   (s)
+   "Returns the default for a particular capability.")
+     
+
 ;                                                           
 ;                                                           
 ;                                                           
@@ -1345,6 +1381,11 @@
                            (or/c number? (symbols 'infinity))
                            . -> .
                            any))
-     (unmarshall-settings (printable/c . -> . any)))
+     (unmarshall-settings (printable/c . -> . any))
+     (capability-value 
+      (->d (and/c symbol? drscheme:language:capability-registered?)
+           (λ (cap-name) (drscheme:language:get-capability-contract cap-name))))
+     
+     )
     #;
     (is-a?/c drscheme:language:language<%>)))

collects/drscheme/private/unit.ss

@@ -11,7 +11,8 @@ module browser threading seems wrong.
 |#
 
 (module unit mzscheme
-  (require (lib "unitsig.ss")
+  (require (lib "contract.ss")
+           (lib "unitsig.ss")
 	   (lib "class.ss")
            (lib "file.ss")
            (lib "etc.ss")
@@ -602,19 +603,29 @@ module browser threading seems wrong.
         (keymap:add-to-right-button-menu
          (λ (menu editor event)
            (when (is-a? editor text%)
+             (let* ([canvas (send editor get-canvas)]
+                    [frame (and canvas (send canvas get-frame))])
+               (unless (is-a? frame -frame<%>)
+                 (let* ([tab (send frame get-current-tab)]
+                        [language-settings (send (send tab get-definitions-text) get-next-settings)]
+                        [new-language (drscheme:language-configuration:language-settings-language language-settings)]
+                        [capability-info (send new-language capability-value 'drscheme:define-popup)])
+                   (when capability-info
                      (let* ([current-pos (get-pos editor event)]
                             [current-word (and current-pos (get-current-word editor current-pos))]
                             [defn (and current-word
                                        (ormap (λ (defn) (and (string=? current-word (defn-name defn))
                                                              defn))
-                                      (get-definitions #f editor)))])
+                                              (get-definitions (car capability-info)
+                                                               #f
+                                                               editor)))])
                        (when defn
                          (new separator-menu-item% (parent menu))
                          (new menu-item%
                               (parent menu)
                               (label (format (string-constant jump-to-defn) (defn-name defn)))
                               (callback (λ (x y)
-                               (send editor set-position (defn-start-pos defn))))))))
+                                          (send editor set-position (defn-start-pos defn))))))))))))
            (old menu editor event))))
 
       ;; get-current-word : editor number -> string
@@ -649,9 +660,23 @@ module browser threading seems wrong.
                                    (string-constant sort-by-position) 
                                    (string-constant sort-by-name))))
           
+          (define capability-info (drscheme:language:get-capability-default 'drscheme:define-popup))
+          
+          (inherit set-message set-hidden?)
+          (define/public (language-changed new-language)
+            (set! capability-info (send new-language capability-value 'drscheme:define-popup))
+            (cond
+              [capability-info
+               (set-message #f (cdr capability-info))
+               (set-hidden? #f)]
+              [else
+               (set-hidden? #t)]))
           (define/override (fill-popup menu reset)
+            (when capability-info
               (let* ([text (send frame get-definitions-text)]
-                   [unsorted-defns (get-definitions (not sort-by-name?) text)]
+                     [unsorted-defns (get-definitions (car capability-info)
+                                                      (not sort-by-name?)
+                                                      text)]
                      [defns (if sort-by-name?
                                 (sort
                                  unsorted-defns
@@ -693,16 +718,15 @@ module browser threading seems wrong.
                                         (send canvas focus)))))])
                           (when checked?
                             (send item check #t))
-                        (loop (cdr defns))))))))
+                          (loop (cdr defns)))))))))
           
           (super-new (label "(define ...)"))))
 
       ;; defn = (make-defn number string number number)
       (define-struct defn (indent name start-pos end-pos))
-      (define tag-string "(define")
 
       ;; get-definitions : boolean text -> (listof defn)
-      (define (get-definitions indent? text)
+      (define (get-definitions tag-string indent? text)
         (let* ([min-indent 0]
                [defs (let loop ([pos 0])
                        (let ([defn-pos (send text find-string tag-string 'forward pos 'eof #t #f)])
@@ -1262,6 +1286,13 @@ module browser threading seems wrong.
                   (set! save-init-shown? mod?))
               (update-tab-label current-tab)))
 
+          ;; update-define-popup : -> void
+          ;; brings the (define ...) popup in sync with the main drscheme window
+          (define/public (update-define-popup)
+            (let ([settings (send definitions-text get-next-settings)])
+              (send func-defs-canvas language-changed 
+                    (drscheme:language-configuration:language-settings-language settings))))
+          
           ;; update-save-message : -> void
           ;; sets the save message. If input is #f, uses the frame's
           ;; title.
@@ -1455,10 +1486,9 @@ module browser threading seems wrong.
                           (close-current-tab)))))
             (super file-menu:between-close-and-quit file-menu))
           
-          [define/override file-menu:save-string (λ () (string-constant save-definitions))]
+          (define/override (file-menu:save-string) (string-constant save-definitions))
-          [define/override file-menu:save-as-string (λ () (string-constant save-definitions-as))]
+          (define/override (file-menu:save-as-string) (string-constant save-definitions-as))
-          [define/override file-menu:between-save-as-and-print
+          (define/override (file-menu:between-save-as-and-print file-menu)
-            (λ (file-menu)
             (let ([sub-menu (make-object menu% (string-constant save-other) file-menu)])
               (make-object menu:can-restore-menu-item%
                 (string-constant save-definitions-as-text)
@@ -1495,7 +1525,7 @@ module browser threading seems wrong.
                         (if logging
                             (stop-logging)
                             (start-logging)))))
-                (make-object separator-menu-item% file-menu)))]
+              (make-object separator-menu-item% file-menu)))
           
           [define/override file-menu:print-string (λ () (string-constant print-definitions))]
           (define/override (file-menu:between-print-and-close file-menu)
@@ -2068,6 +2098,7 @@ module browser threading seems wrong.
               (restore-visible-tab-regions)
               (update-save-message)
               (update-save-button)
+              (update-define-popup)
               
               (send definitions-text update-frame-filename)
               (send definitions-text set-delegate old-delegate)
@@ -2512,10 +2543,60 @@ module browser threading seems wrong.
 ;                                            
 ;                                            
 
+          ;; capability-menu-items : hash-table[menu -o> (listof (list menu-item number key)))
+          (define capability-menu-items (make-hash-table))
+          (define/public (register-capability-menu-item key menu)
+            (let ([items (send menu get-items)])
+              (when (null? items)
+                (error 'register-capability-menu-item "menu ~e has no items" menu))
+              (drscheme:language:register-capability key (flat-contract boolean?) #t)
+              (let* ([menu-item (car (last-pair items))]
+                     [this-one (list menu-item (length items) key)]
+                     [old-ones (hash-table-get capability-menu-items menu (λ () '()))])
+                (hash-table-put! capability-menu-items menu (cons this-one old-ones)))))
+          
+          (define/private (update-items/capability menu)
+            (let ([new-items (get-items/capability menu)])
+              (for-each (λ (i) (send i delete)) (send menu get-items))
+              (for-each (λ (i) (send i restore)) new-items)))
+          (define/private (get-items/capability menu)
+            (let loop ([capability-items 
+                        (reverse
+                         (hash-table-get capability-menu-items menu (λ () '())))]
+                       [all-items (send menu get-items)]
+                       [i 0])
+              (cond
+                [(null? capability-items) all-items]
+                [else
+                 (let* ([cap-item-list (car capability-items)]
+                        [cap-item (list-ref cap-item-list 0)]
+                        [cap-num (list-ref cap-item-list 1)]
+                        [cap-key (list-ref cap-item-list 2)])
+                   (cond
+                     [(= cap-num i)
+                      (let ([is-on? (get-current-capability-value cap-key)])
+                        (cond
+                          [is-on?
+                           (if (eq? (car all-items) cap-item)
+                               (cons cap-item (loop (cdr capability-items) (cdr all-items) (+ i 1)))
+                               (cons cap-item (loop (cdr capability-items) all-items (+ i 1))))]
+                          [else
+                           (if (eq? (car all-items) cap-item)
+                               (loop (cdr capability-items) (cdr all-items) (+ i 1))
+                               (loop (cdr capability-items) all-items (+ i 1)))]))]
+                     [else (cons (car all-items)
+                                 (loop capability-items
+                                       (cdr all-items)
+                                       (+ i 1)))]))])))
+          
+          (define/private (get-current-capability-value key)
+            (let* ([language-settings (send (get-definitions-text) get-next-settings)]
+                   [new-language (drscheme:language-configuration:language-settings-language language-settings)])
+              (send new-language capability-value key)))
+          
           (define special-menu 'special-menu-not-yet-init)
           (define/public (get-special-menu) special-menu)
 
-          
           (define/private (initialize-menus)
             (let* ([mb (get-menu-bar)]
                    [language-menu-on-demand
@@ -2532,7 +2613,10 @@ module browser threading seems wrong.
                       (λ (_1 _2)
                         (let ([text (get-focus-object)])
                           (when (is-a? text scheme:text<%>)
-                            (method text)))))])
+                            (method text)))))]
+                   [show/hide-capability-menus
+                    (λ ()
+                      (for-each (λ (menu) (update-items/capability menu)) (send (get-menu-bar) get-items)))])
               
               (make-object menu:can-restore-menu-item%
                 (string-constant choose-language-menu-item-label)
@@ -2544,6 +2628,7 @@ module browser threading seems wrong.
                                        this)])
                     (when new-settings
                       (send definitions-text set-next-settings new-settings)
+                      (update-define-popup)
                       (preferences:set
                        drscheme:language-configuration:settings-preferences-symbol
                        new-settings))))
@@ -2649,7 +2734,13 @@ module browser threading seems wrong.
                           [else (send text uncomment-selection)]))))))
             
               (set! special-menu
-                    (make-object (get-menu%) (string-constant special-menu) mb))
+                    (new (get-menu%)
+                         [label (string-constant special-menu)]
+                         [parent mb]
+                         [demand-callback
+                          (λ (special-menu)
+                            ;; just here for convience -- it actually works on all menus, not just the special menu
+                            (show/hide-capability-menus))]))
 
               (let ([has-editor-on-demand
                      (λ (menu-item)
@@ -2783,17 +2874,22 @@ module browser threading seems wrong.
                   special-menu callback 
                   #f #f
                   has-editor-on-demand)
+                (register-capability-menu-item 'drscheme:special:insert-fraction special-menu)
+                
                 (make-object c% (string-constant insert-large-letters...)
                   special-menu
                   (λ (x y) (insert-large-semicolon-letters))
                   #f #f
                   has-editor-on-demand)
+                (register-capability-menu-item 'drscheme:special:insert-large-letters special-menu)
+                
                 (make-object c% (string-constant insert-lambda)
                   special-menu
                   (λ (x y) (insert-lambda))
                   #\\
                   #f
-                  has-editor-on-demand))
+                  has-editor-on-demand)
+                (register-capability-menu-item 'drscheme:special:insert-lambda special-menu))
 
               (make-object separator-menu-item% (get-show-menu))
               
@@ -2981,6 +3077,7 @@ module browser threading seems wrong.
 
 	  (update-save-message)
           (update-save-button)
+          (update-define-popup)
           
 	  (cond
             [filename

collects/framework/private/scheme.ss

@@ -1263,7 +1263,7 @@
                                      (ormap
                                       (λ (x)
                                         (text-between-equal? x text backward-match before-whitespace-pos))
-                                      '("cond" "provide/contract")))
+                                      '("cond" "field" "provide/contract")))
                           (change-to #\())]))]
                   [(not (zero? before-whitespace-pos))
                    ;; this is the first thing in the sequence

collects/mrlib/name-message.ss

@@ -38,6 +38,12 @@
                stretchable-width stretchable-height
                get-top-level-window refresh)
       
+      (define hidden? #f)
+      (define/public (set-hidden? d?) 
+        (unless (eq? hidden? d?)
+          (set! hidden? d?)
+          (refresh)))
+      
       (define paths #f)
       
       ;; label : string
@@ -87,6 +93,7 @@
 	      (send i enable #f))))
 	
       (define/override (on-event evt)
+	(unless hidden?
           (let-values ([(max-x max-y) (get-size)])
             (let ([inside? (and (not (send evt leaving?))
                                 (<= 0 (send evt get-x) max-x)
@@ -118,7 +125,7 @@
                  ;; Popup menu
                  (popup-menu menu
                              0
-			  height)))]))
+                             height)))])))
 
       (define paint-sema #f)
       
@@ -134,8 +141,18 @@
 	  (semaphore-post paint-sema))
         (let ([dc (get-dc)])
           (let-values ([(w h) (get-client-size)])
+            (cond
+              [hidden? 
+               (let ([pen (send dc get-pen)]
+                     [brush (send dc get-brush)])
+                 (send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel))
+                 (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
+                 (send dc draw-rectangle 0 0 w h)
+                 (send dc set-pen pen)
+                 (send dc set-brush brush))]
+              [else
                (when (and (> w 5) (> h 5))
-              (draw-button-label dc label 0 0 w h mouse-over? mouse-grabbed?)))))
+                 (draw-button-label dc label 0 0 w h mouse-over? mouse-grabbed?))]))))
       
       (super-new [style '(transparent)])
       (update-min-sizes)

collects/profj/tool.ss

@@ -149,6 +149,12 @@
       (define (java-lang-mixin level name number one-line dyn?)
         (when dyn? (dynamic? #t))
         (class* object% (drscheme:language:language<%>)
+          (define/public (capability-value s) 
+            (cond
+              [(regexp-match #rx"^drscheme:special:" (format "~a" s)) #f]
+              [(memq s '(slideshow:special-menu drscheme:define-popup)) #f]
+              [else
+               (drscheme:language:get-capability-default s)]))
           (define/public (first-opened) (void))
           
           (define/public (order-manuals x)

collects/slideshow/tool.ss

@@ -621,8 +621,9 @@ pict snip :
           
           (super-new)
           
-          (inherit get-special-menu)
+          (inherit get-special-menu #;register-capability-menu-item)
-          (add-special-menu-item (get-special-menu) this)))
+          (add-special-menu-item (get-special-menu) this)
+          #;(register-capability-menu-item 'slideshow:special-menu (get-special-menu))))
       
       (define slideshow-dragable%
         (class panel:horizontal-dragable%