suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Ported macro-debugger collection to new unit system

Browse Source 
svn: r5123
This commit is contained in:
Ryan Culpepper 2006-12-14 23:29:57 +00:00
parent 056683743d
commit 201d34d3c7
15 changed files with 153 additions and 178 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/macro-debugger/syntax-browser/browser.ss
View File

@ -1,6 +1,6 @@
(module browser mzscheme (module browser mzscheme
(require (lib "unitsig.ss") (require (lib "unit.ss")
"interfaces.ss" "interfaces.ss"
"frame.ss" "frame.ss"
"implementation.ss") "implementation.ss")
@ -8,12 +8,14 @@
(provide-signature-elements snip^) (provide-signature-elements snip^)
(define browser@ (define browser@
(compound-unit/sig (compound-unit
(import) (import)
(link [PREFS : prefs^ (global-prefs@)] (link [((PREFS : prefs^)) global-prefs@]
[IMPL : implementation^ (implementation@)] [((WIDGET : widget^)) implementation@]
[FRAME : browser^ (frame@ PREFS (IMPL widget))]) [((FRAME : browser^)) frame@ PREFS WIDGET])
(export (open FRAME)))) (export FRAME)))
(define-values/invoke-unit/sig browser^ browser@) (define-values/invoke-unit browser@
(import)
(export browser^))
) )

5
collects/macro-debugger/syntax-browser/frame.ss
View File

@ -1,7 +1,7 @@
(module frame mzscheme (module frame mzscheme
(require (lib "class.ss") (require (lib "class.ss")
(lib "unitsig.ss") (lib "unit.ss")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "framework.ss" "framework") (lib "framework.ss" "framework")
(lib "list.ss") (lib "list.ss")
@ -10,9 +10,10 @@
(provide frame@) (provide frame@)
(define frame@ (define frame@
(unit/sig browser^ (unit
(import prefs^ (import prefs^
widget^) widget^)
(export browser^)
;; browse-syntax : syntax -> void ;; browse-syntax : syntax -> void
(define (browse-syntax stx) (define (browse-syntax stx)

78
collects/macro-debugger/syntax-browser/implementation.ss
View File

@ -1,6 +1,6 @@
(module implementation mzscheme (module implementation mzscheme
(require (lib "unitsig.ss") (require (lib "unit.ss")
"interfaces.ss" "interfaces.ss"
"widget.ss" "widget.ss"
"syntax-snip.ss" "syntax-snip.ss"
@ -19,69 +19,55 @@
;; We create a new unit/sig out of their invocation ;; We create a new unit/sig out of their invocation
(define snip-keymap@ (define snip-keymap@
(compound-unit/sig (compound-unit
(import [MENU : context-menu^] (import [MENU : context-menu^]
[SNIP : snip^]) [SNIP : snip^])
(link [KEYMAP : keymap^ (keymap@ MENU SNIP)] (link [((KEYMAP : keymap^)) keymap@ MENU SNIP]
[SNIP-KEYMAP : keymap^ (snip-keymap-extension@ KEYMAP)]) [((SNIP-KEYMAP : keymap^)) snip-keymap-extension@ KEYMAP])
(export (open SNIP-KEYMAP)))) (export SNIP-KEYMAP)))
(define snip-implementation@ (define snip-implementation@
(compound-unit/sig (compound-unit
(import) (import)
(link [PREFS : prefs^ (prefs@)] (link [((PREFS : prefs^)) prefs@]
[MENU : context-menu^ (context-menu@)] [((MENU : context-menu^)) context-menu@]
[KEYMAP : keymap^ (snip-keymap@ MENU SNIP)] [((KEYMAP : keymap^)) snip-keymap@ MENU SNIP]
[SNIP-CLASS : snipclass^ (snipclass@ SNIP)] [((SNIP-CLASS : snipclass^)) snipclass@ SNIP]
[SNIP : snip^ (snip@ PREFS KEYMAP MENU SNIP-CLASS)]) [((SNIP : snip^)) snip@ PREFS KEYMAP MENU SNIP-CLASS])
(export (open PREFS) (open SNIP) (open SNIP-CLASS)))) (export PREFS SNIP SNIP-CLASS)))
(define-values/invoke-unit/sig ((open snip^) (open prefs^) (open snipclass^)) (define-values/invoke-unit snip-implementation@
snip-implementation@) (import)
(export snip^ prefs^ snipclass^))
(define global-prefs@ (define global-prefs@ (unit-from-context prefs^))
(unit/sig prefs^
(import)
(rename (-width pref:width)
(-height pref:height)
(-props-percentage pref:props-percentage))
(define -width pref:width)
(define -height pref:height)
(define -props-percentage pref:props-percentage)))
(define global-snip@ (define global-snip@ (unit-from-context snip^))
(unit/sig snip^
(import)
(rename (-syntax-snip syntax-snip)
(-syntax-snip% syntax-snip%))
(define -syntax-snip syntax-snip)
(define -syntax-snip% syntax-snip%)))
;; Everyone else re-uses the global-snip@ unit ;; Everyone else re-uses the global-snip@ unit
(define widget-keymap@ (define widget-keymap@
(compound-unit/sig (compound-unit
(import [MENU : context-menu^] (import [MENU : context-menu^]
[SNIP : snip^]) [SNIP : snip^])
(link [KEYMAP : keymap^ (keymap@ MENU SNIP)] (link [((KEYMAP : keymap^)) keymap@ MENU SNIP]
[WKEYMAP : keymap^ (widget-keymap-extension@ KEYMAP)]) [((WKEYMAP : keymap^)) widget-keymap-extension@ KEYMAP])
(export (open WKEYMAP)))) (export WKEYMAP)))
(define widget-context-menu@ (define widget-context-menu@
(compound-unit/sig (compound-unit
(import) (import)
(link [MENU : context-menu^ (context-menu@)] (link [((MENU : context-menu^)) context-menu@]
[WMENU : context-menu^ (widget-context-menu-extension@ MENU)]) [((WMENU : context-menu^)) widget-context-menu-extension@ MENU])
(export (open WMENU)))) (export WMENU)))
;; implementation@ : implementation^ ;; implementation@ : snip^ widget^
(define implementation@ (define implementation@
(compound-unit/sig (compound-unit
(import) (import)
(link [SNIP : snip^ (global-snip@)] (link [((SNIP : snip^)) global-snip@]
[MENU : context-menu^ (widget-context-menu@)] [((MENU : context-menu^)) widget-context-menu@]
[KEYMAP : keymap^ (widget-keymap@ MENU SNIP)] [((KEYMAP : keymap^)) widget-keymap@ MENU SNIP]
[WIDGET : widget^ (widget@ KEYMAP)]) [((WIDGET : widget^)) widget@ KEYMAP])
(export (unit SNIP snip) (export SNIP WIDGET)))
(unit WIDGET widget))))
) )

6
collects/macro-debugger/syntax-browser/interfaces.ss
View File

@ -1,7 +1,7 @@
(module interfaces mzscheme (module interfaces mzscheme
(require (lib "class.ss") (require (lib "class.ss")
(lib "unitsig.ss")) (lib "unit.ss"))
(provide (all-defined)) (provide (all-defined))
;; Signatures ;; Signatures
@ -55,10 +55,6 @@
(;; syntax-widget% (;; syntax-widget%
syntax-widget%)) syntax-widget%))
(define-signature implementation^
([unit widget : widget^]
[unit snip : snip^]))
;; Class Interfaces ;; Class Interfaces
;; syntax-controller<%> ;; syntax-controller<%>

8
collects/macro-debugger/syntax-browser/keymap.ss
View File

@ -1,7 +1,7 @@
(module keymap mzscheme (module keymap mzscheme
(require (lib "class.ss") (require (lib "class.ss")
(lib "unitsig.ss") (lib "unit.ss")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
"interfaces.ss" "interfaces.ss"
"partition.ss") "partition.ss")
@ -9,8 +9,9 @@
context-menu@) context-menu@)
(define context-menu@ (define context-menu@
(unit/sig context-menu^ (unit
(import) (import)
(export context-menu^)
(define context-menu% (define context-menu%
(class popup-menu% (class popup-menu%
@ -103,8 +104,9 @@
)))) ))))
(define keymap@ (define keymap@
(unit/sig keymap^ (unit
(import context-menu^ snip^) (import context-menu^ snip^)
(export keymap^)
(define syntax-keymap% (define syntax-keymap%
(class keymap% (class keymap%

5
collects/macro-debugger/syntax-browser/prefs.ss
View File

@ -1,6 +1,6 @@
(module prefs mzscheme (module prefs mzscheme
(require (lib "unitsig.ss") (require (lib "unit.ss")
(lib "framework.ss" "framework") (lib "framework.ss" "framework")
"interfaces.ss") "interfaces.ss")
(provide prefs@) (provide prefs@)
@ -14,8 +14,9 @@
[(newval) (preferences:set 'prop newval)]))])) [(newval) (preferences:set 'prop newval)]))]))
(define prefs@ (define prefs@
(unit/sig prefs^ (unit
(import) (import)
(export prefs^)
(preferences:set-default 'SyntaxBrowser:Width 700 number?) (preferences:set-default 'SyntaxBrowser:Width 700 number?)
(preferences:set-default 'SyntaxBrowser:Height 600 number?) (preferences:set-default 'SyntaxBrowser:Height 600 number?)

8
collects/macro-debugger/syntax-browser/snipclass.ss
View File

@ -1,7 +1,7 @@
(module snipclass mzscheme (module snipclass mzscheme
(require (lib "class.ss") (require (lib "class.ss")
(lib "unitsig.ss") (lib "unit.ss")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "match.ss") (lib "match.ss")
(lib "string.ss") (lib "string.ss")
@ -10,8 +10,10 @@
(provide snipclass@) (provide snipclass@)
(define snipclass@ (define snipclass@
(unit/sig snipclass^ (unit
(import snip^) (import snip^)
(export snipclass^)
;; COPIED AND MODIFIED from mrlib/syntax-browser.ss ;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
(define syntax-snipclass% (define syntax-snipclass%
(class snip-class% (class snip-class%
@ -61,7 +63,7 @@
[else stx])) [else stx]))
(define (unmarshall-object obj) (define (unmarshall-object obj)
(let ([unknown (λ () (string->symbol (format "unknown: ~s" obj)))]) (let ([unknown (lambda () (string->symbol (format "unknown: ~s" obj)))])
(if (and (pair? obj) (if (and (pair? obj)
(symbol? (car obj))) (symbol? (car obj)))
(case (car obj) (case (car obj)

27
collects/macro-debugger/syntax-browser/syntax-snip.ss
View File

@ -1,7 +1,7 @@
(module syntax-snip mzscheme (module syntax-snip mzscheme
(require (lib "class.ss") (require (lib "class.ss")
(lib "unitsig.ss") (lib "unit.ss")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "framework.ss" "framework") (lib "framework.ss" "framework")
"interfaces.ss" "interfaces.ss"
@ -12,11 +12,12 @@
snip-keymap-extension@) snip-keymap-extension@)
(define snip@ (define snip@
(unit/sig snip^ (unit
(import prefs^ (import prefs^
keymap^ keymap^
context-menu^ context-menu^
snipclass^) snipclass^)
(export snip^)
;; syntax-snip : syntax -> snip ;; syntax-snip : syntax -> snip
(define (syntax-snip stx) (define (syntax-snip stx)
@ -201,8 +202,9 @@
)) ))
(define snip-keymap-extension@ (define snip-keymap-extension@
(unit/sig keymap^ (unit
(import (pre : keymap^)) (import (prefix pre: keymap^))
(export keymap^)
(define syntax-keymap% (define syntax-keymap%
(class pre:syntax-keymap% (class pre:syntax-keymap%
@ -214,23 +216,6 @@
(lambda (i e) (lambda (i e)
(send snip show-props))))))) (send snip show-props)))))))
#;
(define snip-context-menu-extension@
(unit/sig context-menu^
(import (pre : context-menu^))
(define context-menu%
(class pre:context-menu%
(init-field snip)
(define/override (after-selection-items)
(super after-selection-items)
(new menu-item% (label "Show syntax properties")
(parent this)
(callback (lambda _ (send snip show-props))))
(void))
(super-new (controller (send snip get-controller)))))))
(define style:normal (make-object style-delta% 'change-normal)) (define style:normal (make-object style-delta% 'change-normal))

15
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -1,7 +1,7 @@
(module widget mzscheme (module widget mzscheme
(require (lib "class.ss") (require (lib "class.ss")
(lib "unitsig.ss") (lib "unit.ss")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "framework.ss" "framework") (lib "framework.ss" "framework")
(lib "list.ss") (lib "list.ss")
@ -17,8 +17,9 @@
widget-context-menu-extension@) widget-context-menu-extension@)
(define widget@ (define widget@
(unit/sig widget^ (unit
(import keymap^) (import keymap^)
(export widget^)
;; syntax-widget% ;; syntax-widget%
;; A syntax-widget creates its own syntax-controller. ;; A syntax-widget creates its own syntax-controller.
@ -140,8 +141,9 @@
)) ))
(define widget-keymap-extension@ (define widget-keymap-extension@
(unit/sig keymap^ (unit
(import (pre : keymap^)) (import (prefix pre: keymap^))
(export keymap^)
(define syntax-keymap% (define syntax-keymap%
(class pre:syntax-keymap% (class pre:syntax-keymap%
@ -157,8 +159,9 @@
)))) ))))
(define widget-context-menu-extension@ (define widget-context-menu-extension@
(unit/sig context-menu^ (unit
(import (pre : context-menu^)) (import (prefix pre: context-menu^))
(export context-menu^)
(define context-menu% (define context-menu%
(class pre:context-menu% (class pre:context-menu%

28
collects/macro-debugger/tool.ss
View File

@ -3,10 +3,6 @@
(require (lib "class.ss") (require (lib "class.ss")
(lib "list.ss") (lib "list.ss")
(lib "unit.ss") (lib "unit.ss")
(only (lib "unitsig.ss")
unit/sig
compound-unit/sig
define-values/invoke-unit/sig)
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "framework.ss" "framework") (lib "framework.ss" "framework")
(lib "tool.ss" "drscheme") (lib "tool.ss" "drscheme")
@ -19,28 +15,20 @@
(prefix sb: "syntax-browser/embed.ss")) (prefix sb: "syntax-browser/embed.ss"))
(define view-base/tool@ (define view-base/tool@
(unit/sig view:view-base^ (unit
(import) (import)
(export view:view-base^)
(define base-frame% (define base-frame%
(frame:standard-menus-mixin frame:basic%)))) (frame:standard-menus-mixin frame:basic%))))
(define stepper@ (define stepper@
(compound-unit/sig (compound-unit
(import) (import)
(link [BASE : view:view-base^ (view-base/tool@)] (link [((BASE : view:view-base^)) view-base/tool@]
[STEPPER : view:view^ (view:pre-stepper@ BASE)]) [((STEPPER : view:view^)) view:pre-stepper@ BASE])
(export (open STEPPER)))) (export STEPPER)))
#;(define stepper@ (define-values/invoke-unit stepper@ (import) (export view:view^))
(compound-unit/sig
(import)
(link (PREFS : view:prefs^ (view:prefs@))
(SB : sb:implementation^ (sb:implementation@))
(BASE : view:view-base^ (view-base/tool@))
(VIEW : view:view^ (view:view@ PREFS BASE SB)))
(export (open VIEW))))
(define-values/invoke-unit/sig view:view^ stepper@)
(provide tool@) (provide tool@)

18
collects/macro-debugger/view/browse-deriv.ss
View File

@ -2,7 +2,7 @@
(module browse-deriv mzscheme (module browse-deriv mzscheme
(require (lib "class.ss") (require (lib "class.ss")
(lib "plt-match.ss") (lib "plt-match.ss")
(lib "unitsig.ss") (lib "unit.ss")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "framework.ss" "framework") (lib "framework.ss" "framework")
(lib "hierlist.ss" "hierlist")) (lib "hierlist.ss" "hierlist"))
@ -25,8 +25,9 @@
)) ))
(define deriv@ (define deriv@
(unit/sig node^ (unit
(import) (import)
(export node^)
;; Node = (union Derivation Transformation) ;; Node = (union Derivation Transformation)
@ -76,8 +77,9 @@
)) ))
(define browser@ (define browser@
(unit/sig browser^ (unit
(import node^) (import node^)
(export browser^)
(define callback-hierlist% (define callback-hierlist%
(class hierarchical-list% (class hierarchical-list%
@ -131,11 +133,11 @@
(define app@ (define app@
(compound-unit/sig (compound-unit
(import) (import)
(link [NODE : node^ (deriv@)] (link [((NODE node^)) deriv@]
[BROWSER : browser^ (browser@ NODE)]) [((BROWSER browser^)) browser@ NODE])
(export (open BROWSER)))) (export BROWSER)))
(define-values/invoke-unit/sig browser^ app@) (define-values/invoke-unit app@ (export browser^))
) )

66
collects/macro-debugger/view/gui.ss
View File

@ -1,7 +1,7 @@
(module gui mzscheme (module gui mzscheme
(require (lib "class.ss") (require (lib "class.ss")
(lib "unitsig.ss") (lib "unit.ss")
(lib "list.ss") (lib "list.ss")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "framework.ss" "framework") (lib "framework.ss" "framework")
@ -32,10 +32,11 @@
;; Macro Stepper ;; Macro Stepper
(define view@ (define view@
(unit/sig view^ (unit
(import prefs^ (import prefs^
view-base^ view-base^
(sb : sb:widget^)) (prefix sb: sb:widget^))
(export view^)
(define macro-stepper-config% (define macro-stepper-config%
(class object% (class object%
@ -592,8 +593,9 @@
;; Extensions ;; Extensions
(define keymap-extension@ (define keymap-extension@
(unit/sig sb:keymap^ (unit
(import (pre : sb:keymap^)) (import (prefix pre: sb:keymap^))
(export sb:keymap^)
(define syntax-keymap% (define syntax-keymap%
(class pre:syntax-keymap% (class pre:syntax-keymap%
@ -619,8 +621,9 @@
(refresh)))))))) (refresh))))))))
(define context-menu-extension@ (define context-menu-extension@
(unit/sig sb:context-menu^ (unit
(import (pre : sb:context-menu^)) (import (prefix pre: sb:context-menu^))
(export sb:context-menu^)
(define context-menu% (define context-menu%
(class pre:context-menu% (class pre:context-menu%
@ -658,9 +661,10 @@
(super-new))))) (super-new)))))
(define browser-extension@ (define browser-extension@
(unit/sig sb:widget^ (unit
(import (pre : sb:widget^) (import (prefix pre: sb:widget^)
sb:keymap^) sb:keymap^)
(export sb:widget^)
(define syntax-widget% (define syntax-widget%
(class pre:syntax-widget% (class pre:syntax-widget%
@ -676,37 +680,35 @@
;; Linking ;; Linking
(define context-menu@ (define context-menu@
(compound-unit/sig (compound-unit
(import) (import)
(link [SB:MENU : sb:context-menu^ (sb:widget-context-menu@)] (link [((SB:MENU : sb:context-menu^)) sb:widget-context-menu@]
[V:MENU : sb:context-menu^ (context-menu-extension@ SB:MENU)]) [((V:MENU : sb:context-menu^)) context-menu-extension@ SB:MENU])
(export (open V:MENU)))) (export V:MENU)))
(define keymap@ (define keymap@
(compound-unit/sig (compound-unit
(import [MENU : sb:context-menu^] (import [MENU : sb:context-menu^]
[SNIP : sb:snip^]) [SNIP : sb:snip^])
(link [SB:KEYMAP : sb:keymap^ (sb:widget-keymap@ MENU SNIP)] (link [((SB:KEYMAP : sb:keymap^)) sb:widget-keymap@ MENU SNIP]
[V:KEYMAP : sb:keymap^ (keymap-extension@ SB:KEYMAP)]) [((V:KEYMAP : sb:keymap^)) keymap-extension@ SB:KEYMAP])
(export (open V:KEYMAP)))) (export V:KEYMAP)))
(define widget@ (define widget@
(compound-unit/sig (compound-unit
(import [KEYMAP : sb:keymap^] (import [KEYMAP : sb:keymap^])
[MENU : sb:context-menu^]) (link [((SB:WIDGET : sb:widget^)) sb:widget@ KEYMAP]
(link [SB:WIDGET : sb:widget^ (sb:widget@ KEYMAP)] [((V:WIDGET : sb:widget^)) browser-extension@ SB:WIDGET KEYMAP])
[V:WIDGET : sb:widget^ (browser-extension@ SB:WIDGET KEYMAP)]) (export V:WIDGET)))
(export (open V:WIDGET))))
(define pre-stepper@ (define pre-stepper@
(compound-unit/sig (compound-unit
(import [BASE : view-base^]) (import [BASE : view-base^])
(link [PREFS : prefs^ (prefs@)] (link [((PREFS : prefs^)) prefs@]
[MENU : sb:context-menu^ (context-menu@)] [((MENU : sb:context-menu^)) context-menu@]
[KEYMAP : sb:keymap^ (keymap@ MENU SNIP)] [((KEYMAP : sb:keymap^)) keymap@ MENU SNIP]
[SNIP : sb:snip^ (sb:global-snip@)] [((SNIP : sb:snip^)) sb:global-snip@]
[WIDGET : sb:widget^ (widget@ KEYMAP MENU)] [((WIDGET : sb:widget^)) widget@ KEYMAP]
[VIEW : view^ (view@ PREFS BASE WIDGET)]) [((VIEW : view^)) view@ PREFS BASE WIDGET])
(export (open VIEW)))) (export VIEW)))
) )

2
collects/macro-debugger/view/interfaces.ss
View File

@ -1,6 +1,6 @@
(module interfaces mzscheme (module interfaces mzscheme
(require (lib "unitsig.ss")) (require (lib "unit.ss"))
(provide (all-defined)) (provide (all-defined))
;; Signatures ;; Signatures

5
collects/macro-debugger/view/prefs.ss
View File

@ -1,6 +1,6 @@
(module prefs mzscheme (module prefs mzscheme
(require (lib "unitsig.ss") (require (lib "unit.ss")
(lib "framework.ss" "framework") (lib "framework.ss" "framework")
"interfaces.ss") "interfaces.ss")
(provide prefs@) (provide prefs@)
@ -14,8 +14,9 @@
[(newval) (preferences:set 'prop newval)]))])) [(newval) (preferences:set 'prop newval)]))]))
(define prefs@ (define prefs@
(unit/sig prefs^ (unit
(import) (import)
(export prefs^)
(preferences:set-default 'MacroStepper:Frame:Width 700 number?) (preferences:set-default 'MacroStepper:Frame:Width 700 number?)
(preferences:set-default 'MacroStepper:Frame:Height 600 number?) (preferences:set-default 'MacroStepper:Frame:Height 600 number?)

18
collects/macro-debugger/view/view.ss
View File

@ -1,6 +1,6 @@
(module view mzscheme (module view mzscheme
(require (lib "unitsig.ss") (require (lib "unit.ss")
(lib "mred.ss" "mred") (lib "mred.ss" "mred")
(lib "framework.ss" "framework") (lib "framework.ss" "framework")
"interfaces.ss" "interfaces.ss"
@ -8,15 +8,19 @@
(provide (all-defined)) (provide (all-defined))
(define view-base@ (define view-base@
(unit/sig view-base^ (unit
(import) (import)
(export view-base^)
(define base-frame% (define base-frame%
(frame:standard-menus-mixin (frame:basic-mixin frame%))))) (frame:standard-menus-mixin (frame:basic-mixin frame%)))))
(define-values/invoke-unit/sig view^ (define-values/invoke-unit
(compound-unit/sig (compound-unit
(import) (import)
(link [BASE : view-base^ (view-base@)] (link [((BASE : view-base^)) view-base@]
[STEPPER : view^ (pre-stepper@ BASE)]) [((STEPPER : view^)) pre-stepper@ BASE])
(export (open STEPPER)))) (export STEPPER))
(import)
(export view^))
) )