Macro stepper:
cleaned up representation of big (localaction) contexts unitized hiding impl added (broken/experimental) navigation tools (jump, zoom) svn: r5468
This commit is contained in:
Ryan Culpepper
parent
c7b622c537
commit
ef1f77c33f
|
|
@ -1,20 +1,24 @@
|
|||
|
||||
(module hide mzscheme
|
||||
(require (lib "plt-match.ss")
|
||||
(lib "unit.ss")
|
||||
(lib "list.ss")
|
||||
"deriv.ss"
|
||||
"deriv-util.ss"
|
||||
"synth-engine.ss"
|
||||
"stx-util.ss"
|
||||
"context.ss")
|
||||
(provide (all-defined))
|
||||
|
||||
#;
|
||||
|
||||
(provide hide/policy
|
||||
hide
|
||||
#;seek/syntax
|
||||
seek/syntax
|
||||
macro-policy
|
||||
current-hiding-warning-handler)
|
||||
current-hiding-warning-handler
|
||||
(struct nonlinearity (message paths))
|
||||
(struct localactions ()))
|
||||
|
||||
(define-signature hide^ (hide))
|
||||
(define-signature seek^ (seek/deriv seek subterm-derivations))
|
||||
(define-signature seek-syntax^ (seek/syntax))
|
||||
|
||||
;; hide/policy : Derivation (identifier -> boolean) -> (values Derivation syntax)
|
||||
(define (hide/policy deriv show-macro?)
|
||||
|
|
@ -87,6 +91,11 @@
|
|||
; -$ @- ++ -@- $@- @+ -
|
||||
; -$ @- ++ +@@+@- -@@@@-
|
||||
|
||||
(define hide@
|
||||
(unit
|
||||
(import seek^)
|
||||
(export hide^)
|
||||
|
||||
;; Macro hiding:
|
||||
;; The derivation is "visible" or "active" by default,
|
||||
;; but pieces of it may need to be hidden.
|
||||
|
|
@ -444,7 +453,7 @@
|
|||
[#f (values #f #f)]))
|
||||
|
||||
(for-deriv deriv))
|
||||
|
||||
))
|
||||
|
||||
; -@@@$ -$
|
||||
; @* - -$
|
||||
|
|
@ -457,28 +466,16 @@
|
|||
; +- +@ @+ - @+ - -$ +@
|
||||
; -@@@@- -@@@@- -@@@@- -$ $+
|
||||
|
||||
(define seek@
|
||||
(unit
|
||||
(import hide^)
|
||||
(export seek^)
|
||||
|
||||
;; Seek:
|
||||
;; The derivation is "inactive" or "hidden" by default,
|
||||
;; but pieces of it can become visible if they correspond to subterms
|
||||
;; of the hidden syntax.
|
||||
|
||||
;; seek/syntax : syntax Derivation -> (union (cons Derivation Derivation) #f)
|
||||
;; Seeks for derivations of *exactly* the given syntax (not a subterm)
|
||||
;; Does track the syntax through renaming, however.
|
||||
;; Returns the whole derivation followed by the subterm derivation.
|
||||
;; If there is no subderivation for that syntax, returns #f.
|
||||
#;
|
||||
(define (seek/syntax stx deriv)
|
||||
(let ([subterms (gather-one-subterm (deriv-e1 deriv) stx)])
|
||||
(parameterize ((subterms-table subterms))
|
||||
(let ([subderivs (subterm-derivations deriv)])
|
||||
(unless (and (pair? subderivs) (null? (cdr subderivs)))
|
||||
(error 'seek/syntax "nonlinear subterm derivations"))
|
||||
(if (pair? subderivs)
|
||||
(values (create-synth-deriv (deriv-e1 deriv) subderivs)
|
||||
(s:subterm-deriv (car subderivs)))
|
||||
#f)))))
|
||||
|
||||
;; seek/deriv : Derivation -> (values Derivation syntax)
|
||||
;; Seeks for derivations of all proper subterms of the derivation's
|
||||
;; initial syntax.
|
||||
|
|
@ -714,6 +711,77 @@
|
|||
|
||||
(for-deriv d))
|
||||
|
||||
))
|
||||
|
||||
(define-values/invoke-unit
|
||||
(compound-unit
|
||||
(import)
|
||||
(export HIDE SEEK)
|
||||
(link [((HIDE : hide^)) hide@ SEEK]
|
||||
[((SEEK : seek^)) seek@ HIDE]))
|
||||
(import)
|
||||
(export hide^ seek^))
|
||||
|
||||
|
||||
(define trivial-hide@
|
||||
(unit
|
||||
(import)
|
||||
(export hide^)
|
||||
|
||||
(define (hide d)
|
||||
(values d (lift/deriv-e2 d)))))
|
||||
|
||||
(define seek-syntax@
|
||||
(unit
|
||||
(import seek^)
|
||||
(export seek-syntax^)
|
||||
|
||||
;; seek/syntax : syntax Derivation -> (listof Derivation)
|
||||
;; Seeks for derivations of *exactly* the given syntax (not a subterm)
|
||||
;; Does track the syntax through renaming, however.
|
||||
(define (seek/syntax stx deriv)
|
||||
(let ([subterms (gather-one-subterm (deriv-e1 deriv) stx)])
|
||||
(parameterize ((subterms-table subterms))
|
||||
(let ([subderivs (subterm-derivations deriv)])
|
||||
(map s:subterm-deriv (filter s:subterm? subderivs))))))))
|
||||
|
||||
(define-values/invoke-unit
|
||||
(compound-unit
|
||||
(import)
|
||||
(export SEEK-SYNTAX)
|
||||
(link [((HIDE : hide^)) trivial-hide@]
|
||||
[((SEEK : seek^)) seek@ HIDE]
|
||||
[((SEEK-SYNTAX : seek-syntax^)) seek-syntax@ SEEK]))
|
||||
(import)
|
||||
(export seek-syntax^))
|
||||
|
||||
|
||||
; +###+
|
||||
; +@@ +@@: @+
|
||||
; @+ @+ @+
|
||||
; @+ @+ @+
|
||||
; @+ @+ +###+ @+ :@@ +@+ +###+ :@$$ +@# -+###+:
|
||||
; @+ @+ +#: #+ @+ +@+**@+ +#: #+ :+@++*@ #+ ++
|
||||
; @@###@+ #+ +# @+ +@: +# #+ +# +@: + @+ ::
|
||||
; @+ @+ @@###@# @+ +@ +@ @@###@# +@ +@#++
|
||||
; @+ @+ @+ @+ +@ +@ @+ +@ ++#@+
|
||||
; @+ @+ #+ @+ +@ ++ #+ +@ + +@
|
||||
; @+ @+ :@+- :+ @+ +@- +@* :@+- :+ +@ @: ++
|
||||
; +@# +@#- :+@@#+ +##@@## +@$$#+ :+@@#+ :#@@##+ +#@##+
|
||||
; +@
|
||||
; +@
|
||||
; :###+
|
||||
|
||||
;; show-macro? : identifier -> boolean
|
||||
(define (show-macro? id)
|
||||
((macro-policy) id))
|
||||
|
||||
;; show-mrule? : MRule -> boolean
|
||||
(define (show-transformation? tx)
|
||||
(match tx
|
||||
[(AnyQ transformation (e1 e2 rs me1 me2 locals _seq))
|
||||
(ormap show-macro? rs)]))
|
||||
|
||||
|
||||
;; check-nonlinear-subterms : (list-of Subterm) -> void
|
||||
;; FIXME: No checking on renamings... need to add
|
||||
|
|
@ -827,34 +895,6 @@
|
|||
(loop stx0 null)
|
||||
table))
|
||||
|
||||
|
||||
|
||||
; +###+
|
||||
; +@@ +@@: @+
|
||||
; @+ @+ @+
|
||||
; @+ @+ @+
|
||||
; @+ @+ +###+ @+ :@@ +@+ +###+ :@$$ +@# -+###+:
|
||||
; @+ @+ +#: #+ @+ +@+**@+ +#: #+ :+@++*@ #+ ++
|
||||
; @@###@+ #+ +# @+ +@: +# #+ +# +@: + @+ ::
|
||||
; @+ @+ @@###@# @+ +@ +@ @@###@# +@ +@#++
|
||||
; @+ @+ @+ @+ +@ +@ @+ +@ ++#@+
|
||||
; @+ @+ #+ @+ +@ ++ #+ +@ + +@
|
||||
; @+ @+ :@+- :+ @+ +@- +@* :@+- :+ +@ @: ++
|
||||
; +@# +@#- :+@@#+ +##@@## +@$$#+ :+@@#+ :#@@##+ +#@##+
|
||||
; +@
|
||||
; +@
|
||||
; :###+
|
||||
|
||||
;; show-macro? : identifier -> boolean
|
||||
(define (show-macro? id)
|
||||
((macro-policy) id))
|
||||
|
||||
;; show-mrule? : MRule -> boolean
|
||||
(define (show-transformation? tx)
|
||||
(match tx
|
||||
[(AnyQ transformation (e1 e2 rs me1 me2 locals _seq))
|
||||
(ormap show-macro? rs)]))
|
||||
|
||||
(define (map/2values f items)
|
||||
(if (null? items)
|
||||
(values null null)
|
||||
|
|
|
|||
|
|
@ -44,15 +44,13 @@
|
|||
(syntax-rules ()
|
||||
[(with-new-local-context e . body)
|
||||
(parameterize ([big-context
|
||||
(cons (cons (current-derivation)
|
||||
(cons (list e)
|
||||
(context)))
|
||||
(cons (make-bigframe (current-derivation) (context) (list e) e)
|
||||
(big-context))]
|
||||
[context null])
|
||||
. body)]))
|
||||
|
||||
|
||||
;; -----------------------------------
|
||||
|
||||
|
||||
;; CC
|
||||
;; the context constructor
|
||||
(define-syntax (CC stx)
|
||||
|
|
@ -66,7 +64,7 @@
|
|||
(syntax-rules ()
|
||||
[(R form pattern . clauses)
|
||||
(R** #f _ [#:set-syntax form] [#:pattern pattern] . clauses)]))
|
||||
|
||||
|
||||
(define-syntax (R** stx)
|
||||
(syntax-case stx (! @ List Block =>)
|
||||
[(R** form-var pattern)
|
||||
|
|
|
|||
|
|
@ -5,13 +5,14 @@
|
|||
;; A ReductionSequence is a (list-of Reduction)
|
||||
|
||||
;; A ProtoStep is (make-protostep Derivation BigContext StepType Context)
|
||||
|
||||
|
||||
;; A Context is a list of Frames
|
||||
;; A Frame is (syntax -> syntax)
|
||||
|
||||
;; A BigContext is (list-of (cons Derivation (cons Syntaxes Syntax)))
|
||||
;; local expansion contexts: deriv, foci, term
|
||||
|
||||
;; A BigContext is (list-of BigFrame)
|
||||
;; A BigFrame is (make-bigframe Derivation Context Syntaxes Syntax)
|
||||
(define-struct bigframe (deriv ctx foci e))
|
||||
|
||||
;; A Reduction is one of
|
||||
;; - (make-step ... Syntaxes Syntaxes Syntax Syntax)
|
||||
;; - (make-misstep ... Syntax Syntax Exception)
|
||||
|
|
@ -36,6 +37,9 @@
|
|||
(define (misstep-term1 s)
|
||||
(context-fill (protostep-ctx s) (misstep-e1 s)))
|
||||
|
||||
(define (bigframe-term bf)
|
||||
(context-fill (bigframe-ctx bf) (bigframe-e bf)))
|
||||
|
||||
;; A StepType is a simple in the following alist.
|
||||
|
||||
(define step-type-meanings
|
||||
|
|
|
|||
|
|
@ -326,11 +326,11 @@
|
|||
(define nav:down
|
||||
(new button% (label "Next term") (parent navigator) (style '(deleted))
|
||||
(callback (lambda (b e) (navigate-down)))))
|
||||
#;
|
||||
|
||||
(define nav:zoom
|
||||
(new button% (label "Zoom in") (parent extra-navigator)
|
||||
(callback (lambda (b e) (zoom)))))
|
||||
#;
|
||||
|
||||
(define nav:jump-to
|
||||
(new button% (label "Jump to") (parent extra-navigator)
|
||||
(callback (lambda (b e) (jump-to)))))
|
||||
|
|
@ -378,14 +378,13 @@
|
|||
(refresh/move/cached-prefix))
|
||||
|
||||
;; FIXME: selected stx must be in term1; doesn't work in term2
|
||||
#;
|
||||
(define/private (zoom)
|
||||
(let* ([selected-syntax (send sbc get-selected-syntax)]
|
||||
[step (and steps (cursor:current steps))]
|
||||
[deriv (and step (protostep-deriv step))])
|
||||
(when (and selected-syntax deriv)
|
||||
(for-each go/deriv (seek/syntax selected-syntax deriv)))))
|
||||
#;
|
||||
|
||||
(define/public (jump-to)
|
||||
(let* ([selected-syntax (send sbc get-selected-syntax)]
|
||||
[step (and steps (cursor:current steps))]
|
||||
|
|
@ -400,7 +399,7 @@
|
|||
[else
|
||||
(message-box "Macro stepper - Jump to"
|
||||
"Subterm occurs non-linearly in the expansion")])))))
|
||||
#;
|
||||
|
||||
(define/private (jump-to/deriv subderiv)
|
||||
(define all-step-derivs
|
||||
(let ([ht (make-hash-table)])
|
||||
|
|
@ -408,6 +407,8 @@
|
|||
(cursor-suffix->list steps))
|
||||
ht))
|
||||
(define target-deriv
|
||||
subderiv
|
||||
#;
|
||||
(find-deriv
|
||||
(lambda (d) (hash-table-get all-step-derivs d (lambda () #f)))
|
||||
(lambda (d) #f)
|
||||
|
|
@ -475,10 +476,10 @@
|
|||
|
||||
(define/private (update:show-lctx lctx)
|
||||
(when (pair? lctx)
|
||||
(for-each (lambda (bc)
|
||||
(for-each (lambda (bf)
|
||||
(send sbview add-text
|
||||
"While executing macro transformer in:\n")
|
||||
(insert-syntax/redex (cddr bc) (cadr bc)))
|
||||
(insert-syntax/redex (bigframe-term bf) (bigframe-foci bf)))
|
||||
lctx)
|
||||
(send sbview add-text "\n")))
|
||||
|
||||
|
|
@ -491,7 +492,7 @@
|
|||
(define/private (update:separator/small step)
|
||||
(insert-step-separator/small
|
||||
(step-type->string (protostep-type step))))
|
||||
|
||||
|
||||
(define/private (update:show-step step)
|
||||
(update:show-protostep step)
|
||||
(insert-syntax/redex (step-term1 step) (step-foci1 step))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user