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

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

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

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

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

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

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

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

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

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

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

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

@ -1,6 +1,6 @@
(module prefs mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "framework.ss" "framework")
"interfaces.ss")
(provide prefs@)
@ -14,8 +14,9 @@
[(newval) (preferences:set 'prop newval)]))]))
(define prefs@
(unit/sig prefs^
(unit
(import)
(export prefs^)
(preferences:set-default 'SyntaxBrowser:Width 700 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
(require (lib "class.ss")
(lib "unitsig.ss")
(lib "unit.ss")
(lib "mred.ss" "mred")
(lib "match.ss")
(lib "string.ss")
@ -10,8 +10,10 @@
(provide snipclass@)
(define snipclass@
(unit/sig snipclass^
(unit
(import snip^)
(export snipclass^)
;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
(define syntax-snipclass%
(class snip-class%
@ -61,7 +63,7 @@
[else stx]))
(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)
(symbol? (car obj)))
(case (car obj)

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

@ -1,7 +1,7 @@
(module syntax-snip mzscheme
(require (lib "class.ss")
(lib "unitsig.ss")
(lib "unit.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
"interfaces.ss"
@ -12,12 +12,13 @@
snip-keymap-extension@)
(define snip@
(unit/sig snip^
(unit
(import prefs^
keymap^
context-menu^
snipclass^)
(export snip^)
;; syntax-snip : syntax -> snip
(define (syntax-snip stx)
(new syntax-snip% (syntax stx)))
@ -201,9 +202,10 @@
))
(define snip-keymap-extension@
(unit/sig keymap^
(import (pre : keymap^))
(unit
(import (prefix pre: keymap^))
(export keymap^)
(define syntax-keymap%
(class pre:syntax-keymap%
(init-field snip)
@ -214,23 +216,6 @@
(lambda (i e)
(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))

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

@ -1,7 +1,7 @@
(module widget mzscheme
(require (lib "class.ss")
(lib "unitsig.ss")
(lib "unit.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "list.ss")
@ -17,9 +17,10 @@
widget-context-menu-extension@)
(define widget@
(unit/sig widget^
(unit
(import keymap^)
(export widget^)
;; syntax-widget%
;; A syntax-widget creates its own syntax-controller.
(define syntax-widget%
@ -140,9 +141,10 @@
))
(define widget-keymap-extension@
(unit/sig keymap^
(import (pre : keymap^))
(unit
(import (prefix pre: keymap^))
(export keymap^)
(define syntax-keymap%
(class pre:syntax-keymap%
(init-field widget)
@ -157,14 +159,15 @@
))))
(define widget-context-menu-extension@
(unit/sig context-menu^
(import (pre : context-menu^))
(unit
(import (prefix pre: context-menu^))
(export context-menu^)
(define context-menu%
(class pre:context-menu%
(inherit-field keymap)
(inherit-field props-menu)
(define/override (on-demand)
(send props-menu set-label
(if (send (send keymap get-widget) props-shown?)

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

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

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

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

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

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

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

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

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

@ -1,6 +1,6 @@
(module prefs mzscheme
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "framework.ss" "framework")
"interfaces.ss")
(provide prefs@)
@ -14,8 +14,9 @@
[(newval) (preferences:set 'prop newval)]))]))
(define prefs@
(unit/sig prefs^
(unit
(import)
(export prefs^)
(preferences:set-default 'MacroStepper:Frame:Width 700 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
(require (lib "unitsig.ss")
(require (lib "unit.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
"interfaces.ss"
@ -8,15 +8,19 @@
(provide (all-defined))
(define view-base@
(unit/sig view-base^
(unit
(import)
(export view-base^)
(define base-frame%
(frame:standard-menus-mixin (frame:basic-mixin frame%)))))
(define-values/invoke-unit/sig view^
(compound-unit/sig
(define-values/invoke-unit
(compound-unit
(import)
(link [BASE : view-base^ (view-base@)]
[STEPPER : view^ (pre-stepper@ BASE)])
(export (open STEPPER))))
(link [((BASE : view-base^)) view-base@]
[((STEPPER : view^)) pre-stepper@ BASE])
(export STEPPER))
(import)
(export view^))
)