sync Ryan's macro-debugger changes
svn: r9166 original commit: 5165d9e8559eda1245acee8296c81613c3770c7a
This commit is contained in:
Matthew Flatt
parent
d81ac1a5e9
commit
b5e5c83b91
|
|
@ -20,5 +20,5 @@
|
|||
(let-values ([(result deriv) (trace/result stx)])
|
||||
(when (exn? result)
|
||||
(raise result))
|
||||
(let-values ([(_d estx) (hide/policy deriv show?)])
|
||||
(let-values ([(_d estx) (hide*/policy deriv show?)])
|
||||
estx)))
|
||||
|
|
|
|||
|
|
@ -7,9 +7,11 @@
|
|||
"deriv-util.ss"
|
||||
"deriv-find.ss"
|
||||
"hide.ss"
|
||||
"seek.ss"
|
||||
"hiding-policies.ss"
|
||||
"deriv.ss"
|
||||
"steps.ss")
|
||||
"steps.ss"
|
||||
"synth-derivs.ss")
|
||||
|
||||
(provide (all-from-out "trace.ss")
|
||||
(all-from-out "reductions.ss")
|
||||
|
|
@ -18,5 +20,7 @@
|
|||
(all-from-out "deriv-find.ss")
|
||||
(all-from-out "hiding-policies.ss")
|
||||
(all-from-out "hide.ss")
|
||||
(all-from-out "seek.ss")
|
||||
(all-from-out "steps.ss")
|
||||
(all-from-out "synth-derivs.ss")
|
||||
(all-from-out scheme/match))
|
||||
|
|
|
|||
|
|
@ -16,6 +16,7 @@
|
|||
(define-struct (deriv node) () #:transparent)
|
||||
(define-struct (lift-deriv deriv) (first lift-stx second) #:transparent)
|
||||
(define-struct (mrule deriv) (transformation next) #:transparent)
|
||||
(define-struct (tagrule deriv) (tagged-stx next) #:transparent)
|
||||
|
||||
;; A DerivLL is one of
|
||||
;; (make-lift/let-deriv <Node(Stx)> Deriv Stx Deriv)
|
||||
|
|
@ -24,7 +25,7 @@
|
|||
|
||||
;; A Transformation is
|
||||
;; (make-transformation <Node(Stx)> Rs ?exn ?Stx (list-of LocalAction) ?exn ?Stx Number)
|
||||
(define-struct (transformation node) (resolves ?1 me1 locals ?2 me2 seq) #:transparent)
|
||||
(define-struct (transformation node) (resolves ?1 me1 locals me2 ?2 seq) #:transparent)
|
||||
|
||||
;; A LocalAction is one of
|
||||
;; (make-local-expansion <Node(Stx)> Stx ?Stx Boolean Deriv)
|
||||
|
|
@ -32,11 +33,11 @@
|
|||
;; (make-local-lift Stx Identifier)
|
||||
;; (make-local-lift-end Stx)
|
||||
;; (make-local-bind BindSyntaxes)
|
||||
(define-struct (local-expansion node) (me1 me2 for-stx? inner) #:transparent)
|
||||
(define-struct (local-expansion/expr node) (me1 me2 for-stx? opaque inner) #:transparent)
|
||||
(define-struct (local-expansion node) (me1 me2 inner for-stx? lifted opaque)
|
||||
#:transparent)
|
||||
(define-struct local-lift (expr id) #:transparent)
|
||||
(define-struct local-lift-end (decl) #:transparent)
|
||||
(define-struct local-bind (bindrhs) #:transparent)
|
||||
(define-struct local-bind (names bindrhs) #:transparent)
|
||||
|
||||
;; Base = << Node(Stx) Rs ?exn >>
|
||||
(define-struct (base deriv) (resolves ?1) #:transparent)
|
||||
|
|
@ -45,10 +46,11 @@
|
|||
(define-struct (prule base) () #:transparent)
|
||||
(define-struct (p:variable prule) () #:transparent)
|
||||
|
||||
;; (make-p:module <Base> Boolean ?Deriv ?exn Deriv)
|
||||
;; (make-p:#%module-begin <Base> ModulePass1 ModulePass2 ?exn)
|
||||
(define-struct (p:module prule) (one-body-form? mb ?2 body) #:transparent)
|
||||
(define-struct (p:#%module-begin prule) (pass1 pass2 ?2) #:transparent)
|
||||
;; (make-p:module <Base> ?exn ?stx stx ?Deriv ?stx ?exn Deriv ?stx)
|
||||
;; (make-p:#%module-begin <Base> Stx ModulePass1 ModulePass2 ?exn)
|
||||
(define-struct (p:module prule) (?2 tag rename check tag2 ?3 body shift)
|
||||
#:transparent)
|
||||
(define-struct (p:#%module-begin prule) (me pass1 pass2 ?2) #:transparent)
|
||||
|
||||
;; (make-p:define-syntaxes <Base> DerivLL)
|
||||
;; (make-p:define-values <Base> Deriv)
|
||||
|
|
@ -61,7 +63,7 @@
|
|||
;; (make-p:set! <Base> Rs Deriv)
|
||||
;; (make-p:set!-macro <Base> Rs Deriv)
|
||||
(define-struct (p:#%expression prule) (inner) #:transparent)
|
||||
(define-struct (p:if prule) (full? test then else) #:transparent)
|
||||
(define-struct (p:if prule) (test then else) #:transparent)
|
||||
(define-struct (p:wcm prule) (key mark body) #:transparent)
|
||||
(define-struct (p:set! prule) (id-resolves rhs) #:transparent)
|
||||
(define-struct (p:set!-macro prule) (deriv) #:transparent)
|
||||
|
|
@ -69,7 +71,7 @@
|
|||
;; (make-p:#%app <Base> Stx LDeriv)
|
||||
;; (make-p:begin <Base> LDeriv)
|
||||
;; (make-p:begin0 <Base> Deriv LDeriv)
|
||||
(define-struct (p:#%app prule) (tagged-stx lderiv) #:transparent)
|
||||
(define-struct (p:#%app prule) (lderiv) #:transparent)
|
||||
(define-struct (p:begin prule) (lderiv) #:transparent)
|
||||
(define-struct (p:begin0 prule) (first lderiv) #:transparent)
|
||||
|
||||
|
|
@ -97,8 +99,8 @@
|
|||
(define-struct (p::STOP prule) () #:transparent)
|
||||
(define-struct (p:stop p::STOP) () #:transparent)
|
||||
(define-struct (p:unknown p::STOP) () #:transparent)
|
||||
(define-struct (p:#%top p::STOP) (tagged-stx) #:transparent)
|
||||
(define-struct (p:#%datum p::STOP) (tagged-stx) #:transparent)
|
||||
(define-struct (p:#%top p::STOP) () #:transparent)
|
||||
(define-struct (p:#%datum p::STOP) () #:transparent)
|
||||
(define-struct (p:quote p::STOP) () #:transparent)
|
||||
(define-struct (p:quote-syntax p::STOP) () #:transparent)
|
||||
(define-struct (p:require p::STOP) () #:transparent)
|
||||
|
|
@ -151,21 +153,21 @@
|
|||
;; A ModPass2 is (list-of ModRule2)
|
||||
|
||||
;; A ModRule1 is one of
|
||||
;; (make-mod:prim Deriv ModPrim)
|
||||
;; (make-mod:splice Deriv ?exn Stxs)
|
||||
;; (make-mod:lift Deriv Stxs)
|
||||
;; (make-mod:prim Deriv Stx ModPrim)
|
||||
;; (make-mod:splice Deriv Stx ?exn Stxs)
|
||||
;; (make-mod:lift Deriv ?Stxs Stxs)
|
||||
;; (make-mod:lift-end Stxs)
|
||||
;; A ModRule2 is one of
|
||||
;; (make-mod:skip)
|
||||
;; (make-mod:cons Deriv)
|
||||
;; (make-mod:lift Deriv Stxs)
|
||||
(define-struct modrule () #:transparent)
|
||||
(define-struct (mod:cons modrule) (head) #:transparent)
|
||||
(define-struct (mod:prim modrule) (head prim) #:transparent)
|
||||
(define-struct (mod:skip modrule) () #:transparent)
|
||||
(define-struct (mod:splice modrule) (head ?1 tail) #:transparent)
|
||||
(define-struct (mod:lift modrule) (head tail) #:transparent)
|
||||
(define-struct (mod:prim modrule) (head rename prim) #:transparent)
|
||||
(define-struct (mod:splice modrule) (head rename ?1 tail) #:transparent)
|
||||
(define-struct (mod:lift modrule) (head renames tail) #:transparent)
|
||||
(define-struct (mod:lift-end modrule) (tail) #:transparent)
|
||||
(define-struct (mod:cons modrule) (head) #:transparent)
|
||||
(define-struct (mod:skip modrule) () #:transparent)
|
||||
|
||||
;; A ModPrim is a PRule in:
|
||||
;; (make-p:define-values <Base> #:transparent)
|
||||
|
|
|
|||
|
|
@ -49,7 +49,8 @@
|
|||
(tokens basic-tokens prim-tokens renames-tokens)
|
||||
(end EOF)
|
||||
(error deriv-error)
|
||||
#;(debug "DEBUG-PARSER.txt"))
|
||||
#;(debug "/Users/ryanc/DEBUG-PARSER.txt")
|
||||
)
|
||||
|
||||
;; tokens
|
||||
(skipped-token-values
|
||||
|
|
@ -60,12 +61,15 @@
|
|||
enter-list exit-list
|
||||
enter-check exit-check
|
||||
local-post exit-local exit-local/expr
|
||||
local-bind enter-bind exit-bind
|
||||
phase-up module-body
|
||||
renames-lambda
|
||||
renames-case-lambda
|
||||
renames-let
|
||||
renames-letrec-syntaxes
|
||||
renames-block
|
||||
rename-one
|
||||
rename-list
|
||||
IMPOSSIBLE)
|
||||
|
||||
;; Entry point
|
||||
|
|
@ -76,42 +80,17 @@
|
|||
|
||||
(productions/I
|
||||
|
||||
;; Expand/Lifts
|
||||
;; Expand with possible lifting
|
||||
(EE/Lifts
|
||||
(#:no-wrap)
|
||||
[((? EE)) $1]
|
||||
[((? EE/Lifts+)) $1])
|
||||
|
||||
(EE/Lifts+
|
||||
(#:no-wrap)
|
||||
[(EE lift-loop (? EE/Lifts))
|
||||
(let ([e1 (wderiv-e1 $1)]
|
||||
[e2 (wderiv-e2 $3)])
|
||||
(make lift-deriv e1 e2 $1 $2 $3))])
|
||||
|
||||
;; Expansion of an expression
|
||||
;; EE Answer = Derivation (I)
|
||||
(EE
|
||||
(#:no-wrap)
|
||||
[(visit (? PrimStep) return)
|
||||
($2 $1 $3)]
|
||||
[((? EE/Macro))
|
||||
$1])
|
||||
|
||||
(EE/Macro
|
||||
(#:wrap)
|
||||
[(visit (? MacroStep) (? EE))
|
||||
(make mrule $1 (and $3 (wderiv-e2 $3)) $2 $3)])
|
||||
|
||||
;; Expand/LetLifts
|
||||
;; Used for expand_lift_to_let (rhs of define-syntaxes, mostly)
|
||||
;; Expand, convert lifts to let (rhs of define-syntaxes, mostly)
|
||||
(EE/LetLifts
|
||||
(#:no-wrap)
|
||||
[((? EE)) $1]
|
||||
[((? EE/LetLifts+)) $1])
|
||||
|
||||
(EE/LetLifts+
|
||||
(#:wrap)
|
||||
[(EE lift/let-loop (? EE/LetLifts))
|
||||
(let ([initial (wderiv-e1 $1)]
|
||||
[final (wderiv-e2 $3)])
|
||||
|
|
@ -120,7 +99,6 @@
|
|||
;; Evaluation
|
||||
;; Answer = ?exn
|
||||
(Eval
|
||||
(#:no-wrap)
|
||||
[() #f]
|
||||
[(!!) $1]
|
||||
[(start EE/Interrupted) (create-eval-exn $2)]
|
||||
|
|
@ -130,116 +108,119 @@
|
|||
|
||||
;; Expansion of an expression to primitive form
|
||||
(CheckImmediateMacro
|
||||
(#:no-wrap)
|
||||
[(enter-check (? CheckImmediateMacro/Inner) exit-check)
|
||||
($2 $1 $3 (lambda (ce1 ce2) (make p:stop ce1 ce2 null #f)))])
|
||||
(CheckImmediateMacro/Inner
|
||||
(#:args e1 e2 k)
|
||||
(#:wrap)
|
||||
[()
|
||||
(k e1 e2)]
|
||||
[(visit (? MacroStep) return (? CheckImmediateMacro/Inner))
|
||||
(let ([next ($4 $3 e2 k)])
|
||||
(make mrule $1 (and next (wderiv-e2 next)) $2 next))])
|
||||
[(visit Resolves (? MacroStep) return (? CheckImmediateMacro/Inner))
|
||||
(let ([next ($5 $4 e2 k)])
|
||||
(make mrule $1 (and next (wderiv-e2 next)) ($3 $2) next))]
|
||||
[(visit Resolves tag (? MacroStep) return (? CheckImmediateMacro/Inner))
|
||||
(let ([next ($6 $5 e2 k)])
|
||||
(let ([mnode (make mrule $1 (and next (wderiv-e2 next)) ($4 $2) next)])
|
||||
(make tagrule $1 (wderiv-e2 mnode) $3 mnode)))])
|
||||
|
||||
;; Expansion of multiple expressions, next-separated
|
||||
(NextEEs
|
||||
(#:no-wrap)
|
||||
(#:skipped null)
|
||||
[() null]
|
||||
[(next (? EE) (? NextEEs)) (cons $2 $3)])
|
||||
|
||||
;; EE
|
||||
|
||||
;; Expand expression (term)
|
||||
(EE
|
||||
[(visit Resolves (? EE/k))
|
||||
($3 $1 $2)]
|
||||
[(visit Resolves tag (? EE/k))
|
||||
(let ([next ($4 $1 $2)])
|
||||
(make tagrule $1 (wderiv-e2 next) $3 next))])
|
||||
|
||||
(EE/k
|
||||
(#:args e1 rs)
|
||||
[((? PrimStep) return)
|
||||
($1 e1 $2 rs)]
|
||||
[((? MacroStep) (? EE))
|
||||
(make mrule e1 (and $2 (wderiv-e2 $2)) ($1 rs) $2)])
|
||||
|
||||
;; Keyword resolution
|
||||
(Resolves
|
||||
(#:no-wrap)
|
||||
[() null]
|
||||
[(resolve Resolves) (cons $1 $2)])
|
||||
|
||||
;; Single macro step (may contain local-expand calls)
|
||||
;; MacroStep Answer = Transformation (I,E)
|
||||
(MacroStep
|
||||
(#:wrap)
|
||||
[(Resolves enter-macro ! macro-pre-transform (? LocalActions)
|
||||
! macro-post-transform exit-macro)
|
||||
(make transformation $2 $8 $1 $3 $4 $5 $6 $7 (new-sequence-number))])
|
||||
(#:args rs)
|
||||
[(enter-macro ! macro-pre-transform (? LocalActions)
|
||||
! macro-post-transform ! exit-macro)
|
||||
(make transformation $1 $8 rs $2 $3 $4 $6 (or $5 $7) (new-sequence-number))])
|
||||
|
||||
;; Local actions taken by macro
|
||||
;; LocalAction Answer = (list-of LocalAction)
|
||||
(LocalActions
|
||||
(#:no-wrap)
|
||||
(#:skipped null)
|
||||
[() null]
|
||||
[((? LocalAction) (? LocalActions)) (cons $1 $2)]
|
||||
[((? NotReallyLocalAction) (? LocalActions)) $2])
|
||||
|
||||
(LocalAction
|
||||
(#:no-wrap)
|
||||
[(enter-local local-pre start (? EE) local-post exit-local)
|
||||
(make local-expansion $1 $6 $2 $5 #f $4)]
|
||||
[(enter-local phase-up local-pre start (? EE) local-post exit-local)
|
||||
(make local-expansion $1 $7 $3 $6 #t $5)]
|
||||
[(enter-local/expr local-pre start (? EE) local-post exit-local/expr)
|
||||
(make local-expansion/expr $1 (car $6) $2 $5 #f (cdr $6) $4)]
|
||||
[(enter-local/expr local-pre phase-up start (? EE) local-post exit-local/expr)
|
||||
(make local-expansion/expr $1 (car $7) $3 $6 #t (cdr $7) $5)]
|
||||
[(enter-local OptPhaseUp
|
||||
local-pre (? LocalExpand/Inner) local-post
|
||||
OptLifted OptOpaqueExpr exit-local)
|
||||
(make local-expansion $1 $8 $3 $5 $4 $2 $6 $7)]
|
||||
[(lift)
|
||||
(make local-lift (cdr $1) (car $1))]
|
||||
[(lift-statement)
|
||||
(make local-lift-end $1)]
|
||||
[((? BindSyntaxes))
|
||||
(make local-bind $1)])
|
||||
[(local-bind (? BindSyntaxes))
|
||||
(make local-bind $1 $2)])
|
||||
|
||||
(LocalExpand/Inner
|
||||
[(start (? EE)) $2]
|
||||
[((? CheckImmediateMacro)) $1])
|
||||
(OptLifted
|
||||
[(lift-loop) $1]
|
||||
[() #f])
|
||||
(OptOpaqueExpr
|
||||
[(opaque) $1]
|
||||
[() #f])
|
||||
(OptPhaseUp
|
||||
[(phase-up) #t]
|
||||
[() #f])
|
||||
|
||||
(NotReallyLocalAction
|
||||
(#:no-wrap)
|
||||
;; called 'expand' (not 'local-expand') within transformer
|
||||
[(start (? EE))
|
||||
(make local-expansion (wderiv-e1 $2)
|
||||
(wderiv-e2 $2)
|
||||
(wderiv-e1 $2)
|
||||
(wderiv-e2 $2)
|
||||
#f
|
||||
$2)])
|
||||
#f])
|
||||
|
||||
;; Primitive
|
||||
(PrimStep
|
||||
(#:args e1 e2)
|
||||
(#:no-wrap)
|
||||
[(Resolves (? PrimError))
|
||||
($2 e1 e2 $1)]
|
||||
[(Resolves Variable)
|
||||
($2 e1 e2 $1)]
|
||||
[(Resolves enter-prim (? Prim) exit-prim)
|
||||
($3 e1 e2 $1)]
|
||||
[(Resolves enter-prim (? TaggedPrim) exit-prim)
|
||||
($3 e1 $4 $1 $2)])
|
||||
|
||||
(PrimError
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(! IMPOSSIBLE)
|
||||
(make p:unknown e1 e2 rs $1)])
|
||||
|
||||
(Variable
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(!!)
|
||||
(make p:unknown e1 e2 rs $1)]
|
||||
[(variable)
|
||||
(make p:variable e1 e2 rs #f)])
|
||||
|
||||
(TaggedPrim
|
||||
(#:args e1 e2 rs tagged-stx)
|
||||
(#:no-wrap)
|
||||
[((? Prim#%App)) ($1 e1 e2 rs tagged-stx)]
|
||||
[((? Prim#%Datum)) ($1 e1 e2 rs tagged-stx)]
|
||||
[((? Prim#%Top)) ($1 e1 e2 rs tagged-stx)])
|
||||
(make p:variable e1 e2 rs #f)]
|
||||
[(enter-prim (? Prim) exit-prim)
|
||||
(begin
|
||||
(unless (eq? $3 e2)
|
||||
(fprintf (current-error-port)
|
||||
"warning: exit-prim and return differ:\n~s\n~s\n"
|
||||
$3 e2))
|
||||
($2 $1 $3 rs))])
|
||||
|
||||
(Prim
|
||||
(#:args e1 e2 rs)
|
||||
(#:no-wrap)
|
||||
[((? PrimModule)) ($1 e1 e2 rs)]
|
||||
[((? Prim#%ModuleBegin)) ($1 e1 e2 rs)]
|
||||
[((? PrimDefineSyntaxes)) ($1 e1 e2 rs)]
|
||||
[((? PrimDefineValues)) ($1 e1 e2 rs)]
|
||||
[((? PrimExpression)) ($1 e1 e2 rs)]
|
||||
[((? Prim#%App)) ($1 e1 e2 rs)]
|
||||
[((? Prim#%Datum)) ($1 e1 e2 rs)]
|
||||
[((? Prim#%Top)) ($1 e1 e2 rs)]
|
||||
[((? PrimIf)) ($1 e1 e2 rs)]
|
||||
[((? PrimWCM)) ($1 e1 e2 rs)]
|
||||
[((? PrimSet)) ($1 e1 e2 rs)]
|
||||
|
|
@ -261,22 +242,24 @@
|
|||
|
||||
(PrimModule
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
;; Multiple forms after language: tagging done automatically
|
||||
[(prim-module (? Eval) (? EE))
|
||||
(make p:module e1 e2 rs $2 #f #f #f $3)]
|
||||
;; One form after language: macro that expands into #%module-begin
|
||||
[(prim-module Eval next (? CheckImmediateMacro) next ! (? EE))
|
||||
(make p:module e1 e2 rs #f #t $4 $6 $7)])
|
||||
[(prim-module ! next (? Eval) OptTag rename-one
|
||||
(? OptCheckImmediateMacro) OptTag !
|
||||
(? EE) rename-one)
|
||||
(make p:module e1 e2 rs $2 $4 $5 $6 $7 $8 $9 $10 $11)])
|
||||
(OptTag
|
||||
[() #f]
|
||||
[(tag) $1])
|
||||
(OptCheckImmediateMacro
|
||||
[() #f]
|
||||
[((? CheckImmediateMacro)) $1])
|
||||
|
||||
(Prim#%ModuleBegin
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(prim-#%module-begin ! (? ModulePass1) next-group (? ModulePass2) !)
|
||||
(make p:#%module-begin e1 e2 rs $2 $3 $5 $6)])
|
||||
[(prim-#%module-begin ! rename-one
|
||||
(? ModulePass1) next-group (? ModulePass2) !)
|
||||
(make p:#%module-begin e1 e2 rs $2 $3 $4 $6 $7)])
|
||||
|
||||
(ModulePass1
|
||||
(#:no-wrap)
|
||||
(#:skipped null)
|
||||
[() null]
|
||||
[(next (? ModulePass1-Part) (? ModulePass1))
|
||||
|
|
@ -285,16 +268,14 @@
|
|||
(cons (make mod:lift-end $1) $2)])
|
||||
|
||||
(ModulePass1-Part
|
||||
(#:wrap)
|
||||
[((? EE) (? ModulePass1/Prim))
|
||||
(make mod:prim $1 $2)]
|
||||
[(EE ! splice)
|
||||
(make mod:splice $1 $2 $3)]
|
||||
[(EE module-lift-loop)
|
||||
(make mod:lift $1 $2)])
|
||||
[((? EE) rename-one (? ModulePass1/Prim))
|
||||
(make mod:prim $1 $2 $3)]
|
||||
[(EE rename-one ! splice)
|
||||
(make mod:splice $1 $2 $3 $4)]
|
||||
[(EE rename-list module-lift-loop)
|
||||
(make mod:lift $1 $2 $3)])
|
||||
|
||||
(ModulePass1/Prim
|
||||
(#:wrap)
|
||||
[(enter-prim prim-define-values ! exit-prim)
|
||||
(make p:define-values $1 $4 null $3 #f)]
|
||||
[(enter-prim prim-define-syntaxes !
|
||||
|
|
@ -306,13 +287,10 @@
|
|||
(make p:require-for-syntax $1 $4 null $3)]
|
||||
[(enter-prim prim-require-for-template (? Eval) exit-prim)
|
||||
(make p:require-for-template $1 $4 null $3)]
|
||||
[(enter-prim prim-provide ! exit-prim)
|
||||
(make p:provide $1 $4 null $3)]
|
||||
[()
|
||||
#f])
|
||||
|
||||
(ModulePass2
|
||||
(#:no-wrap)
|
||||
(#:skipped null)
|
||||
[() null]
|
||||
[(next (? ModulePass2-Part) (? ModulePass2))
|
||||
|
|
@ -321,106 +299,98 @@
|
|||
(cons (make mod:lift-end $1) $2)])
|
||||
|
||||
(ModulePass2-Part
|
||||
(#:no-wrap)
|
||||
;; not normal; already handled
|
||||
[()
|
||||
(make mod:skip)]
|
||||
;; provide: special
|
||||
[(enter-prim prim-provide (? ModuleProvide/Inner) exit-prim)
|
||||
(make mod:cons (make p:provide $1 $4 null $3))]
|
||||
;; normal: expand completely
|
||||
[((? EE))
|
||||
(make mod:cons $1)]
|
||||
;; catch lifts
|
||||
[(EE module-lift-loop)
|
||||
(make mod:lift $1 $2)])
|
||||
(make mod:lift $1 #f $2)])
|
||||
|
||||
(ModuleProvide/Inner
|
||||
[() #f]
|
||||
[(!!) $1]
|
||||
[(EE/Interrupted) $1]
|
||||
[(EE (? ModuleProvide/Inner)) $2])
|
||||
|
||||
;; Definitions
|
||||
(PrimDefineSyntaxes
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(prim-define-syntaxes ! (? EE/LetLifts) (? Eval))
|
||||
(make p:define-syntaxes e1 e2 rs $2 $3 $4)])
|
||||
|
||||
(PrimDefineValues
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(prim-define-values ! (? EE))
|
||||
(make p:define-values e1 e2 rs $2 $3)])
|
||||
|
||||
;; Simple expressions
|
||||
(PrimExpression
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(prim-expression ! (? EE))
|
||||
(make p:#%expression e1 e2 rs $2 $3)])
|
||||
|
||||
(PrimIf
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(prim-if ! (? EE) next (? EE) next (? EE))
|
||||
(make p:if e1 e2 rs $2 #t $3 $5 $7)]
|
||||
[(prim-if next-group (? EE) next (? EE))
|
||||
(make p:if e1 e2 rs #f #f $3 $5 #f)])
|
||||
(make p:if e1 e2 rs $2 $3 $5 $7)])
|
||||
|
||||
(PrimWCM
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(prim-wcm ! (? EE) next (? EE) next (? EE))
|
||||
(make p:wcm e1 e2 rs $2 $3 $5 $7)])
|
||||
|
||||
;; Sequence-containing expressions
|
||||
(PrimBegin
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(prim-begin ! (? EL))
|
||||
(make p:begin e1 e2 rs $2 $3)])
|
||||
|
||||
(PrimBegin0
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(prim-begin0 ! next (? EE) next (? EL))
|
||||
(make p:begin0 e1 e2 rs $2 $4 $6)])
|
||||
|
||||
(Prim#%App
|
||||
(#:args e1 e2 rs tagged-stx)
|
||||
(#:wrap)
|
||||
(#:args e1 e2 rs)
|
||||
[(prim-#%app !)
|
||||
(make p:#%app e1 e2 rs $2 tagged-stx (make lderiv null null #f null))]
|
||||
(make p:#%app e1 e2 rs $2 (make lderiv null null #f null))]
|
||||
[(prim-#%app (? EL))
|
||||
(make p:#%app e1 e2 rs #f tagged-stx $2)])
|
||||
(make p:#%app e1 e2 rs #f $2)])
|
||||
|
||||
;; Binding expressions
|
||||
(PrimLambda
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(prim-lambda ! renames-lambda (? EB))
|
||||
(make p:lambda e1 e2 rs $2 $3 $4)])
|
||||
|
||||
(PrimCaseLambda
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(prim-case-lambda ! (? NextCaseLambdaClauses))
|
||||
(make p:case-lambda e1 e2 rs $2 $3)])
|
||||
|
||||
(NextCaseLambdaClauses
|
||||
(#:skipped null)
|
||||
(#:no-wrap)
|
||||
[(next (? CaseLambdaClause) (? NextCaseLambdaClauses))
|
||||
(cons $2 $3)]
|
||||
[() null])
|
||||
|
||||
(CaseLambdaClause
|
||||
(#:wrap)
|
||||
[(! renames-case-lambda (? EB))
|
||||
(make clc $1 $2 $3)])
|
||||
|
||||
(PrimLetValues
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(prim-let-values ! renames-let (? NextEEs) next-group (? EB))
|
||||
(make p:let-values e1 e2 rs $2 $3 $4 $6)])
|
||||
|
||||
(PrimLet*Values
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
;; let*-values with bindings is "macro-like"
|
||||
[(prim-let*-values !!)
|
||||
(let ([tx (make transformation e1 #f rs $2
|
||||
|
|
@ -429,7 +399,7 @@
|
|||
[(prim-let*-values (? EE))
|
||||
(let* ([next-e1 (wderiv-e1 $2)]
|
||||
[tx (make transformation e1 next-e1 rs #f
|
||||
e1 null #f next-e1 (new-sequence-number))])
|
||||
e1 null next-e1 #f (new-sequence-number))])
|
||||
(make mrule e1 e2 tx $2))]
|
||||
;; No bindings... model as "let"
|
||||
[(prim-let*-values renames-let (? NextEEs) next-group (? EB))
|
||||
|
|
@ -437,13 +407,11 @@
|
|||
|
||||
(PrimLetrecValues
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(prim-letrec-values ! renames-let (? NextEEs) next-group (? EB))
|
||||
(make p:letrec-values e1 e2 rs $2 $3 $4 $6)])
|
||||
|
||||
(PrimLetrecSyntaxes+Values
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(prim-letrec-syntaxes+values ! renames-letrec-syntaxes
|
||||
(? NextBindSyntaxess) next-group (? EB))
|
||||
(make p:letrec-syntaxes+values e1 e2 rs $2 $3 $4 #f null $6)]
|
||||
|
|
@ -455,66 +423,55 @@
|
|||
|
||||
;; Atomic expressions
|
||||
(Prim#%Datum
|
||||
(#:args e1 e2 rs tagged-stx)
|
||||
(#:wrap)
|
||||
[(prim-#%datum !) (make p:#%datum e1 e2 rs $2 tagged-stx)])
|
||||
(#:args e1 e2 rs)
|
||||
[(prim-#%datum !) (make p:#%datum e1 e2 rs $2)])
|
||||
|
||||
(Prim#%Top
|
||||
(#:args e1 e2 rs tagged-stx)
|
||||
(#:wrap)
|
||||
[(prim-#%top !) (make p:#%top e1 e2 rs $2 tagged-stx)])
|
||||
(#:args e1 e2 rs)
|
||||
[(prim-#%top !) (make p:#%top e1 e2 rs $2)])
|
||||
|
||||
(PrimSTOP
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(prim-stop !) (make p:stop e1 e2 rs $2)])
|
||||
|
||||
(PrimQuote
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(prim-quote !) (make p:quote e1 e2 rs $2)])
|
||||
|
||||
(PrimQuoteSyntax
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(prim-quote-syntax !) (make p:quote-syntax e1 e2 rs $2)])
|
||||
|
||||
(PrimRequire
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(prim-require (? Eval))
|
||||
(make p:require e1 e2 rs $2)])
|
||||
|
||||
(PrimRequireForSyntax
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(prim-require-for-syntax (? Eval))
|
||||
(make p:require-for-syntax e1 e2 rs $2)])
|
||||
|
||||
(PrimRequireForTemplate
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(prim-require-for-template (? Eval))
|
||||
(make p:require-for-template e1 e2 rs $2)])
|
||||
|
||||
(PrimProvide
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(prim-provide !) (make p:provide e1 e2 rs $2)])
|
||||
|
||||
(PrimSet
|
||||
(#:args e1 e2 rs)
|
||||
(#:wrap)
|
||||
[(prim-set! ! Resolves next (? EE))
|
||||
(make p:set! e1 e2 rs $2 $3 $5)]
|
||||
[(prim-set! (? MacroStep) (? EE))
|
||||
[(prim-set! Resolves (? MacroStep) (? EE))
|
||||
(make p:set!-macro e1 e2 rs #f
|
||||
(make mrule e1 (and $3 (wderiv-e2 $3)) $2 $3))])
|
||||
(make mrule e1 (and $4 (wderiv-e2 $4)) ($3 $2) $4))])
|
||||
|
||||
;; Blocks
|
||||
;; EB Answer = BlockDerivation
|
||||
(EB
|
||||
(#:wrap)
|
||||
[(enter-block (? BlockPass1) block->list (? EL))
|
||||
(make bderiv $1 (and $4 (wlderiv-es2 $4))
|
||||
$2 'list $4)]
|
||||
|
|
@ -524,7 +481,6 @@
|
|||
|
||||
;; BlockPass1 Answer = (list-of BRule)
|
||||
(BlockPass1
|
||||
(#:no-wrap)
|
||||
(#:skipped null)
|
||||
[() null]
|
||||
[((? BRule) (? BlockPass1))
|
||||
|
|
@ -532,7 +488,6 @@
|
|||
|
||||
;; BRule Answer = BRule
|
||||
(BRule
|
||||
(#:wrap)
|
||||
[(next !!)
|
||||
(make b:error $2)]
|
||||
[(next renames-block (? CheckImmediateMacro))
|
||||
|
|
@ -547,13 +502,11 @@
|
|||
|
||||
;; BindSyntaxes Answer = Derivation
|
||||
(BindSyntaxes
|
||||
(#:wrap)
|
||||
[(phase-up (? EE/LetLifts) (? Eval))
|
||||
(make bind-syntaxes $2 $3)])
|
||||
[(enter-bind (? EE/LetLifts) next (? Eval) exit-bind)
|
||||
(make bind-syntaxes $2 $4)])
|
||||
|
||||
;; NextBindSyntaxess Answer = (list-of Derivation)
|
||||
(NextBindSyntaxess
|
||||
(#:no-wrap)
|
||||
(#:skipped null)
|
||||
[() null]
|
||||
[(next (? BindSyntaxes) (? NextBindSyntaxess)) (cons $2 $3)])
|
||||
|
|
@ -561,7 +514,6 @@
|
|||
;; Lists
|
||||
;; EL Answer = ListDerivation
|
||||
(EL
|
||||
(#:wrap)
|
||||
(#:skipped #f)
|
||||
[(enter-list ! (? EL*) exit-list)
|
||||
;; FIXME: Workaround for bug in events
|
||||
|
|
@ -571,7 +523,6 @@
|
|||
|
||||
;; EL* Answer = (listof Derivation)
|
||||
(EL*
|
||||
(#:no-wrap)
|
||||
(#:skipped null)
|
||||
[() null]
|
||||
[(next (? EE) (? EL*)) (cons $2 $3)])
|
||||
|
|
|
|||
|
|
@ -44,7 +44,16 @@
|
|||
enter-local/expr ; syntax
|
||||
exit-local/expr ; (cons syntax expanded-expression)
|
||||
|
||||
local-bind ; (list-of identifier)
|
||||
enter-bind ; .
|
||||
exit-bind ; .
|
||||
opaque ; opaque-syntax
|
||||
|
||||
variable ; (cons identifier identifier)
|
||||
tag ; syntax
|
||||
|
||||
rename-one ; syntax
|
||||
rename-list ; (list-of syntax)
|
||||
|
||||
IMPOSSIBLE ; useful for error-handling clauses that have no NoError counterpart
|
||||
))
|
||||
|
|
@ -142,6 +151,13 @@
|
|||
(139 . ,token-enter-local/expr)
|
||||
(140 . ,token-exit-local/expr)
|
||||
(141 . ,token-start)
|
||||
(142 . ,token-tag)
|
||||
(143 . ,token-local-bind)
|
||||
(144 . ,token-enter-bind)
|
||||
(145 . ,token-exit-bind)
|
||||
(146 . ,token-opaque)
|
||||
(147 . ,token-rename-list)
|
||||
(148 . ,token-rename-one)
|
||||
))
|
||||
|
||||
(define (tokenize sig-n val pos)
|
||||
|
|
|
|||
|
|
@ -59,8 +59,8 @@
|
|||
[?1 (?? exn?)]
|
||||
[me1 (?? syntax?)]
|
||||
[locals (?? (listof localaction/c))]
|
||||
[?2 (?? exn?)]
|
||||
[me2 (?? syntax?)]
|
||||
[?2 (?? exn?)]
|
||||
[seq number?]))
|
||||
(struct (local-expansion node)
|
||||
([z1 syntax?]
|
||||
|
|
|
|||
|
|
@ -2,100 +2,103 @@
|
|||
#lang scheme/base
|
||||
(require (for-syntax scheme/base)
|
||||
scheme/match
|
||||
syntax/boundmap)
|
||||
(provide (all-defined-out))
|
||||
syntax/boundmap
|
||||
"synth-engine.ss")
|
||||
(provide make-policy
|
||||
standard-policy
|
||||
base-policy
|
||||
hide-all-policy
|
||||
hide-none-policy)
|
||||
|
||||
(define-struct hiding-policy
|
||||
(opaque-modules opaque-ids opaque-kernel opaque-libs transparent-ids)
|
||||
#:mutable)
|
||||
;; make-policy : bool^4 (listof (identifier bindinglist (bool -> void) -> void))
|
||||
;; -> identifier -> bool
|
||||
(define (make-policy hide-mzscheme?
|
||||
hide-libs?
|
||||
hide-contracts?
|
||||
hide-transformers?
|
||||
specialized-policies)
|
||||
(lambda (id)
|
||||
(define now (phase))
|
||||
(define binding
|
||||
(cond [(= now 0) (identifier-binding id)]
|
||||
[(= now 1) (identifier-transformer-binding id)]
|
||||
[else #f]))
|
||||
(define-values (def-mod def-name nom-mod nom-name)
|
||||
(if (pair? binding)
|
||||
(values (car binding)
|
||||
(cadr binding)
|
||||
(caddr binding)
|
||||
(cadddr binding))
|
||||
(values #f #f #f #f)))
|
||||
(let/ec return
|
||||
(let loop ([policies specialized-policies])
|
||||
(when (pair? policies)
|
||||
((car policies) id binding return)
|
||||
(loop (cdr policies))))
|
||||
(cond [(and hide-mzscheme? def-mod (scheme-module? def-mod))
|
||||
#f]
|
||||
[(and hide-libs? def-mod (lib-module? def-mod))
|
||||
#f]
|
||||
[(and hide-contracts? def-name
|
||||
(regexp-match #rx"^provide/contract-id-"
|
||||
(symbol->string def-name)))
|
||||
#f]
|
||||
[(and hide-transformers? (positive? now))
|
||||
#f]
|
||||
[else #t]))))
|
||||
|
||||
(define (policy-hide-module p m)
|
||||
(hash-table-put! (hiding-policy-opaque-modules p) m #t))
|
||||
(define (policy-unhide-module p m)
|
||||
(hash-table-remove! (hiding-policy-opaque-modules p) m))
|
||||
(define standard-policy
|
||||
(make-policy #t #t #t #t null))
|
||||
|
||||
(define (policy-hide-kernel p)
|
||||
(set-hiding-policy-opaque-kernel! p #t))
|
||||
(define (policy-unhide-kernel p)
|
||||
(set-hiding-policy-opaque-kernel! p #f))
|
||||
(define base-policy
|
||||
(make-policy #t #f #f #f null))
|
||||
|
||||
(define (policy-hide-libs p)
|
||||
(set-hiding-policy-opaque-libs! p #t))
|
||||
(define (policy-unhide-libs p)
|
||||
(set-hiding-policy-opaque-libs! p #f))
|
||||
(define (hide-all-policy id) #f)
|
||||
(define (hide-none-policy id) #t)
|
||||
|
||||
(define (policy-hide-id p id)
|
||||
(policy-unshow-id p id)
|
||||
(module-identifier-mapping-put! (hiding-policy-opaque-ids p) id #t))
|
||||
(define (policy-unhide-id p id)
|
||||
(module-identifier-mapping-put! (hiding-policy-opaque-ids p) id #f))
|
||||
|
||||
(define (policy-show-id p id)
|
||||
(policy-unhide-id p id)
|
||||
(module-identifier-mapping-put! (hiding-policy-transparent-ids p) id #t))
|
||||
(define (policy-unshow-id p id)
|
||||
(module-identifier-mapping-put! (hiding-policy-transparent-ids p) id #f))
|
||||
;;
|
||||
|
||||
(define (new-hiding-policy)
|
||||
(make-hiding-policy (make-hash-table)
|
||||
(make-module-identifier-mapping)
|
||||
#f
|
||||
#f
|
||||
(make-module-identifier-mapping)))
|
||||
|
||||
(define (new-standard-hiding-policy)
|
||||
(let ([p (new-hiding-policy)])
|
||||
(policy-hide-kernel p)
|
||||
(policy-hide-libs p)
|
||||
p))
|
||||
|
||||
;; ---
|
||||
|
||||
(define-syntax inline
|
||||
(syntax-rules ()
|
||||
[(inline ([name expr] ...) . body)
|
||||
(let-syntax ([name
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[xx (identifier? #'xx) #'expr]))] ...)
|
||||
. body)]))
|
||||
|
||||
(define (/false) #f)
|
||||
|
||||
(define (policy-show-macro? policy id)
|
||||
(match policy
|
||||
[(struct hiding-policy (opaque-modules
|
||||
opaque-identifiers
|
||||
opaque-kernel
|
||||
opaque-libs
|
||||
transparent-identifiers))
|
||||
(inline ([not-opaque-id
|
||||
(not (module-identifier-mapping-get opaque-identifiers id /false))]
|
||||
[transparent-id
|
||||
(module-identifier-mapping-get transparent-identifiers id /false)])
|
||||
(let ([binding (identifier-binding id)])
|
||||
(if (list? binding)
|
||||
(let-values ([(srcmod srcname nommod nomname _) (apply values binding)])
|
||||
(inline ([opaque-srcmod (hash-table-get opaque-modules srcmod /false)]
|
||||
[opaque-nommod (hash-table-get opaque-modules nommod /false)]
|
||||
;; FIXME
|
||||
[in-kernel?
|
||||
(and (symbol? srcmod)
|
||||
(eq? #\# (string-ref (symbol->string srcmod) 0)))]
|
||||
[in-lib-module?
|
||||
(lib-module? srcmod)])
|
||||
(or transparent-id
|
||||
(and (not opaque-srcmod)
|
||||
(not opaque-nommod)
|
||||
(not (and in-kernel? opaque-kernel))
|
||||
(not (and in-lib-module? opaque-libs))
|
||||
not-opaque-id))))
|
||||
(or transparent-id
|
||||
not-opaque-id))))]))
|
||||
(define (scheme-module? mpi)
|
||||
(let ([abs (find-absolute-module-path mpi)])
|
||||
(and abs
|
||||
(or (base-module-path? abs)
|
||||
(scheme-lib-module-path? abs)))))
|
||||
|
||||
(define (lib-module? mpi)
|
||||
(let ([abs (find-absolute-module-path mpi)])
|
||||
(and abs (lib-module-path? abs))))
|
||||
|
||||
|
||||
(define (find-absolute-module-path mpi)
|
||||
(and (module-path-index? mpi)
|
||||
(let-values ([(path rel) (module-path-index-split mpi)])
|
||||
(cond [(pair? path) (memq (car path) '(lib planet))]
|
||||
[(string? path) (lib-module? rel)]
|
||||
(cond [(and (pair? path) (memq (car path) '(quote lib planet)))
|
||||
path]
|
||||
[(symbol? path) path]
|
||||
[(string? path) (find-absolute-module-path rel)]
|
||||
[else #f]))))
|
||||
|
||||
(define (base-module-path? mp)
|
||||
(and (pair? mp)
|
||||
(eq? 'quote (car mp))
|
||||
(regexp-match #rx"^#%" (symbol->string (cadr mp)))))
|
||||
|
||||
(define (scheme-lib-module-path? mp)
|
||||
(cond [(symbol? mp)
|
||||
(scheme-collection-name? (symbol->string mp))]
|
||||
[(and (pair? mp) (eq? (car mp) 'lib))
|
||||
(cond [(string? (cadr mp)) (null? (cddr mp))
|
||||
(scheme-collection-name? (cadr mp))]
|
||||
[(symbol? (cadr mp))
|
||||
(scheme-collection-name? (symbol->string (cadr mp)))]
|
||||
[else #f])]
|
||||
[else #f]))
|
||||
|
||||
(define (scheme-collection-name? path)
|
||||
(or (regexp-match? #rx"^scheme/base(/.)?" path)
|
||||
(regexp-match? #rx"^mzscheme(/.)?" path)))
|
||||
|
||||
(define (lib-module-path? mp)
|
||||
(or (symbol? mp)
|
||||
(and (pair? mp) (memq (car mp) '(lib planet)))))
|
||||
|
|
|
|||
|
|
@ -158,16 +158,19 @@
|
|||
[(CC HOLE expr pattern)
|
||||
#'(syntax-copier HOLE expr pattern)]))
|
||||
|
||||
;; (R stx R-clause ...)
|
||||
;; R
|
||||
;; the threaded reductions engine
|
||||
|
||||
;; (R stx R-clause ...) : (values (list-of Step) ?stx ?exn)
|
||||
;; An R-clause is one of
|
||||
;; [! expr]
|
||||
;; [#:pattern pattern]
|
||||
;; [#:bind pattern stx-expr]
|
||||
;; [#:let-values (var ...) expr]
|
||||
;; [#:set-syntax stx-expr]
|
||||
;; [#:walk term2 foci1 foci2 description]
|
||||
;; [#:walk term2 description]
|
||||
;; [#:rename form2 foci1 foci2 description]
|
||||
;; [#:walk/ctx pattern term2 description]
|
||||
;; [#:walk/foci term2 foci1 foci2 description]
|
||||
;; [#:rename* pattern rename [description]]
|
||||
;; [#:rename/no-step pattern stx stx]
|
||||
;; [#:reductions expr]
|
||||
;; [#:learn ids]
|
||||
|
|
@ -176,15 +179,11 @@
|
|||
;; [#:if/np test R-clause ...]
|
||||
;; [generator hole fill]
|
||||
|
||||
;; R
|
||||
;; the threaded reductions engine
|
||||
|
||||
;; (R form . clauses) : (values (list-of Step) ?stx ?exn)
|
||||
|
||||
(define-syntax R
|
||||
(syntax-rules ()
|
||||
[(R form . clauses)
|
||||
(R** #f _ [#:set-syntax form] . clauses)]))
|
||||
(let ([form-var form])
|
||||
(R** form-var _ . clauses))]))
|
||||
|
||||
(define-syntax R**
|
||||
(syntax-rules (! =>)
|
||||
|
|
@ -224,14 +223,6 @@
|
|||
(let ([form-variable form])
|
||||
(R** form-variable p . more))]
|
||||
|
||||
;; Change syntax and Step (explicit foci)
|
||||
[(R** f p [#:walk form2 foci1 foci2 description] . more)
|
||||
(let-values ([(form2-var foci1-var foci2-var description-var)
|
||||
(with-syntax ([p f])
|
||||
(values form2 foci1 foci2 description))])
|
||||
(RSadd (list (walk/foci foci1-var foci2-var f form2-var description-var))
|
||||
(lambda () (R** form2-var p . more))))]
|
||||
|
||||
;; Change syntax and Step (infer foci)
|
||||
[(R** f p [#:walk form2 description] . more)
|
||||
(let-values ([(form2-var description-var)
|
||||
|
|
@ -240,7 +231,51 @@
|
|||
(RSadd (list (walk f form2-var description-var))
|
||||
(lambda () (R** form2-var p . more))))]
|
||||
|
||||
;; Change syntax and Step (explicit foci)
|
||||
[(R** f p [#:walk/foci form2 foci1 foci2 description] . more)
|
||||
(let-values ([(form2-var foci1-var foci2-var description-var)
|
||||
(with-syntax ([p f])
|
||||
(values form2 foci1 foci2 description))])
|
||||
(RSadd (list (walk/foci foci1-var foci2-var f form2-var description-var))
|
||||
(lambda () (R** form2-var p . more))))]
|
||||
|
||||
[(R** f p [#:walk/ctx hole form2 desc] . more)
|
||||
(let-values ([(form2-var desc-var)
|
||||
(with-syntax ([p f])
|
||||
(values form2 desc))])
|
||||
(let ([k (lambda (f2) (R** f2 p . more))]
|
||||
[generator
|
||||
(lambda ()
|
||||
(lambda (d init-e1)
|
||||
(R init-e1
|
||||
[#:walk form2-var desc-var])))])
|
||||
(Run f p generator hole form2 k)))]
|
||||
|
||||
;; Rename
|
||||
[(R** f p [#:rename* pattern renames] . more)
|
||||
(R** f p [#:rename* pattern renames #f] . more)]
|
||||
|
||||
[(R** f p [#:rename* pattern renames description] . more)
|
||||
(let-values ([(renames-var description-var)
|
||||
(with-syntax ([p f])
|
||||
(values renames description))])
|
||||
(let ([pre-renames-var
|
||||
(with-syntax ([p f]) (syntax pattern))]
|
||||
[f2
|
||||
(with-syntax ([p f])
|
||||
(with-syntax ([pattern renames])
|
||||
(syntax p)))])
|
||||
(rename-frontier pre-renames-var renames-var)
|
||||
(with-context (make-renames pre-renames-var renames-var)
|
||||
(RSadd (if description-var
|
||||
(list (walk/foci pre-renames-var renames-var
|
||||
f f2
|
||||
description-var))
|
||||
null)
|
||||
(lambda () (R** f2 p . more))))))]
|
||||
|
||||
;; Change syntax with rename
|
||||
#;
|
||||
[(R** f p [#:rename form2 foci1 foci2 description] . more)
|
||||
(let-values ([(form2-var foci1-var foci2-var description-var)
|
||||
(with-syntax ([p f])
|
||||
|
|
@ -307,22 +342,28 @@
|
|||
(define-syntax Run
|
||||
(syntax-rules ()
|
||||
[(Run f p generator hole fill k)
|
||||
(let ([reducer (with-syntax ([p f]) (generator))])
|
||||
(let ([reducer (generator)])
|
||||
(Run* reducer f p hole fill k))]))
|
||||
|
||||
(define-syntax (Run* stx)
|
||||
(syntax-case stx ()
|
||||
;; Implementation of subterm handling for (hole ...) sequences
|
||||
[(Run* f form-var pattern (hole :::) fills k)
|
||||
[(Run* reducer f p (hole :::) fills k)
|
||||
(and (identifier? #':::)
|
||||
(free-identifier=? #'::: (quote-syntax ...)))
|
||||
#'(let ([ctx (CC (hole :::) form-var pattern)])
|
||||
(let ([e1s (with-syntax ([pattern form-var]) (syntax->list #'(hole :::)))])
|
||||
(run-multiple f ctx fills e1s k)))]
|
||||
#'(let ([ctx (CC (hole :::) f p)])
|
||||
(let ([e1s (with-syntax ([p f]) (syntax->list #'(hole :::)))])
|
||||
(run-multiple reducer ctx fills e1s k)))]
|
||||
;; Implementation of subterm handling
|
||||
[(Run* f form-var pattern hole fill k)
|
||||
#'(let ([ctx (CC hole form-var pattern)])
|
||||
(run-one f ctx fill k))]))
|
||||
[(Run* reducer f p hole fill k)
|
||||
#'(let ([init-e (with-syntax ([p f]) #'hole)]
|
||||
[ctx (CC hole f p)])
|
||||
(run-one reducer init-e ctx fill k))]))
|
||||
|
||||
;; run-one : (a stx -> RS(b)) stx (b -> c) (c -> RS(d)) -> RS(d)
|
||||
(define (run-one f init-e ctx fill k)
|
||||
(RSbind (lambda () (with-context ctx (f fill init-e)))
|
||||
(lambda (final) (k (ctx final)))))
|
||||
|
||||
;; run-multiple : (a -> RS(b)) ((list-of b) -> c) (list-of a) (list-of b) (c -> RS(d))
|
||||
;; -> RS(d)
|
||||
|
|
@ -334,7 +375,7 @@
|
|||
(RSbind (lambda ()
|
||||
(with-context ctx
|
||||
(with-context (lambda (x) (revappend prefix (cons x (cdr suffix))))
|
||||
(f (car fills)))))
|
||||
(f (car fills) (car suffix)))))
|
||||
(lambda (final)
|
||||
(loop (cdr fills)
|
||||
(cons final prefix)
|
||||
|
|
@ -343,12 +384,6 @@
|
|||
(let ([form (ctx (reverse prefix))])
|
||||
(k form))])))
|
||||
|
||||
;; run-one : (a -> RS(b)) (b -> c) (c -> RS(d)) -> RS(d)
|
||||
(define (run-one f ctx fill k)
|
||||
(RSbind (lambda () (with-context ctx (f fill)))
|
||||
(lambda (final)
|
||||
(k (ctx final)))))
|
||||
|
||||
;; Rename mapping
|
||||
|
||||
(define (rename-frontier from to)
|
||||
|
|
@ -367,7 +402,8 @@
|
|||
[(syntax? to)
|
||||
(loop from (syntax-e to))]
|
||||
[(pair? from)
|
||||
#;(unless (pair? to)
|
||||
#;
|
||||
(unless (pair? to)
|
||||
(fprintf (current-error-port)
|
||||
"from:\n~s\n\n" (syntax->datum from0))
|
||||
(fprintf (current-error-port)
|
||||
|
|
|
|||
|
|
@ -19,14 +19,14 @@
|
|||
transformation-reductions)
|
||||
(define (BindSyntaxes)
|
||||
bind-syntaxes-reductions)
|
||||
(define ((CaseLambdaClauses e1))
|
||||
(mk-case-lambda-clauses-reductions e1))
|
||||
(define ((SynthItems e1))
|
||||
(mk-synth-items-reductions e1))
|
||||
(define ((BRules es1))
|
||||
(mk-brules-reductions es1))
|
||||
(define ((ModulePass es1))
|
||||
(mk-mbrules-reductions es1))
|
||||
(define (CaseLambdaClauses)
|
||||
case-lambda-clauses-reductions)
|
||||
(define (SynthItems)
|
||||
synth-items-reductions)
|
||||
(define (BRules)
|
||||
brules-reductions)
|
||||
(define (ModulePass)
|
||||
mbrules-reductions)
|
||||
|
||||
;; Syntax
|
||||
|
||||
|
|
@ -41,24 +41,28 @@
|
|||
|
||||
;; reductions : WDeriv -> ReductionSequence
|
||||
(define (reductions d)
|
||||
(parameterize ((current-definites null)
|
||||
(current-frontier null))
|
||||
(when d (add-frontier (list (wderiv-e1 d))))
|
||||
(RS-steps (reductions* d))))
|
||||
(let-values ([(steps definites estx exn) (reductions+ d)])
|
||||
steps))
|
||||
|
||||
;; reductions+ : WDeriv -> (list-of step) (list-of identifier) ?stx ?exn
|
||||
(define (reductions+ d)
|
||||
(parameterize ((current-definites null)
|
||||
(current-frontier null))
|
||||
(when d (add-frontier (list (wderiv-e1 d))))
|
||||
(let-values ([(rs stx exn) (reductions* d)])
|
||||
(values rs (current-definites) stx exn))))
|
||||
(let-values ([(steps stx exn) (reductions* d (wderiv-e1 d))])
|
||||
(values steps (current-definites) stx exn))))
|
||||
|
||||
;; reductions* : WDeriv -> RS(stx)
|
||||
(define (reductions* d)
|
||||
;; reductions* : WDeriv Syntax -> RS(stx)
|
||||
(define (reductions* d init-e1)
|
||||
(match d
|
||||
[(Wrap deriv (e1 e2))
|
||||
(blaze-frontier e1)]
|
||||
(begin (blaze-frontier e1)
|
||||
(unless (eq? init-e1 e1)
|
||||
(void)
|
||||
#;(fprintf (current-error-port)
|
||||
"starting points don't match:\n~s\n~s\n"
|
||||
init-e1 e1)
|
||||
#;(error 'reductions* "starting points don't match for: ~s" d)))]
|
||||
[_ (void)])
|
||||
(match d
|
||||
[(Wrap prule (e1 e2 rs ?1))
|
||||
|
|
@ -70,38 +74,41 @@
|
|||
(R e1
|
||||
[#:learn (list e2)]
|
||||
[#:when/np (not (bound-identifier=? e1 e2))
|
||||
[#:walk e2 e1 e2 'resolve-variable]])]
|
||||
[(Wrap p:module (e1 e2 rs ?1 #f #f #f body))
|
||||
[#:walk e2 'resolve-variable]])]
|
||||
[(Wrap p:module (e1 e2 rs ?1 ?2 tag rename check tag2 ?3 body shift))
|
||||
(R e1
|
||||
[! ?1]
|
||||
[#:pattern (?module ?name ?language . ?_body)]
|
||||
[#:walk (d->so e1 `(,#'?module ,#'?name ,#'?language ,(wderiv-e1 body)))
|
||||
'tag-module-begin]
|
||||
[#:pattern (?module ?name ?language ?body)]
|
||||
[#:frontier (list #'?body)]
|
||||
[Expr ?body body])]
|
||||
[(Wrap p:module (e1 e2 rs ?1 #t mb ?2 body))
|
||||
(R e1
|
||||
[! ?1]
|
||||
[#:pattern (?module ?name ?language ?body)]
|
||||
[#:frontier (list #'?body)]
|
||||
[Expr ?body mb]
|
||||
[#:pattern (?module ?name ?language . ?body-parts)]
|
||||
#;[#:frontier null (list #'?language #'?body-parts)]
|
||||
[! ?2]
|
||||
[#:when/np (not (eq? (wderiv-e2 mb) (wderiv-e1 body)))
|
||||
[#:walk
|
||||
(d->so e1 `(,#'?module ,#'?name ,#'?language
|
||||
,(wderiv-e1 body)))
|
||||
#;[#:frontier (list #'?language) null]
|
||||
[#:when/np tag
|
||||
[#:walk/ctx ?body-parts
|
||||
(list tag)
|
||||
'tag-module-begin]]
|
||||
[Expr ?body body])]
|
||||
[(Wrap p:#%module-begin (e1 e2 rs ?1 pass1 pass2 ?2))
|
||||
[#:pattern (?module ?name ?language ?body)]
|
||||
[#:rename* ?body rename]
|
||||
[#:when/np check
|
||||
[Expr ?body check]]
|
||||
[#:when/np tag2
|
||||
[#:walk/ctx ?body
|
||||
tag2
|
||||
'tag-module-begin]]
|
||||
[! ?3]
|
||||
[Expr ?body body]
|
||||
[#:pattern ?form]
|
||||
[#:rename* ?form shift])]
|
||||
[(Wrap p:#%module-begin (e1 e2 rs ?1 me pass1 pass2 ?2))
|
||||
(R e1
|
||||
[! ?1]
|
||||
#;[#:let-values (_) (printf "#%module-begin:\n~s\n" me)]
|
||||
[#:pattern ?form]
|
||||
[#:rename* ?form me]
|
||||
[#:pattern (?module-begin . ?forms)]
|
||||
[#:frontier (stx->list* #'?forms)]
|
||||
[(ModulePass #'?forms)
|
||||
?forms pass1]
|
||||
[(ModulePass #'?forms)
|
||||
?forms pass2]
|
||||
#;[#:frontier (syntax->list #'?forms)]
|
||||
#;[#:let-values (_) (printf "#%module-begin ?forms:\n~s\n" #'?forms)]
|
||||
[ModulePass ?forms pass1]
|
||||
[ModulePass ?forms pass2]
|
||||
[! ?1])]
|
||||
[(Wrap p:define-syntaxes (e1 e2 rs ?1 rhs ?2))
|
||||
(R e1
|
||||
|
|
@ -124,21 +131,14 @@
|
|||
[#:pattern (?expr ?inner)]
|
||||
[#:frontier (list #'?inner)]
|
||||
[Expr ?inner inner])]
|
||||
[(Wrap p:if (e1 e2 rs ?1 full? test then else))
|
||||
(if full?
|
||||
[(Wrap p:if (e1 e2 rs ?1 test then else))
|
||||
(R e1
|
||||
[! ?1]
|
||||
[#:pattern (?if TEST THEN ELSE)]
|
||||
[#:frontier (list #'TEST #'THEN #'ELSE)]
|
||||
[Expr TEST test]
|
||||
[Expr THEN then]
|
||||
[Expr ELSE else])
|
||||
(R e1
|
||||
[! ?1]
|
||||
[#:pattern (?if TEST THEN)]
|
||||
[#:frontier (list #'TEST #'THEN)]
|
||||
[Expr TEST test]
|
||||
[Expr THEN then]))]
|
||||
[Expr ELSE else])]
|
||||
[(Wrap p:wcm (e1 e2 rs ?1 key mark body))
|
||||
(R e1
|
||||
[! ?1]
|
||||
|
|
@ -160,42 +160,31 @@
|
|||
[#:frontier (cons #'FIRST (stx->list* #'LDERIV))]
|
||||
[Expr FIRST first]
|
||||
[List LDERIV lderiv])]
|
||||
[(Wrap p:#%app (e1 e2 rs ?1 tagged-stx lderiv))
|
||||
[(Wrap p:#%app (e1 e2 rs ?1 lderiv))
|
||||
(R e1
|
||||
[! ?1]
|
||||
[#:when/np (not (eq? tagged-stx e1))
|
||||
[#:walk tagged-stx 'tag-app]]
|
||||
[#:pattern (?app . LDERIV)]
|
||||
[#:frontier (stx->list* #'LDERIV)]
|
||||
[List LDERIV lderiv])]
|
||||
[(Wrap p:lambda (e1 e2 rs ?1 renames body))
|
||||
(R e1
|
||||
[! ?1]
|
||||
[#:bind (?formals* . ?body*) renames]
|
||||
[#:pattern (?lambda ?formals . ?body)]
|
||||
[#:frontier (stx->list* #'?body)]
|
||||
[#:rename (syntax/skeleton e1 (?lambda ?formals* . ?body*))
|
||||
#'?formals #'?formals*
|
||||
'rename-lambda]
|
||||
[#:rename* (?formals . ?body) renames 'rename-lambda]
|
||||
[Block ?body body])]
|
||||
[(Wrap p:case-lambda (e1 e2 rs ?1 clauses))
|
||||
(R e1
|
||||
[! ?1]
|
||||
[#:pattern (?case-lambda . ?clauses)]
|
||||
[#:frontier (stx->list* #'?clauses)]
|
||||
[(CaseLambdaClauses (stx->list* #'?clauses))
|
||||
?clauses clauses])]
|
||||
[CaseLambdaClauses ?clauses clauses])]
|
||||
[(Wrap p:let-values (e1 e2 rs ?1 renames rhss body))
|
||||
(R e1
|
||||
[! ?1]
|
||||
[#:pattern (?let-values ([?vars ?rhs] ...) . ?body)]
|
||||
[#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))]
|
||||
[#:bind (([?vars* ?rhs*] ...) . ?body*) renames]
|
||||
[#:rename
|
||||
(syntax/skeleton e1 (?let-values ([?vars* ?rhs*] ...) . ?body*))
|
||||
(syntax->list #'(?vars ...))
|
||||
(syntax->list #'(?vars* ...))
|
||||
'rename-let-values]
|
||||
[#:rename* (((?vars ?rhs) ...) . ?body) renames 'rename-let-values]
|
||||
[Expr (?rhs ...) rhss]
|
||||
[Block ?body body])]
|
||||
[(Wrap p:letrec-values (e1 e2 rs ?1 renames rhss body))
|
||||
|
|
@ -203,12 +192,7 @@
|
|||
[! ?1]
|
||||
[#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)]
|
||||
[#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))]
|
||||
[#:bind (([?vars* ?rhs*] ...) . ?body*) renames]
|
||||
[#:rename
|
||||
(syntax/skeleton e1 (?letrec-values ([?vars* ?rhs*] ...) . ?body*))
|
||||
(syntax->list #'(?vars ...))
|
||||
(syntax->list #'(?vars* ...))
|
||||
'rename-letrec-values]
|
||||
[#:rename* (((?vars ?rhs) ...) . ?body) renames 'rename-letrec-values]
|
||||
[Expr (?rhs ...) rhss]
|
||||
[Block ?body body])]
|
||||
[(Wrap p:letrec-syntaxes+values
|
||||
|
|
@ -219,44 +203,34 @@
|
|||
[#:frontier (append (syntax->list #'(?srhs ...))
|
||||
(syntax->list #'(?vrhs ...))
|
||||
(stx->list* #'?body))]
|
||||
[#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...) . ?body*) srenames]
|
||||
[#:rename
|
||||
(syntax/skeleton e1
|
||||
(?lsv ([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...)
|
||||
. ?body*))
|
||||
(syntax->list #'(?svars ...))
|
||||
(syntax->list #'(?svars* ...))
|
||||
[#:rename* (((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body) srenames
|
||||
'rename-lsv]
|
||||
[BindSyntaxes (?srhs ...) srhss]
|
||||
;; If vrenames is #f, no var bindings to rename
|
||||
[#:when/np vrenames
|
||||
[#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames]
|
||||
[#:rename
|
||||
(syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...)
|
||||
([?vvars** ?vrhs**] ...)
|
||||
. ?body**))
|
||||
(syntax->list #'(?vvars* ...))
|
||||
(syntax->list #'(?vvars** ...))
|
||||
'rename-lsv]]
|
||||
[#:rename* (((?vars ?vrhs) ...) . ?body) vrenames 'rename-lsv]]
|
||||
[Expr (?vrhs ...) vrhss]
|
||||
[Block ?body body]
|
||||
[#:pattern ?form]
|
||||
[#:when/np (not (eq? #'?form e2)) ;; FIXME: correct comparison?
|
||||
[#:walk e2 'lsv-remove-syntax]])]
|
||||
;; The auto-tagged atomic primitives
|
||||
[(Wrap p:#%datum (e1 e2 rs ?1 tagged-stx))
|
||||
|
||||
[(Wrap p:#%datum (e1 e2 rs ?1))
|
||||
(R e1
|
||||
[#:when/np (not (eq? e1 tagged-stx))
|
||||
[#:walk tagged-stx 'tag-datum]]
|
||||
[! ?1])]
|
||||
[(Wrap p:#%top (e1 e2 rs ?1 tagged-stx))
|
||||
[! ?1]
|
||||
[#:walk e2 'macro])]
|
||||
[(Wrap p:#%top (e1 e2 rs ?1))
|
||||
(R e1
|
||||
[#:when/np (not (eq? e1 tagged-stx))
|
||||
[#:walk tagged-stx 'tag-top]]
|
||||
[#:pattern (?top . ?var)]
|
||||
[#:learn (list #'?var)]
|
||||
[! ?1])]
|
||||
|
||||
[(Wrap p:provide (e1 e2 rs ?1))
|
||||
(R e1
|
||||
[! ?1]
|
||||
[#:walk e2 'provide])]
|
||||
|
||||
;; The rest of the automatic primitives
|
||||
[(Wrap p::STOP (e1 e2 rs ?1))
|
||||
(R e1
|
||||
|
|
@ -299,17 +273,18 @@
|
|||
(rename-frontier (s:rename-after (car subterms))
|
||||
(s:rename-before (car subterms)))]))
|
||||
(current-frontier))]
|
||||
[(SynthItems e1) ?form subterms]
|
||||
[SynthItems ?form subterms]
|
||||
[! ?2])]
|
||||
|
||||
;; FIXME: elimiate => ??
|
||||
[(Wrap p:rename (e1 e2 rs ?1 rename inner))
|
||||
(R e1
|
||||
[! ?1]
|
||||
[#:pattern ?form]
|
||||
=>
|
||||
(lambda (e)
|
||||
(rename-frontier (car rename) (cdr rename))
|
||||
(reductions* inner)))]
|
||||
(reductions* inner (wderiv-e1 inner))))]
|
||||
|
||||
;; Macros
|
||||
[(Wrap mrule (e1 e2 transformation next))
|
||||
|
|
@ -319,6 +294,18 @@
|
|||
[#:frontier (list (wderiv-e1 next))]
|
||||
[Expr ?form next])]
|
||||
|
||||
[(Wrap tagrule (e1 e2 tagged-stx next))
|
||||
(R e1
|
||||
[#:pattern ?form]
|
||||
[#:walk tagged-stx
|
||||
(case (syntax-e (stx-car tagged-stx))
|
||||
((#%app) 'tag-app)
|
||||
((#%datum) 'tag-datum)
|
||||
((#%top) 'tag-top)
|
||||
(else
|
||||
(error 'reductions "unknown tagged syntax: ~s" tagged-stx)))]
|
||||
[Expr ?form next])]
|
||||
|
||||
;; Lifts
|
||||
|
||||
[(Wrap lift-deriv (e1 e2 first lifted-stx second))
|
||||
|
|
@ -338,11 +325,11 @@
|
|||
[Expr ?form second])]
|
||||
|
||||
;; Skipped
|
||||
[#f (RSzero)]))
|
||||
[#f (RSunit init-e1)]))
|
||||
|
||||
;; mk-case-lambda-clauses-reductions : stxs ->
|
||||
;; (list-of (W (list ?exn rename (W BDeriv)))) -> (RS stxs)
|
||||
(define ((mk-case-lambda-clauses-reductions es1) clauses)
|
||||
;; case-lambda-clauses-reductions :
|
||||
;; (list-of (W (list ?exn rename (W BDeriv)))) stxs -> (RS stxs)
|
||||
(define (case-lambda-clauses-reductions clauses es1)
|
||||
(blaze-frontier es1)
|
||||
(match clauses
|
||||
['()
|
||||
|
|
@ -352,16 +339,12 @@
|
|||
[! ?1]
|
||||
[#:pattern ((?formals . ?body) . ?rest)]
|
||||
[#:frontier (list #'?body #'?rest)]
|
||||
[#:bind (?formals* . ?body*) rename]
|
||||
[#:rename (syntax/skeleton es1 ((?formals* . ?body*) . ?rest))
|
||||
#'?formals #'?formals*
|
||||
'rename-case-lambda]
|
||||
[#:rename* (?formals . ?body) rename 'rename-case-lambda]
|
||||
[Block ?body body]
|
||||
[(CaseLambdaClauses (cdr es1))
|
||||
?rest rest])]))
|
||||
[CaseLambdaClauses ?rest rest])]))
|
||||
|
||||
;; mk-synth-items-reductions : syntax -> (list-of SynthItem) -> (RS syntax)
|
||||
(define ((mk-synth-items-reductions e1) subterms)
|
||||
;; synth-items-reductions : (list-of SynthItem) syntax -> (RS syntax)
|
||||
(define (synth-items-reductions subterms e1)
|
||||
(let loop ([term e1] [subterms subterms])
|
||||
(cond [(null? subterms)
|
||||
(RSunit e1)]
|
||||
|
|
@ -369,9 +352,12 @@
|
|||
(let* ([subterm0 (car subterms)]
|
||||
[path0 (s:subterm-path subterm0)]
|
||||
[deriv0 (s:subterm-deriv subterm0)])
|
||||
(let ([ctx (lambda (x) (path-replace term path0 x))])
|
||||
(let ([ctx (lambda (x) (path-replace term path0 x))]
|
||||
;; unused: may not be the same, due to mark/unmark???
|
||||
[init-e (path-get term path0)])
|
||||
(RSseq (lambda ()
|
||||
(with-context ctx (reductions* deriv0)))
|
||||
(with-context ctx
|
||||
(reductions* deriv0 (wderiv-e1 deriv0))))
|
||||
(lambda ()
|
||||
(loop (path-replace term path0 (wderiv-e2 deriv0))
|
||||
(cdr subterms))))))]
|
||||
|
|
@ -386,20 +372,17 @@
|
|||
(s:rename-after subterm0))
|
||||
(cdr subterms)))])))
|
||||
|
||||
;; transformation-reductions : Transformation -> (RS Stx)
|
||||
(define (transformation-reductions tx)
|
||||
;; transformation-reductions : Transformation stx -> (RS Stx)
|
||||
(define (transformation-reductions tx init-e1)
|
||||
(match tx
|
||||
[(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 seq))
|
||||
[(Wrap transformation (e1 e2 rs ?1 me1 locals me2 ?2 seq))
|
||||
(R e1
|
||||
[! ?1]
|
||||
[#:pattern ?form]
|
||||
[#:learn rs]
|
||||
[#:reductions (reductions-locals e1 locals)]
|
||||
[! ?2]
|
||||
[#:walk e2
|
||||
(list #'?form)
|
||||
(list e2)
|
||||
'macro])]))
|
||||
[#:walk e2 'macro])]))
|
||||
|
||||
;; reductions-locals : syntax (list-of LocalAction) -> (RS void)
|
||||
(define (reductions-locals stx locals)
|
||||
|
|
@ -409,23 +392,24 @@
|
|||
;; reductions-local : LocalAction -> (RS void)
|
||||
(define (reductions-local local)
|
||||
(match/with-derivation local
|
||||
[(struct local-expansion (e1 e2 me1 me2 for-stx? deriv))
|
||||
(reductions* deriv)]
|
||||
[(struct local-expansion/expr (e1 e2 me1 me2 for-stx? opaque deriv))
|
||||
[(struct local-expansion (e1 e2 me1 me2 deriv for-stx? lifted opaque))
|
||||
;; FIXME
|
||||
;; When lifted is present, need to locally rearrange lifts!
|
||||
(when (or lifted opaque)
|
||||
(fprintf (current-error-port)
|
||||
"reductions: local-expand-expr not fully implemented")
|
||||
(reductions* deriv)]
|
||||
"reductions: local-expand-expr not fully implemented"))
|
||||
(reductions* deriv me1)]
|
||||
[(struct local-lift (expr id))
|
||||
(RSadd (list (walk expr id 'local-lift))
|
||||
RSzero)]
|
||||
[(struct local-lift-end (decl))
|
||||
(RSadd (list (walk/mono decl 'module-lift))
|
||||
RSzero)]
|
||||
[(struct local-bind (bindrhs))
|
||||
[(struct local-bind (names bindrhs))
|
||||
(bind-syntaxes-reductions bindrhs)]))
|
||||
|
||||
;; list-reductions : ListDerivation -> (RS Stxs)
|
||||
(define (list-reductions ld)
|
||||
;; list-reductions : ListDerivation stxs -> (RS Stxs)
|
||||
(define (list-reductions ld init-es1)
|
||||
(match/with-derivation ld
|
||||
[(Wrap lderiv (es1 es2 ?1 derivs))
|
||||
(R es1
|
||||
|
|
@ -434,13 +418,13 @@
|
|||
[Expr (?form ...) derivs])]
|
||||
[#f (RSunit null)]))
|
||||
|
||||
;; block-reductions : BlockDerivation -> (RS Stxs)
|
||||
(define (block-reductions bd)
|
||||
;; block-reductions : BlockDerivation stxs -> (RS Stxs)
|
||||
(define (block-reductions bd init-es1)
|
||||
(match/with-derivation bd
|
||||
[(Wrap bderiv (es1 es2 pass1 trans pass2))
|
||||
(R es1
|
||||
[#:pattern ?form]
|
||||
[(BRules es1) ?form pass1]
|
||||
[BRules ?form pass1]
|
||||
[#:when/np (eq? trans 'letrec)
|
||||
[#:walk (wlderiv-es1 pass2) 'block->letrec]]
|
||||
[#:frontier (stx->list* (wlderiv-es1 pass2))]
|
||||
|
|
@ -448,8 +432,8 @@
|
|||
[List ?form pass2])]
|
||||
[#f (RSunit null)]))
|
||||
|
||||
;; mk-brules-reductions : stxs -> (list-of BRule) -> (RS Stxs)
|
||||
(define ((mk-brules-reductions es1) brules)
|
||||
;; brules-reductions : (list-of BRule) stxs -> (RS Stxs)
|
||||
(define (brules-reductions brules es1)
|
||||
(match brules
|
||||
['()
|
||||
(RSunit null)]
|
||||
|
|
@ -459,7 +443,7 @@
|
|||
[#:bind ?first* (cdr renames)]
|
||||
[#:rename/no-step ?first (car renames) (cdr renames)]
|
||||
[Expr ?first head]
|
||||
[(BRules (stx-cdr es1)) ?rest rest])]
|
||||
[BRules ?rest rest])]
|
||||
[(cons (Wrap b:defvals (renames head ?1)) rest)
|
||||
(R es1
|
||||
[#:pattern (?first . ?rest)]
|
||||
|
|
@ -469,7 +453,7 @@
|
|||
[! ?1]
|
||||
[#:pattern ((?define-values ?vars ?rhs) . ?rest)]
|
||||
[#:learn (syntax->list #'?vars)]
|
||||
[(BRules (stx-cdr es1)) ?rest rest])]
|
||||
[BRules ?rest rest])]
|
||||
[(cons (Wrap b:defstx (renames head ?1 bindrhs)) rest)
|
||||
(R es1
|
||||
[#:pattern (?first . ?rest)]
|
||||
|
|
@ -480,7 +464,7 @@
|
|||
[#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)]
|
||||
[#:learn (syntax->list #'?vars)]
|
||||
[BindSyntaxes ?rhs bindrhs]
|
||||
[(BRules (stx-cdr es1)) ?rest rest])]
|
||||
[BRules ?rest rest])]
|
||||
[(cons (Wrap b:splice (renames head ?1 tail ?2)) rest)
|
||||
(R es1
|
||||
[#:pattern (?first . ?rest)]
|
||||
|
|
@ -488,20 +472,20 @@
|
|||
[#:rename/no-step ?first (car renames) (cdr renames)]
|
||||
[Expr ?first head]
|
||||
[! ?1]
|
||||
[#:walk tail
|
||||
[#:walk/foci tail
|
||||
(list #'?first)
|
||||
(stx-take tail (- (stx-improper-length tail)
|
||||
(stx-improper-length #'?rest)))
|
||||
'splice-block]
|
||||
[! ?2]
|
||||
[#:pattern ?forms]
|
||||
[(BRules (stx->list* #'?forms)) ?forms rest])]
|
||||
[BRules ?forms rest])]
|
||||
[(cons (Wrap b:error (exn)) rest)
|
||||
(R es1
|
||||
[! exn])]))
|
||||
|
||||
;; bind-syntaxes-reductions : BindSyntaxes -> (RS stx)
|
||||
(define (bind-syntaxes-reductions bindrhs)
|
||||
;; bind-syntaxes-reductions : BindSyntaxes stx -> (RS stx)
|
||||
(define (bind-syntaxes-reductions bindrhs init-e1)
|
||||
(match bindrhs
|
||||
[(Wrap bind-syntaxes (rhs ?1))
|
||||
(R (wderiv-e1 rhs)
|
||||
|
|
@ -509,54 +493,58 @@
|
|||
[Expr ?form rhs]
|
||||
[! ?1])]))
|
||||
|
||||
;; mk-mbrules-reductions : stx -> (list-of MBRule) -> (RS stxs)
|
||||
(define ((mk-mbrules-reductions es1) mbrules)
|
||||
;; mbrules-reductions : -> (list-of MBRule) stxs -> (RS stxs)
|
||||
(define (mbrules-reductions mbrules es1)
|
||||
(match mbrules
|
||||
['()
|
||||
(RSunit null)]
|
||||
[(cons (Wrap mod:skip ()) rest)
|
||||
[(cons (Wrap mod:prim (head rename prim)) rest)
|
||||
(R es1
|
||||
[#:pattern (?first . ?rest)]
|
||||
[(ModulePass (stx-cdr es1)) ?rest rest])]
|
||||
[(cons (Wrap mod:cons (head)) rest)
|
||||
[#:pattern (?firstP . ?rest)]
|
||||
[Expr ?firstP head]
|
||||
[#:rename* ?firstP rename]
|
||||
[Expr ?firstP prim]
|
||||
[ModulePass ?rest rest])]
|
||||
[(cons (Wrap mod:splice (head rename ?1 tail)) rest)
|
||||
(R es1
|
||||
[#:pattern (?first . ?rest)]
|
||||
[Expr ?first head]
|
||||
[(ModulePass (stx-cdr es1)) ?rest rest])]
|
||||
[(cons (Wrap mod:prim (head prim)) rest)
|
||||
(R es1
|
||||
[#:pattern (?first . ?rest)]
|
||||
[Expr ?first head]
|
||||
[Expr ?first prim]
|
||||
[(ModulePass (stx-cdr es1)) ?rest rest])]
|
||||
[(cons (Wrap mod:splice (head ?1 tail)) rest)
|
||||
(R es1
|
||||
[#:pattern (?first . ?rest)]
|
||||
[Expr ?first head]
|
||||
[#:pattern (?firstB . ?rest)]
|
||||
[Expr ?firstB head]
|
||||
[#:rename* ?firstB rename]
|
||||
[! ?1]
|
||||
[#:walk tail
|
||||
(list #'?first)
|
||||
[#:walk/foci tail
|
||||
(list #'?firstB)
|
||||
(stx-take tail (- (stx-improper-length tail)
|
||||
(stx-improper-length #'?rest)))
|
||||
'splice-module]
|
||||
[#:pattern ?forms]
|
||||
[(ModulePass #'?forms) ?forms rest])]
|
||||
[(cons (Wrap mod:lift (head stxs)) rest)
|
||||
[ModulePass ?forms rest])]
|
||||
[(cons (Wrap mod:lift (head renames stxs)) rest)
|
||||
(R es1
|
||||
[#:pattern (?first . ?rest)]
|
||||
[Expr ?first head]
|
||||
[#:pattern (?firstL . ?rest)]
|
||||
[Expr ?firstL head]
|
||||
[#:pattern ?forms]
|
||||
[#:walk (append stxs #'?forms)
|
||||
[#:when/np renames
|
||||
[#:rename* ?forms renames]]
|
||||
[#:walk/foci (append stxs #'?forms)
|
||||
null
|
||||
stxs
|
||||
'splice-lifts]
|
||||
[(ModulePass #'?forms) ?forms rest])]
|
||||
[ModulePass ?forms rest])]
|
||||
[(cons (Wrap mod:lift-end (stxs)) rest)
|
||||
(R es1
|
||||
[#:pattern ?forms]
|
||||
[#:when/np (pair? stxs)
|
||||
[#:walk (append stxs #'?forms)
|
||||
[#:walk/foci (append stxs #'?forms)
|
||||
null
|
||||
stxs
|
||||
'splice-module-lifts]]
|
||||
[(ModulePass #'?forms) ?forms rest])]))
|
||||
[ModulePass ?forms rest])]
|
||||
[(cons (Wrap mod:skip ()) rest)
|
||||
(R es1
|
||||
[#:pattern (?firstS . ?rest)]
|
||||
[ModulePass ?rest rest])]
|
||||
[(cons (Wrap mod:cons (head)) rest)
|
||||
(R es1
|
||||
[#:pattern (?firstC . ?rest)]
|
||||
[Expr ?firstC head]
|
||||
[ModulePass ?rest rest])]))
|
||||
|
|
|
|||
|
|
@ -87,6 +87,7 @@
|
|||
(tag-datum . "Tag datum")
|
||||
(tag-top . "Tag top-level variable")
|
||||
(capture-lifts . "Capture lifts")
|
||||
(provide . "Expand provide-specs")
|
||||
|
||||
(local-lift . "Macro lifted expression to top-level")
|
||||
(module-lift . "Macro lifted declaration to end of module")
|
||||
|
|
|
|||
|
|
@ -234,6 +234,11 @@
|
|||
(define wrap?
|
||||
(let ([wrap? (assq '#:wrap options)]
|
||||
[no-wrap? (assq '#:no-wrap options)])
|
||||
(when (and wrap? no-wrap?)
|
||||
(raise-syntax-error 'split
|
||||
"cannot specify both #:wrap and #:no-wrap"
|
||||
stx))
|
||||
#;
|
||||
(unless (and (or wrap? no-wrap?) (not (and wrap? no-wrap?)))
|
||||
(raise-syntax-error 'split
|
||||
"must specify exactly one of #:wrap, #:no-wrap"
|
||||
|
|
|
|||
|
|
@ -6,7 +6,6 @@
|
|||
"model/reductions.ss"
|
||||
"model/steps.ss"
|
||||
"model/hide.ss"
|
||||
"model/hiding-policies.ss"
|
||||
"syntax-browser/partition.ss"
|
||||
"syntax-browser/pretty-helper.ss")
|
||||
(provide expand/step-text
|
||||
|
|
@ -125,8 +124,6 @@
|
|||
(lambda (id)
|
||||
(ormap (lambda (x) (free-identifier=? x id))
|
||||
show))]
|
||||
[(hiding-policy? show)
|
||||
(lambda (x) (policy-show-macro? show x))]
|
||||
[(eq? show #f)
|
||||
#f]
|
||||
[else
|
||||
|
|
|
|||
|
|
@ -176,11 +176,6 @@
|
|||
(let ([end (get-end-position)])
|
||||
;; Pretty printer always inserts final newline; we remove it here.
|
||||
(send text delete (sub1 end) end))
|
||||
;; Set font to standard
|
||||
(send text change-style
|
||||
(code-style text)
|
||||
(get-start-position)
|
||||
(get-end-position))
|
||||
(let ([offset (get-start-position)])
|
||||
(fixup-parentheses text range offset)
|
||||
(for-each
|
||||
|
|
@ -191,8 +186,13 @@
|
|||
(send text set-clickback (+ offset start) (+ offset end)
|
||||
(lambda (_1 _2 _3)
|
||||
(send controller set-selected-syntax stx)))))
|
||||
(send range all-ranges))
|
||||
range)))
|
||||
(send range all-ranges)))
|
||||
;; Set font to standard
|
||||
(send text change-style
|
||||
(code-style text)
|
||||
(get-start-position)
|
||||
(get-end-position))
|
||||
range))
|
||||
|
||||
;; fixup-parentheses : text range -> void
|
||||
(define (fixup-parentheses text range offset)
|
||||
|
|
|
|||
|
|
@ -4,35 +4,73 @@
|
|||
scheme/gui
|
||||
"interfaces.ss"
|
||||
"partition.ss")
|
||||
(provide syntax-keymap%
|
||||
context-menu%)
|
||||
(provide smart-keymap%
|
||||
syntax-keymap%)
|
||||
|
||||
(define syntax-keymap%
|
||||
(define smart-keymap%
|
||||
(class keymap%
|
||||
(init editor)
|
||||
(init-field controller)
|
||||
|
||||
(inherit add-function
|
||||
map-function
|
||||
chain-to-keymap)
|
||||
|
||||
(super-new)
|
||||
|
||||
(define/public (get-context-menu%)
|
||||
context-menu%)
|
||||
smart-context-menu%)
|
||||
|
||||
(define/public (make-context-menu)
|
||||
(new (get-context-menu%) (controller controller) (keymap this)))
|
||||
|
||||
;; Key mappings
|
||||
(field (the-context-menu #f))
|
||||
(set! the-context-menu (new (get-context-menu%)))
|
||||
|
||||
(map-function "rightbutton" "popup-context-window")
|
||||
|
||||
;; Functionality
|
||||
|
||||
(add-function "popup-context-window"
|
||||
(lambda (editor event)
|
||||
(do-popup-context-window editor event)))
|
||||
|
||||
(chain-to-keymap (send editor get-keymap) #t)
|
||||
(send editor set-keymap this)
|
||||
|
||||
(define/private (do-popup-context-window editor event)
|
||||
(define-values (x y)
|
||||
(send editor dc-location-to-editor-location
|
||||
(send event get-x)
|
||||
(send event get-y)))
|
||||
(define admin (send editor get-admin))
|
||||
(send admin popup-menu the-context-menu x y))
|
||||
|
||||
))
|
||||
|
||||
(define smart-context-menu%
|
||||
(class popup-menu%
|
||||
(define on-demand-actions null)
|
||||
(define/public (add-on-demand p)
|
||||
(set! on-demand-actions (cons p on-demand-actions)))
|
||||
|
||||
(define/override (on-demand)
|
||||
(for-each (lambda (p) (p)) on-demand-actions))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define syntax-keymap%
|
||||
(class smart-keymap%
|
||||
(init-field controller
|
||||
config)
|
||||
|
||||
(inherit add-function
|
||||
map-function
|
||||
call-function
|
||||
chain-to-keymap)
|
||||
(inherit-field the-context-menu)
|
||||
(field [copy-menu #f]
|
||||
[clear-menu #f]
|
||||
[props-menu #f])
|
||||
(super-new)
|
||||
|
||||
;; Functionality
|
||||
|
||||
(define/public (get-controller) controller)
|
||||
|
||||
(add-function "copy-text"
|
||||
(lambda (_ event)
|
||||
(define stx (send controller get-selected-syntax))
|
||||
|
|
@ -48,38 +86,17 @@
|
|||
|
||||
(add-function "show-syntax-properties"
|
||||
(lambda (i e)
|
||||
(error 'show-syntax-properties "not provided by this keymap")))
|
||||
(send config set-props-shown? #t)))
|
||||
|
||||
;; Attach to editor
|
||||
|
||||
(chain-to-keymap (send editor get-keymap) #t)
|
||||
(send editor set-keymap this)
|
||||
|
||||
(define/public (get-controller) controller)
|
||||
|
||||
(define/private (do-popup-context-window editor event)
|
||||
(define-values (x y)
|
||||
(send editor dc-location-to-editor-location
|
||||
(send event get-x)
|
||||
(send event get-y)))
|
||||
(define admin (send editor get-admin))
|
||||
(send admin popup-menu (make-context-menu) x y))))
|
||||
|
||||
(define context-menu%
|
||||
(class popup-menu%
|
||||
(init-field keymap)
|
||||
(init-field controller)
|
||||
(super-new)
|
||||
|
||||
(field [copy-menu #f]
|
||||
[clear-menu #f]
|
||||
[props-menu #f])
|
||||
(add-function "hide-syntax-properties"
|
||||
(lambda (i e)
|
||||
(send config set-props-shown? #f)))
|
||||
|
||||
(define/public (add-edit-items)
|
||||
(set! copy-menu
|
||||
(new menu-item% (label "Copy") (parent this)
|
||||
(new menu-item% (label "Copy") (parent the-context-menu)
|
||||
(callback (lambda (i e)
|
||||
(send keymap call-function "copy-text" i e)))))
|
||||
(call-function "copy-text" i e)))))
|
||||
(void))
|
||||
|
||||
(define/public (after-edit-items)
|
||||
|
|
@ -89,24 +106,26 @@
|
|||
(set! clear-menu
|
||||
(new menu-item%
|
||||
(label "Clear selection")
|
||||
(parent this)
|
||||
(parent the-context-menu)
|
||||
(callback
|
||||
(lambda (i e)
|
||||
(send keymap call-function "clear-syntax-selection" i e)))))
|
||||
(call-function "clear-syntax-selection" i e)))))
|
||||
(set! props-menu
|
||||
(new menu-item%
|
||||
(label "Show syntax properties")
|
||||
(parent this)
|
||||
(parent the-context-menu)
|
||||
(callback
|
||||
(lambda (i e)
|
||||
(send keymap call-function "show-syntax-properties" i e)))))
|
||||
(if (send config get-props-shown?)
|
||||
(call-function "hide-syntax-properties" i e)
|
||||
(call-function "show-syntax-properties" i e))))))
|
||||
(void))
|
||||
|
||||
(define/public (after-selection-items)
|
||||
(void))
|
||||
|
||||
(define/public (add-partition-items)
|
||||
(let ([secondary (new menu% (label "identifier=?") (parent this))])
|
||||
(let ([secondary (new menu% (label "identifier=?") (parent the-context-menu))])
|
||||
(for-each
|
||||
(lambda (name func)
|
||||
(let ([this-choice
|
||||
|
|
@ -128,15 +147,10 @@
|
|||
(void))
|
||||
|
||||
(define/public (add-separator)
|
||||
(new separator-menu-item% (parent this)))
|
||||
(new separator-menu-item% (parent the-context-menu)))
|
||||
|
||||
(define/override (on-demand)
|
||||
(define stx (send controller get-selected-syntax))
|
||||
(send copy-menu enable (and stx #t))
|
||||
(send clear-menu enable (and stx #t))
|
||||
(super on-demand))
|
||||
;; Initialize menu
|
||||
|
||||
;; Initialization
|
||||
(add-edit-items)
|
||||
(after-edit-items)
|
||||
|
||||
|
|
@ -147,4 +161,15 @@
|
|||
(add-separator)
|
||||
(add-partition-items)
|
||||
(after-partition-items)
|
||||
))
|
||||
|
||||
(send the-context-menu add-on-demand
|
||||
(lambda ()
|
||||
(define stx (send controller get-selected-syntax))
|
||||
(send copy-menu enable (and stx #t))
|
||||
(send clear-menu enable (and stx #t))))
|
||||
(send config listen-props-shown?
|
||||
(lambda (shown?)
|
||||
(send props-menu set-label
|
||||
(if shown?
|
||||
"Hide syntax properties"
|
||||
"Show syntax properties"))))))
|
||||
|
|
|
|||
|
|
@ -3,11 +3,15 @@
|
|||
(require scheme/class
|
||||
framework/framework
|
||||
"interfaces.ss"
|
||||
"../util/notify.ss"
|
||||
"../util/misc.ss")
|
||||
(provide syntax-prefs%
|
||||
syntax-prefs-mixin
|
||||
syntax-prefs/readonly%
|
||||
|
||||
pref:tabify)
|
||||
#;pref:tabify
|
||||
#;pref:height
|
||||
#;pref:width
|
||||
#;pref:props-percentage)
|
||||
|
||||
(preferences:set-default 'SyntaxBrowser:Width 700 number?)
|
||||
(preferences:set-default 'SyntaxBrowser:Height 600 number?)
|
||||
|
|
@ -18,14 +22,28 @@
|
|||
(pref:get/set pref:height SyntaxBrowser:Height)
|
||||
(pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage)
|
||||
(pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown)
|
||||
|
||||
(pref:get/set pref:tabify framework:tabify)
|
||||
|
||||
(define syntax-prefs-mixin
|
||||
(closure-mixin (syntax-prefs<%>)
|
||||
(pref:width pref:width)
|
||||
(pref:height pref:height)
|
||||
(pref:props-percentage pref:props-percentage)
|
||||
(pref:props-shown? pref:props-shown?)))
|
||||
(define syntax-prefs-base%
|
||||
(class object%
|
||||
(notify-methods width)
|
||||
(notify-methods height)
|
||||
(notify-methods props-percentage)
|
||||
(notify-methods props-shown?)
|
||||
(super-new)))
|
||||
|
||||
(define syntax-prefs% (syntax-prefs-mixin object%))
|
||||
(define syntax-prefs%
|
||||
(class syntax-prefs-base%
|
||||
(connect-to-pref width pref:width)
|
||||
(connect-to-pref height pref:height)
|
||||
(connect-to-pref props-percentage pref:props-percentage)
|
||||
(connect-to-pref props-shown? pref:props-shown?)
|
||||
(super-new)))
|
||||
|
||||
(define syntax-prefs/readonly%
|
||||
(class syntax-prefs-base%
|
||||
(connect-to-pref/readonly width pref:width)
|
||||
(connect-to-pref/readonly height pref:height)
|
||||
(connect-to-pref/readonly props-percentage pref:props-percentage)
|
||||
(connect-to-pref/readonly props-shown? pref:props-shown?)
|
||||
(super-new)))
|
||||
|
|
|
|||
|
|
@ -85,6 +85,8 @@
|
|||
[else #f]))
|
||||
|
||||
(define (pp-better-style-table)
|
||||
(basic-style-list)
|
||||
#; ;; Messes up formatting too much :(
|
||||
(let* ([pref (pref:tabify)]
|
||||
[table (car pref)]
|
||||
[begin-rx (cadr pref)]
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
(require scheme/class
|
||||
scheme/gui
|
||||
"interfaces.ss"
|
||||
"util.ss")
|
||||
"util.ss"
|
||||
"../util/mpi.ss")
|
||||
(provide properties-view%
|
||||
properties-snip%)
|
||||
|
||||
|
|
|
|||
|
|
@ -6,26 +6,57 @@
|
|||
mzlib/match
|
||||
mzlib/list
|
||||
mzlib/string
|
||||
"../util/notify.ss"
|
||||
"interfaces.ss"
|
||||
"display.ss"
|
||||
"controller.ss"
|
||||
"keymap.ss"
|
||||
"properties.ss"
|
||||
"partition.ss")
|
||||
"partition.ss"
|
||||
"prefs.ss")
|
||||
|
||||
(provide syntax-value-snip%)
|
||||
(provide syntax-snip%
|
||||
syntax-value-snip%)
|
||||
|
||||
(define syntax-snip-config-base%
|
||||
(class object%
|
||||
(notify-methods props-shown?)
|
||||
(super-new)))
|
||||
(define syntax-snip-config%
|
||||
(class syntax-snip-config-base%
|
||||
(define/override (init-props-shown?) (new notify-box% (value #f)))
|
||||
(super-new)))
|
||||
|
||||
(define dumb-host%
|
||||
(class object%
|
||||
(define controller (new controller%))
|
||||
(define config (new syntax-snip-config%))
|
||||
(super-new)
|
||||
(define/public (get-controller) controller)
|
||||
(define/public (get-config) config)
|
||||
(define/public (add-keymap text snip)
|
||||
(send text set-keymap
|
||||
(new syntax-keymap%
|
||||
(controller controller)
|
||||
(editor text)
|
||||
(config config))))))
|
||||
|
||||
;; syntax-value-snip%
|
||||
(define syntax-value-snip%
|
||||
(class* editor-snip% (readable-snip<%>)
|
||||
(init-field ((stx syntax)))
|
||||
(init-field host)
|
||||
(init-field (host (new dumb-host%)))
|
||||
(inherit set-margin
|
||||
set-inset)
|
||||
|
||||
(define text (new text:standard-style-list%))
|
||||
(super-new (editor text) (with-border? #f))
|
||||
|
||||
(set-margin 0 0 0 0)
|
||||
(set-inset 2 2 2 2)
|
||||
;;(set-inset 2 2 2 2)
|
||||
;;(set-margin 2 2 2 2)
|
||||
(set-inset 0 0 0 0)
|
||||
|
||||
(send text begin-edit-sequence)
|
||||
(send text change-style (make-object style-delta% 'change-alignment 'top))
|
||||
(define display
|
||||
|
|
@ -48,12 +79,18 @@
|
|||
#'(p)))
|
||||
))
|
||||
|
||||
;; syntax-snip%
|
||||
#;
|
||||
(define syntax-snip%
|
||||
(class* editor-snip% (readable-snip<%>)
|
||||
(init-field ((stx syntax)))
|
||||
(init-field primary-partition)
|
||||
(define top-aligned
|
||||
(make-object style-delta% 'change-alignment 'top))
|
||||
|
||||
(define-struct styled (contents style clickback))
|
||||
|
||||
;; clicky-snip%
|
||||
(define clicky-snip%
|
||||
(class* editor-snip% ()
|
||||
|
||||
(init-field [open-style '(border)]
|
||||
[closed-style '(tight-text-fit)])
|
||||
|
||||
(inherit set-margin
|
||||
set-inset
|
||||
set-snipclass
|
||||
|
|
@ -61,76 +98,54 @@
|
|||
show-border
|
||||
get-admin)
|
||||
|
||||
(define properties-snip (new properties-snip%))
|
||||
|
||||
(define -outer (new text%))
|
||||
(super-new (editor -outer) (with-border? #f))
|
||||
(set-margin 0 0 0 0)
|
||||
(set-inset 0 0 0 0)
|
||||
(set-snipclass snip-class)
|
||||
(send -outer select-all)
|
||||
(set-margin 2 2 2 2)
|
||||
(set-inset 2 2 2 2)
|
||||
;;(set-margin 3 0 0 0)
|
||||
;;(set-inset 1 0 0 0)
|
||||
;;(set-margin 0 0 0 0)
|
||||
;;(set-inset 0 0 0 0)
|
||||
|
||||
(define the-syntax-snip
|
||||
(new syntax-value-snip%
|
||||
(syntax stx)
|
||||
(controller controller)
|
||||
;; FIXME
|
||||
#;(syntax-keymap% syntax-keymap%)
|
||||
))
|
||||
(define the-summary
|
||||
(let ([line (syntax-line stx)]
|
||||
[col (syntax-column stx)])
|
||||
(if (and line col)
|
||||
(format "#<syntax:~s:~s>" line col)
|
||||
"#<syntax>")))
|
||||
(define/public (closed-contents) null)
|
||||
(define/public (open-contents) null)
|
||||
|
||||
(define shown? #f)
|
||||
(define/public (refresh)
|
||||
(if shown?
|
||||
(refresh/shown)
|
||||
(refresh/hidden)))
|
||||
(define open? #f)
|
||||
|
||||
(define/private (refresh/hidden)
|
||||
(define/public (refresh-contents)
|
||||
(send* -outer
|
||||
(begin-edit-sequence)
|
||||
(lock #f)
|
||||
(erase))
|
||||
(set-tight-text-fit #t)
|
||||
(show-border #f)
|
||||
(outer:insert (show-icon) style:hyper
|
||||
(lambda _ (set! shown? #t) (refresh)))
|
||||
(outer:insert the-summary)
|
||||
(do-style (if open? open-style closed-style))
|
||||
(outer:insert (if open? (hide-icon) (show-icon))
|
||||
style:hyper
|
||||
(if open?
|
||||
(lambda _
|
||||
(set! open? #f)
|
||||
(refresh-contents))
|
||||
(lambda _
|
||||
(set! open? #t)
|
||||
(refresh-contents))))
|
||||
(for-each (lambda (s) (outer:insert s))
|
||||
(if open? (open-contents) (closed-contents)))
|
||||
(send* -outer
|
||||
(change-style top-aligned 0 (send -outer last-position))
|
||||
(lock #t)
|
||||
(end-edit-sequence)))
|
||||
|
||||
(define/private (refresh/shown)
|
||||
(send* -outer
|
||||
(begin-edit-sequence)
|
||||
(lock #f)
|
||||
(erase))
|
||||
(set-tight-text-fit #f)
|
||||
(show-border #t)
|
||||
(outer:insert (hide-icon) style:hyper
|
||||
(lambda _ (set! shown? #f) (refresh)))
|
||||
(outer:insert " ")
|
||||
(outer:insert the-syntax-snip)
|
||||
(outer:insert " ")
|
||||
(if (props-shown?)
|
||||
(begin (outer:insert "<" style:green (lambda _ (show #f)))
|
||||
(outer:insert properties-snip))
|
||||
(begin (outer:insert ">" style:green (lambda _ (show #t)))))
|
||||
(send* -outer
|
||||
(change-style (make-object style-delta% 'change-alignment 'top)
|
||||
0
|
||||
(send -outer last-position))
|
||||
(lock #t)
|
||||
(end-edit-sequence)))
|
||||
(define/private (do-style style)
|
||||
(show-border (memq 'border style))
|
||||
(set-tight-text-fit (memq 'tight-text-fit style)))
|
||||
|
||||
(define/private outer:insert
|
||||
(case-lambda
|
||||
[(obj)
|
||||
(outer:insert obj style:normal)]
|
||||
(if (styled? obj)
|
||||
(outer:insert (styled-contents obj)
|
||||
(styled-style obj)
|
||||
(styled-clickback obj))
|
||||
(outer:insert obj style:normal))]
|
||||
[(text style)
|
||||
(outer:insert text style #f)]
|
||||
[(text style clickback)
|
||||
|
|
@ -141,78 +156,78 @@
|
|||
(when clickback
|
||||
(send -outer set-clickback start end clickback))))]))
|
||||
|
||||
(send -outer hide-caret #t)
|
||||
(send -outer lock #t)
|
||||
(refresh-contents)
|
||||
))
|
||||
|
||||
;; syntax-snip%
|
||||
(define syntax-snip%
|
||||
(class* clicky-snip% (readable-snip<%>)
|
||||
(init-field ((stx syntax)))
|
||||
(init-field (host (new dumb-host%)))
|
||||
(define config (send host get-config))
|
||||
(inherit set-snipclass
|
||||
refresh-contents)
|
||||
|
||||
(define the-syntax-snip
|
||||
(new syntax-value-snip%
|
||||
(syntax stx)
|
||||
(host host)))
|
||||
(define the-summary
|
||||
(let* ([t (new text%)]
|
||||
[es (new editor-snip% (editor t) (with-border? #f))])
|
||||
(send es set-margin 0 0 0 0)
|
||||
(send es set-inset 0 0 0 0)
|
||||
(send t insert (format "~s" stx))
|
||||
es))
|
||||
|
||||
(define properties-snip
|
||||
(new properties-container-snip%
|
||||
(controller (send host get-controller))))
|
||||
|
||||
(define/override (closed-contents)
|
||||
(list the-summary))
|
||||
|
||||
(define/override (open-contents)
|
||||
(list " "
|
||||
the-syntax-snip
|
||||
" "
|
||||
properties-snip))
|
||||
|
||||
;; Snip methods
|
||||
(define/override (copy)
|
||||
(new syntax-snip% (syntax stx)))
|
||||
(define/override (write stream)
|
||||
(send stream put (string->bytes/utf-8 (format "~s" (marshall-syntax stx)))))
|
||||
(send stream put
|
||||
(string->bytes/utf-8
|
||||
(format "~s" (marshall-syntax stx)))))
|
||||
(define/public (read-special src line col pos)
|
||||
(send the-syntax-snip read-special src line col pos))
|
||||
|
||||
(define/private (find-primary-partition)
|
||||
#;(define editor (send (get-admin) get-editor))
|
||||
(new-bound-partition))
|
||||
(send config listen-props-shown?
|
||||
(lambda (?) (refresh-contents)))
|
||||
|
||||
(super-new)
|
||||
(set-snipclass snip-class)))
|
||||
|
||||
|
||||
;; syntax-properties-controller methods
|
||||
(define properties-shown? #f)
|
||||
(define/public (props-shown?)
|
||||
properties-shown?)
|
||||
(define/public (show ?)
|
||||
(set! properties-shown? ?)
|
||||
(refresh))
|
||||
(define/public (set-syntax stx)
|
||||
(send properties-snip set-syntax stx))
|
||||
(define properties-container-snip%
|
||||
(class clicky-snip%
|
||||
(init controller)
|
||||
|
||||
(refresh)
|
||||
(send -outer hide-caret #t)
|
||||
(send -outer lock #t)
|
||||
))
|
||||
(define properties-snip
|
||||
(new properties-snip% (controller controller)))
|
||||
|
||||
;; independent-properties-controller%
|
||||
#;
|
||||
(define independent-properties-controller%
|
||||
(class* object% (syntax-properties-controller<%>)
|
||||
(init-field controller)
|
||||
(init-field ((stx syntax) #f))
|
||||
|
||||
;; Properties display
|
||||
(define parent
|
||||
(new frame% (label "Properties") (height (pref:height))
|
||||
(width (floor (* (pref:props-percentage) (pref:width))))))
|
||||
(define pv (new properties-view% (parent parent)))
|
||||
|
||||
(define/private (show-properties)
|
||||
(unless (send parent is-shown?)
|
||||
(send parent show #t)))
|
||||
|
||||
(define/public (set-syntax stx)
|
||||
(send pv set-syntax stx))
|
||||
(define/public (show ?)
|
||||
(send parent show ?))
|
||||
(define/public (props-shown?)
|
||||
(send parent is-shown?))
|
||||
|
||||
(super-new)))
|
||||
|
||||
|
||||
#;
|
||||
(define snip-keymap-extension@
|
||||
(unit
|
||||
(import (prefix pre: keymap^))
|
||||
(export keymap^)
|
||||
|
||||
(define syntax-keymap%
|
||||
(class pre:syntax-keymap%
|
||||
(init-field snip)
|
||||
(inherit add-function)
|
||||
(super-new (controller (send snip get-controller)))
|
||||
|
||||
(add-function "show-syntax-properties"
|
||||
(lambda (i e)
|
||||
(send snip show-props)))))))
|
||||
(define/override (open-contents)
|
||||
(list #;(show-properties-icon)
|
||||
properties-snip))
|
||||
|
||||
(define/override (closed-contents)
|
||||
(list (show-properties-icon)))
|
||||
|
||||
(super-new (open-style '())
|
||||
(closed-style '()))))
|
||||
|
||||
(define style:normal (make-object style-delta% 'change-normal))
|
||||
(define style:hyper
|
||||
|
|
@ -276,7 +291,6 @@
|
|||
[else (string->symbol (format "unknown-object: ~s" obj))]))
|
||||
|
||||
;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
|
||||
#;
|
||||
(define syntax-snipclass%
|
||||
(class snip-class%
|
||||
(define/override (read stream)
|
||||
|
|
@ -284,11 +298,11 @@
|
|||
(unmarshall-syntax (read-from-string (send stream get-bytes)))))
|
||||
(super-instantiate ())))
|
||||
|
||||
#;(define snip-class (make-object syntax-snipclass%))
|
||||
#;(send snip-class set-version 2)
|
||||
#;(send snip-class set-classname
|
||||
(define snip-class (make-object syntax-snipclass%))
|
||||
(send snip-class set-version 2)
|
||||
(send snip-class set-classname
|
||||
(format "~s" '(lib "implementation.ss" "macro-debugger" "syntax-browser")))
|
||||
#;(send (get-the-snip-class-list) add snip-class)
|
||||
(send (get-the-snip-class-list) add snip-class)
|
||||
|
||||
(define (unmarshall-syntax stx)
|
||||
(match stx
|
||||
|
|
|
|||
|
|
@ -2,9 +2,7 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class)
|
||||
(provide with-unlock
|
||||
make-text-port
|
||||
mpi->string
|
||||
mpi->list)
|
||||
make-text-port)
|
||||
|
||||
;; with-unlock SYNTAX (expression)
|
||||
;; (with-unlock text-expression . body)
|
||||
|
|
@ -31,29 +29,3 @@
|
|||
(lambda (special buffer? enable-break?)
|
||||
(send text insert special (end-position))
|
||||
#t)))
|
||||
|
||||
;; mpi->string : module-path-index -> string
|
||||
(define (mpi->string mpi)
|
||||
(if (module-path-index? mpi)
|
||||
(let ([mps (mpi->list mpi)])
|
||||
(cond [(and (pair? mps) (pair? (cdr mps)))
|
||||
(apply string-append
|
||||
(format "~s" (car mps))
|
||||
(map (lambda (x) (format " <= ~s" x)) (cdr mps)))]
|
||||
[(and (pair? mps) (null? (cdr mps)))
|
||||
(format "~s" (car mps))]
|
||||
[(null? mps) "this module"]))
|
||||
(format "~s" mpi)))
|
||||
|
||||
;; mpi->list : module-path-index -> (list-of module-spec)
|
||||
(define (mpi->list mpi)
|
||||
(cond [(module-path-index? mpi)
|
||||
(let-values ([(path rel) (module-path-index-split mpi)])
|
||||
(cond [(and (pair? path) (memq (car path) '(file lib planet)))
|
||||
(cons path null)]
|
||||
[path
|
||||
(cons path (mpi->list rel))]
|
||||
[else '()]))]
|
||||
[(not mpi)
|
||||
'()]
|
||||
[else (list mpi)]))
|
||||
|
|
|
|||
|
|
@ -16,9 +16,7 @@
|
|||
"properties.ss"
|
||||
"text.ss"
|
||||
"util.ss")
|
||||
(provide widget%
|
||||
widget-keymap%
|
||||
widget-context-menu%)
|
||||
(provide widget%)
|
||||
|
||||
;; widget%
|
||||
;; A syntax widget creates its own syntax-controller.
|
||||
|
|
@ -27,7 +25,7 @@
|
|||
(init parent)
|
||||
(init-field config)
|
||||
|
||||
(define controller (new controller%))
|
||||
(field [controller (new controller%)])
|
||||
|
||||
(define -main-panel
|
||||
(new vertical-panel% (parent parent)))
|
||||
|
|
@ -41,19 +39,15 @@
|
|||
(new properties-view%
|
||||
(parent -props-panel)
|
||||
(controller controller)))
|
||||
(define props-percentage (send config pref:props-percentage))
|
||||
|
||||
(define/public (setup-keymap)
|
||||
(new widget-keymap%
|
||||
(new syntax-keymap%
|
||||
(editor -text)
|
||||
(widget this)))
|
||||
(config config)))
|
||||
|
||||
(send -text set-styles-sticky #f)
|
||||
(send -text lock #t)
|
||||
|
||||
(send -split-panel set-percentages
|
||||
(list (- 1 props-percentage) props-percentage))
|
||||
|
||||
;; syntax-properties-controller<%> methods
|
||||
|
||||
(define/public (props-shown?)
|
||||
|
|
@ -65,16 +59,25 @@
|
|||
(define/public (show-props show?)
|
||||
(if show?
|
||||
(unless (send -props-panel is-shown?)
|
||||
(let ([p (send config get-props-percentage)])
|
||||
(send -split-panel add-child -props-panel)
|
||||
(send -split-panel set-percentages
|
||||
(list (- 1 props-percentage) props-percentage))
|
||||
(update-props-percentage p))
|
||||
(send -props-panel show #t))
|
||||
(when (send -props-panel is-shown?)
|
||||
(set! props-percentage
|
||||
(cadr (send -split-panel get-percentages)))
|
||||
(send -split-panel delete-child -props-panel)
|
||||
(send -props-panel show #f))))
|
||||
|
||||
(send config listen-props-percentage
|
||||
(lambda (p)
|
||||
(update-props-percentage p)))
|
||||
(send config listen-props-shown?
|
||||
(lambda (show?)
|
||||
(show-props show?)))
|
||||
|
||||
(define/private (update-props-percentage p)
|
||||
(send -split-panel set-percentages
|
||||
(list (- 1 p) p)))
|
||||
|
||||
;;
|
||||
|
||||
(define/public (get-controller) controller)
|
||||
|
|
@ -84,8 +87,9 @@
|
|||
(define/public (get-main-panel) -main-panel)
|
||||
|
||||
(define/public (shutdown)
|
||||
(unless (= props-percentage (send config pref:props-percentage))
|
||||
(send config pref:props-percentage props-percentage)))
|
||||
(when (props-shown?)
|
||||
(send config set-props-percentage
|
||||
(cadr (send -split-panel get-percentages)))))
|
||||
|
||||
;; syntax-browser<%> Methods
|
||||
|
||||
|
|
@ -215,35 +219,6 @@
|
|||
|
||||
;; Specialized classes for widget
|
||||
|
||||
(define widget-keymap%
|
||||
(class syntax-keymap%
|
||||
(init-field widget)
|
||||
(super-new (controller (send widget get-controller)))
|
||||
(inherit add-function)
|
||||
(inherit-field controller)
|
||||
|
||||
(define/override (get-context-menu%)
|
||||
widget-context-menu%)
|
||||
|
||||
(add-function "show-syntax-properties"
|
||||
(lambda (i e)
|
||||
(send widget toggle-props)))
|
||||
|
||||
(define/public (get-widget) widget)))
|
||||
|
||||
(define widget-context-menu%
|
||||
(class 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?)
|
||||
"Hide syntax properties"
|
||||
"Show syntax properties"))
|
||||
(super on-demand))
|
||||
(super-new)))
|
||||
|
||||
(define browser-text%
|
||||
(class (text:arrows-mixin
|
||||
(text:tacking-mixin
|
||||
|
|
|
|||
23
collects/macro-debugger/util/mpi.ss
Normal file
23
collects/macro-debugger/util/mpi.ss
Normal file
|
|
@ -0,0 +1,23 @@
|
|||
#lang scheme/base
|
||||
(provide mpi->list
|
||||
mpi->string)
|
||||
|
||||
(define (mpi->list mpi)
|
||||
(cond [(module-path-index? mpi)
|
||||
(let-values ([(path relto) (module-path-index-split mpi)])
|
||||
(cond [(not path) null]
|
||||
[(not relto) (list path)]
|
||||
[else (cons path (mpi->list relto))]))]
|
||||
[(not mpi) null]
|
||||
[else (list mpi)]))
|
||||
|
||||
;; mpi->string : module-path-index -> string
|
||||
(define (mpi->string mpi)
|
||||
(if (module-path-index? mpi)
|
||||
(let ([mps (mpi->list mpi)])
|
||||
(cond [(pair? mps)
|
||||
(apply string-append
|
||||
(format "~s" (car mps))
|
||||
(map (lambda (x) (format " <= ~s" x)) (cdr mps)))]
|
||||
[(null? mps) "this module"]))
|
||||
(format "~s" mpi)))
|
||||
|
|
@ -14,7 +14,7 @@
|
|||
(write (map serialize-context-frame
|
||||
(continuation-mark-set->context
|
||||
(exn-continuation-marks exn)))))
|
||||
'replace))
|
||||
#:exists 'replace))
|
||||
|
||||
(define (serialize-datum d)
|
||||
(cond [(number? d) `(quote ,d)]
|
||||
|
|
|
|||
|
|
@ -12,6 +12,7 @@
|
|||
"warning.ss"
|
||||
"hiding-panel.ss"
|
||||
(prefix-in s: "../syntax-browser/widget.ss")
|
||||
(prefix-in s: "../syntax-browser/keymap.ss")
|
||||
"../model/deriv.ss"
|
||||
"../model/deriv-util.ss"
|
||||
"../model/trace.ss"
|
||||
|
|
@ -20,22 +21,24 @@
|
|||
"cursor.ss"
|
||||
"../util/notify.ss")
|
||||
(provide stepper-keymap%
|
||||
stepper-context-menu%
|
||||
stepper-syntax-widget%)
|
||||
|
||||
;; Extensions
|
||||
|
||||
(define stepper-keymap%
|
||||
(class s:widget-keymap%
|
||||
(class s:syntax-keymap%
|
||||
(init-field macro-stepper)
|
||||
(inherit-field controller)
|
||||
(inherit add-function)
|
||||
(inherit-field config
|
||||
controller
|
||||
the-context-menu)
|
||||
(inherit add-function
|
||||
call-function)
|
||||
|
||||
(define show-macro #f)
|
||||
(define hide-macro #f)
|
||||
|
||||
(super-new)
|
||||
|
||||
(define/override (get-context-menu%)
|
||||
stepper-context-menu%)
|
||||
|
||||
(define/public (get-hiding-panel)
|
||||
(send macro-stepper get-macro-hiding-prefs))
|
||||
|
||||
|
|
@ -49,49 +52,45 @@
|
|||
(lambda (i e)
|
||||
(send* (get-hiding-panel)
|
||||
(add-hide-identifier)
|
||||
(refresh))))))
|
||||
(refresh))))
|
||||
|
||||
;; Menu
|
||||
|
||||
(define stepper-context-menu%
|
||||
(class s:widget-context-menu%
|
||||
(inherit-field keymap)
|
||||
(inherit add-separator)
|
||||
|
||||
(field [show-macro #f]
|
||||
[hide-macro #f])
|
||||
|
||||
(define/override (after-selection-items)
|
||||
(super after-selection-items)
|
||||
(add-separator)
|
||||
(set! show-macro
|
||||
(new menu-item% (label "Show this macro") (parent this)
|
||||
(new menu-item% (label "Show selected identifier") (parent the-context-menu)
|
||||
(callback (lambda (i e)
|
||||
(send keymap call-function "hiding:show-macro" i e)))))
|
||||
(call-function "hiding:show-macro" i e)))))
|
||||
(set! hide-macro
|
||||
(new menu-item% (label "Hide this macro") (parent this)
|
||||
(new menu-item% (label "Hide selected identifier") (parent the-context-menu)
|
||||
(callback (lambda (i e)
|
||||
(send keymap call-function "hiding:hide-macro" i e)))))
|
||||
(call-function "hiding:hide-macro" i e)))))
|
||||
(enable/disable-hide/show #f)
|
||||
(void))
|
||||
|
||||
(define/override (on-demand)
|
||||
(define hiding-panel (send keymap get-hiding-panel))
|
||||
(define controller (send keymap get-controller))
|
||||
(define stx (send controller get-selected-syntax))
|
||||
(define id? (identifier? stx))
|
||||
(send show-macro enable id?)
|
||||
(send hide-macro enable id?)
|
||||
(super on-demand))
|
||||
(define/private (enable/disable-hide/show ?)
|
||||
(send show-macro enable ?)
|
||||
(send hide-macro enable ?))
|
||||
|
||||
(super-new)))
|
||||
(send controller listen-selected-syntax
|
||||
(lambda (stx)
|
||||
(enable/disable-hide/show (identifier? stx))))))
|
||||
|
||||
(define stepper-syntax-widget%
|
||||
(class s:widget%
|
||||
(init-field macro-stepper)
|
||||
(inherit get-text)
|
||||
(inherit-field controller)
|
||||
|
||||
(define/override (setup-keymap)
|
||||
(new stepper-keymap%
|
||||
(editor (get-text))
|
||||
(widget this)
|
||||
(config (send macro-stepper get-config))
|
||||
(controller controller)
|
||||
(macro-stepper macro-stepper)))
|
||||
|
||||
(define/override (show-props show?)
|
||||
|
|
@ -99,13 +98,4 @@
|
|||
(send macro-stepper update/preserve-view))
|
||||
|
||||
(super-new
|
||||
(config (new config-adapter%
|
||||
(config (send macro-stepper get-config)))))))
|
||||
|
||||
(define config-adapter%
|
||||
(class object%
|
||||
(init-field config)
|
||||
(define/public pref:props-percentage
|
||||
(case-lambda [() (send config get-props-percentage)]
|
||||
[(v) (send config set-props-percentage v)]))
|
||||
(super-new)))
|
||||
(config (send macro-stepper get-config)))))
|
||||
|
|
|
|||
|
|
@ -92,8 +92,10 @@
|
|||
(new (get-macro-stepper-widget%)
|
||||
(parent (get-area-container))
|
||||
(config config)))
|
||||
(define controller (send widget get-controller))
|
||||
|
||||
(define/public (get-widget) widget)
|
||||
(define/public (get-controller) controller)
|
||||
|
||||
(define/public (add-obsoleted-warning)
|
||||
(unless obsoleted?
|
||||
|
|
@ -116,7 +118,6 @@
|
|||
"Show syntax properties"
|
||||
(get-field show-syntax-properties? config))
|
||||
|
||||
;; FIXME: rewrite with notify-box
|
||||
(let ([id-menu
|
||||
(new (get-menu%)
|
||||
(label "Identifier=?")
|
||||
|
|
@ -128,24 +129,24 @@
|
|||
(parent id-menu)
|
||||
(callback
|
||||
(lambda _
|
||||
(send (send widget get-controller)
|
||||
set-identifier=? p))))])
|
||||
(send (send widget get-controller)
|
||||
listen-identifier=?
|
||||
(send controller set-identifier=? p))))])
|
||||
(send controller listen-identifier=?
|
||||
(lambda (name+func)
|
||||
(send this-choice check
|
||||
(eq? (car name+func) (car p)))))))
|
||||
(sb:identifier=-choices)))
|
||||
|
||||
(let ([identifier=? (send config get-identifier=?)])
|
||||
(when identifier=?
|
||||
(let ([p (assoc identifier=? (sb:identifier=-choices))])
|
||||
(send (send widget get-controller) set-identifier=? p))))
|
||||
(send controller set-identifier=? p))))
|
||||
|
||||
(new (get-menu-item%)
|
||||
(label "Clear selection")
|
||||
(parent stepper-menu)
|
||||
(callback
|
||||
(lambda _ (send (send widget get-controller) select-syntax #f))))
|
||||
(lambda _ (send controller set-selected-syntax #f))))
|
||||
|
||||
(new separator-menu-item% (parent stepper-menu))
|
||||
|
||||
(menu-option/notify-box stepper-menu
|
||||
|
|
|
|||
|
|
@ -4,54 +4,15 @@
|
|||
scheme/gui
|
||||
scheme/list
|
||||
syntax/boundmap
|
||||
"../model/synth-engine.ss"
|
||||
"../syntax-browser/util.ss"
|
||||
"../util/notify.ss"
|
||||
"../util/hiding.ss")
|
||||
"../model/hiding-policies.ss"
|
||||
"../util/mpi.ss"
|
||||
"../util/notify.ss")
|
||||
(provide macro-hiding-prefs-widget%)
|
||||
|
||||
(define mode:disable "Disable")
|
||||
(define mode:standard "Standard")
|
||||
(define mode:custom "Custom ...")
|
||||
|
||||
(define (make-policy hide-mzscheme?
|
||||
hide-libs?
|
||||
hide-contracts?
|
||||
hide-transformers?
|
||||
specialized-policies)
|
||||
(lambda (id)
|
||||
(define now (phase))
|
||||
(define binding
|
||||
(cond [(= now 0) (identifier-binding id)]
|
||||
[(= now 1) (identifier-transformer-binding id)]
|
||||
[else #f]))
|
||||
(define-values (def-mod def-name nom-mod nom-name)
|
||||
(if (pair? binding)
|
||||
(values (car binding)
|
||||
(cadr binding)
|
||||
(caddr binding)
|
||||
(cadddr binding))
|
||||
(values #f #f #f #f)))
|
||||
(let/ec return
|
||||
(let loop ([policies specialized-policies])
|
||||
(when (pair? policies)
|
||||
((car policies) id binding return)
|
||||
(loop (cdr policies))))
|
||||
(cond [(and hide-mzscheme? def-mod (scheme-module? def-mod))
|
||||
#f]
|
||||
[(and hide-libs? def-mod (lib-module? def-mod))
|
||||
#f]
|
||||
[(and hide-contracts? def-name
|
||||
(regexp-match #rx"^provide/contract-id-"
|
||||
(symbol->string def-name)))
|
||||
#f]
|
||||
[(and hide-transformers? (positive? now))
|
||||
#f]
|
||||
[else #t]))))
|
||||
|
||||
(define standard-policy
|
||||
(make-policy #t #t #t #t null))
|
||||
|
||||
;; macro-hiding-prefs-widget%
|
||||
(define macro-hiding-prefs-widget%
|
||||
(class object%
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@
|
|||
|
||||
(preferences:set-default 'MacroStepper:Frame:Width 700 number?)
|
||||
(preferences:set-default 'MacroStepper:Frame:Height 600 number?)
|
||||
(preferences:set-default 'MacroStepper:PropertiesShown? #f boolean?)
|
||||
(preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?)
|
||||
(preferences:set-default 'MacroStepper:MacroHidingMode "Standard" string?)
|
||||
(preferences:set-default 'MacroStepper:ShowSyntaxProperties? #f boolean?)
|
||||
|
|
@ -26,6 +27,7 @@
|
|||
|
||||
(pref:get/set pref:width MacroStepper:Frame:Width)
|
||||
(pref:get/set pref:height MacroStepper:Frame:Height)
|
||||
(pref:get/set pref:props-shown? MacroStepper:PropertiesShown?)
|
||||
(pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage)
|
||||
(pref:get/set pref:macro-hiding-mode MacroStepper:MacroHidingMode)
|
||||
(pref:get/set pref:show-syntax-properties? MacroStepper:ShowSyntaxProperties?)
|
||||
|
|
@ -44,8 +46,9 @@
|
|||
(class object%
|
||||
(notify-methods width)
|
||||
(notify-methods height)
|
||||
(notify-methods macro-hiding-mode)
|
||||
(notify-methods props-shown?)
|
||||
(notify-methods props-percentage)
|
||||
(notify-methods macro-hiding-mode)
|
||||
(notify-methods show-syntax-properties?)
|
||||
(notify-methods show-hiding-panel?)
|
||||
(notify-methods identifier=?)
|
||||
|
|
@ -63,8 +66,9 @@
|
|||
(class macro-stepper-config-base%
|
||||
(connect-to-pref width pref:width)
|
||||
(connect-to-pref height pref:height)
|
||||
(connect-to-pref macro-hiding-mode pref:macro-hiding-mode)
|
||||
(connect-to-pref props-shown? pref:props-shown?)
|
||||
(connect-to-pref props-percentage pref:props-percentage)
|
||||
(connect-to-pref macro-hiding-mode pref:macro-hiding-mode)
|
||||
(connect-to-pref show-syntax-properties? pref:show-syntax-properties?)
|
||||
(connect-to-pref show-hiding-panel? pref:show-hiding-panel?)
|
||||
(connect-to-pref identifier=? pref:identifier=?)
|
||||
|
|
|
|||
|
|
@ -173,7 +173,7 @@
|
|||
synth-warnings))))
|
||||
(force-letrec-transformation
|
||||
force-letrec?))
|
||||
(hide/policy deriv show-macro?))
|
||||
(hide*/policy deriv show-macro?))
|
||||
(values deriv (wderiv-e2 deriv))))
|
||||
(set! synth-deriv synth-deriv*)
|
||||
(set! synth-estx estx*)))))))
|
||||
|
|
@ -390,7 +390,7 @@
|
|||
(define/public (add-syntax stx binders definites)
|
||||
(send sbview add-syntax stx
|
||||
'#:alpha-table binders
|
||||
'#:definites definites))
|
||||
'#:definites (or definites null)))
|
||||
|
||||
(define/private (add-final stx error binders definites)
|
||||
(when stx
|
||||
|
|
@ -483,9 +483,10 @@
|
|||
(send sbview add-error-text (exn-message (misstep-exn step)))
|
||||
(send sbview add-text "\n")
|
||||
(when (exn:fail:syntax? (misstep-exn step))
|
||||
(for-each (lambda (e) (send sbview add-syntax e
|
||||
(for-each (lambda (e)
|
||||
(send sbview add-syntax e
|
||||
'#:alpha-table binders
|
||||
'#:definites (protostep-definites step)))
|
||||
'#:definites (or (protostep-definites step) null)))
|
||||
(exn:fail:syntax-exprs (misstep-exn step))))
|
||||
(show-lctx step binders))
|
||||
|
||||
|
|
@ -493,7 +494,7 @@
|
|||
;; insert-syntax/color : syntax syntaxes identifiers syntaxes string -> void
|
||||
(define/private (insert-syntax/color stx foci binders definites frontier hi-color)
|
||||
(send sbview add-syntax stx
|
||||
'#:definites definites
|
||||
'#:definites (or definites null)
|
||||
'#:alpha-table binders
|
||||
'#:hi-color hi-color
|
||||
'#:hi-stxs (if (send config get-highlight-foci?) foci null)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user