changed macro-debugger to use v4 syntax (mostly)
svn: r8544 original commit: 13a3c31ad5f63115427cfd34df285c0e981a8107
This commit is contained in:
Ryan Culpepper
parent
e56b4cdb71
commit
dae9aa6eee
|
|
@ -1,27 +1,24 @@
|
|||
#lang scheme/base
|
||||
(require "model/trace.ss"
|
||||
"model/hide.ss")
|
||||
(provide expand-only
|
||||
expand/hide)
|
||||
|
||||
(module expand mzscheme
|
||||
(require "model/trace.ss"
|
||||
"model/hide.ss")
|
||||
(provide expand-only
|
||||
expand/hide)
|
||||
|
||||
(define (expand-only stx show-list)
|
||||
(define (show? id)
|
||||
(ormap (lambda (x) (module-identifier=? id x))
|
||||
show-list))
|
||||
(expand/hiding stx show?))
|
||||
|
||||
(define (expand/hide stx hide-list)
|
||||
(define (show? id)
|
||||
(andmap (lambda (x) (not (module-identifier=? id x)))
|
||||
hide-list))
|
||||
(expand/hiding stx show?))
|
||||
|
||||
(define (expand/hiding stx show?)
|
||||
(let-values ([(result deriv) (trace/result stx)])
|
||||
(when (exn? result)
|
||||
(raise result))
|
||||
(let-values ([(_d estx) (hide/policy deriv show?)])
|
||||
estx)))
|
||||
|
||||
)
|
||||
(define (expand-only stx show-list)
|
||||
(define (show? id)
|
||||
(ormap (lambda (x) (free-identifier=? id x))
|
||||
show-list))
|
||||
(expand/hiding stx show?))
|
||||
|
||||
(define (expand/hide stx hide-list)
|
||||
(define (show? id)
|
||||
(andmap (lambda (x) (not (free-identifier=? id x)))
|
||||
hide-list))
|
||||
(expand/hiding stx show?))
|
||||
|
||||
(define (expand/hiding stx show?)
|
||||
(let-values ([(result deriv) (trace/result stx)])
|
||||
(when (exn? result)
|
||||
(raise result))
|
||||
(let-values ([(_d estx) (hide/policy deriv show?)])
|
||||
estx)))
|
||||
|
|
|
|||
|
|
@ -1,142 +1,141 @@
|
|||
#lang scheme/base
|
||||
|
||||
(module context mzscheme
|
||||
(require (lib "stx.ss" "syntax"))
|
||||
(provide (struct ref (n))
|
||||
(struct tail (n))
|
||||
path-get
|
||||
pathseg-get
|
||||
path-replace
|
||||
pathseg-replace
|
||||
find-subterm-paths)
|
||||
|
||||
;; A Path is a (list-of PathSeg)
|
||||
;; where the PathSegs are listed outermost to innermost
|
||||
;; for example: (path-get #'((a b) (c d)) (list (make-ref 0) (make-ref 1))) = #'b, not #'c
|
||||
|
||||
;; A PathSeg is one of:
|
||||
;; - (make-ref number)
|
||||
;; - (make-tail number)
|
||||
|
||||
(define-struct pathseg () #f)
|
||||
(define-struct (ref pathseg) (n) #f)
|
||||
(define-struct (tail pathseg) (n) #f)
|
||||
(require syntax/stx)
|
||||
(provide (struct-out ref)
|
||||
(struct-out tail)
|
||||
path-get
|
||||
pathseg-get
|
||||
path-replace
|
||||
pathseg-replace
|
||||
find-subterm-paths)
|
||||
|
||||
;; path:ref->splicing-tail : PathSeg -> ???
|
||||
;; ????
|
||||
(define (path:ref->splicing-tail path)
|
||||
(unless (ref? path)
|
||||
(raise-type-error 'path:ref->splicing-tail "ref path" path))
|
||||
(make-tail (sub1 (ref-n path))))
|
||||
;; A Path is a (list-of PathSeg)
|
||||
;; where the PathSegs are listed outermost to innermost
|
||||
;; for example: (path-get #'((a b) (c d)) (list (make-ref 0) (make-ref 1))) = #'b, not #'c
|
||||
|
||||
;; path-get : syntax Path -> syntax
|
||||
(define (path-get stx path)
|
||||
(let loop ([stx stx] [path path])
|
||||
(cond [(null? path) stx]
|
||||
[(pair? path)
|
||||
(loop (pathseg-get stx (car path)) (cdr path))]
|
||||
[else
|
||||
(error 'path-get "bad path: ~s" path)])))
|
||||
;; A PathSeg is one of:
|
||||
;; - (make-ref number)
|
||||
;; - (make-tail number)
|
||||
|
||||
;; pathseg-get : syntax PathSeg -> syntax
|
||||
(define (pathseg-get stx path)
|
||||
(cond [(ref? path) (pathseg-get/ref stx (ref-n path))]
|
||||
[(tail? path) (pathseg-get/tail stx (tail-n path))]))
|
||||
|
||||
;; pathseg-get/ref : syntax number -> syntax
|
||||
(define (pathseg-get/ref stx0 n0)
|
||||
(let loop ([n n0] [stx stx0])
|
||||
(unless (stx-pair? stx)
|
||||
(error 'pathseg-get "ref path out of bounds for syntax: ~s, ~s"
|
||||
n0
|
||||
(syntax-object->datum stx0)))
|
||||
(if (zero? n)
|
||||
(stx-car stx)
|
||||
(loop (sub1 n) (stx-cdr stx)))))
|
||||
(define-struct pathseg () #:transparent)
|
||||
(define-struct (ref pathseg) (n) #:transparent)
|
||||
(define-struct (tail pathseg) (n) #:transparent)
|
||||
|
||||
;; pathseg-get/tail : syntax number -> syntax
|
||||
(define (pathseg-get/tail stx0 n0)
|
||||
(let loop ([n n0] [stx stx0])
|
||||
(unless (stx-pair? stx)
|
||||
(error 'pathseg-get "tail path out of bounds for syntax: ~s, ~s" n0 stx0))
|
||||
(if (zero? n)
|
||||
(stx-cdr stx)
|
||||
(loop (sub1 n) (stx-cdr stx)))))
|
||||
;; path:ref->splicing-tail : PathSeg -> ???
|
||||
;; ????
|
||||
(define (path:ref->splicing-tail path)
|
||||
(unless (ref? path)
|
||||
(raise-type-error 'path:ref->splicing-tail "ref path" path))
|
||||
(make-tail (sub1 (ref-n path))))
|
||||
|
||||
;; path-replace : syntax Path syntax -> syntax
|
||||
(define (path-replace stx path x)
|
||||
(cond [(null? path) x]
|
||||
;; path-get : syntax Path -> syntax
|
||||
(define (path-get stx path)
|
||||
(let loop ([stx stx] [path path])
|
||||
(cond [(null? path) stx]
|
||||
[(pair? path)
|
||||
(let ([pathseg0 (car path)])
|
||||
(pathseg-replace stx
|
||||
pathseg0
|
||||
(path-replace (pathseg-get stx pathseg0)
|
||||
(cdr path)
|
||||
x)))]
|
||||
(loop (pathseg-get stx (car path)) (cdr path))]
|
||||
[else
|
||||
(error 'path-replace "bad path: ~s" path)]))
|
||||
(error 'path-get "bad path: ~s" path)])))
|
||||
|
||||
;; pathseg-replace : syntax PathSeg syntax -> syntax
|
||||
(define (pathseg-replace stx pathseg x)
|
||||
(cond [(ref? pathseg) (pathseg-replace/ref stx (ref-n pathseg) x)]
|
||||
[(tail? pathseg) (pathseg-replace/tail stx (tail-n pathseg) x)]
|
||||
[else (error 'pathseg-replace "bad path: ~s" pathseg)]))
|
||||
;; pathseg-get : syntax PathSeg -> syntax
|
||||
(define (pathseg-get stx path)
|
||||
(cond [(ref? path) (pathseg-get/ref stx (ref-n path))]
|
||||
[(tail? path) (pathseg-get/tail stx (tail-n path))]))
|
||||
|
||||
;; pathseg-replace/ref : syntax number syntax -> syntax
|
||||
(define (pathseg-replace/ref stx0 n0 x)
|
||||
(let loop ([n n0] [stx stx0])
|
||||
(unless (stx-pair? stx)
|
||||
(error 'pathseg-replace "ref path out of bounds for syntax: ~s, ~s" n0 stx0))
|
||||
(if (zero? n)
|
||||
(stx-replcar stx x)
|
||||
(stx-replcdr stx (loop (sub1 n) (stx-cdr stx))))))
|
||||
;; pathseg-get/ref : syntax number -> syntax
|
||||
(define (pathseg-get/ref stx0 n0)
|
||||
(let loop ([n n0] [stx stx0])
|
||||
(unless (stx-pair? stx)
|
||||
(error 'pathseg-get "ref path out of bounds for syntax: ~s, ~s"
|
||||
n0
|
||||
(syntax->datum stx0)))
|
||||
(if (zero? n)
|
||||
(stx-car stx)
|
||||
(loop (sub1 n) (stx-cdr stx)))))
|
||||
|
||||
;; pathseg-replace/tail : syntax number syntax -> syntax
|
||||
(define (pathseg-replace/tail stx0 n0 x)
|
||||
(let loop ([n n0] [stx stx0])
|
||||
(unless (stx-pair? stx)
|
||||
(error 'pathseg-replace "tail path out of bounds for syntax: ~s, ~s" n0 stx0))
|
||||
(if (zero? n)
|
||||
(stx-replcdr stx x)
|
||||
(stx-replcdr stx (loop (sub1 n) (stx-cdr stx))))))
|
||||
;; pathseg-get/tail : syntax number -> syntax
|
||||
(define (pathseg-get/tail stx0 n0)
|
||||
(let loop ([n n0] [stx stx0])
|
||||
(unless (stx-pair? stx)
|
||||
(error 'pathseg-get "tail path out of bounds for syntax: ~s, ~s" n0 stx0))
|
||||
(if (zero? n)
|
||||
(stx-cdr stx)
|
||||
(loop (sub1 n) (stx-cdr stx)))))
|
||||
|
||||
;; stx-replcar : syntax syntax -> syntax
|
||||
(define (stx-replcar stx x)
|
||||
(cond [(pair? stx)
|
||||
(cons x (cdr stx))]
|
||||
[(syntax? stx)
|
||||
(datum->syntax-object stx (cons x (cdr (syntax-e stx))) stx stx)]
|
||||
[else (raise-type-error 'stx-replcar "stx-pair" stx)]))
|
||||
;; path-replace : syntax Path syntax -> syntax
|
||||
(define (path-replace stx path x)
|
||||
(cond [(null? path) x]
|
||||
[(pair? path)
|
||||
(let ([pathseg0 (car path)])
|
||||
(pathseg-replace stx
|
||||
pathseg0
|
||||
(path-replace (pathseg-get stx pathseg0)
|
||||
(cdr path)
|
||||
x)))]
|
||||
[else
|
||||
(error 'path-replace "bad path: ~s" path)]))
|
||||
|
||||
;; stx-replcdr : syntax syntax -> syntax
|
||||
(define (stx-replcdr stx x)
|
||||
(cond [(pair? stx)
|
||||
(cons (car stx) x)]
|
||||
[(and (syntax? stx) (pair? (syntax-e stx)))
|
||||
(datum->syntax-object stx (cons (car (syntax-e stx)) x) stx stx)]
|
||||
[else (raise-type-error 'stx-replcdr "stx-pair" stx)]))
|
||||
|
||||
(define (sd x)
|
||||
(syntax-object->datum (datum->syntax-object #f x)))
|
||||
|
||||
;;=======
|
||||
|
||||
;; find-subterm-paths : syntax syntax -> (list-of Path)
|
||||
(define (find-subterm-paths subterm term)
|
||||
(let outer-loop ([term term])
|
||||
(cond [(eq? subterm term)
|
||||
(list null)]
|
||||
[(stx-pair? term)
|
||||
;; Optimized for lists...
|
||||
(let loop ([term term] [n 0])
|
||||
(if (stx-pair? term)
|
||||
(let* ([seg0 (make-ref n)])
|
||||
(append (map (lambda (p) (cons seg0 p)) (outer-loop (stx-car term)))
|
||||
(if (eq? subterm (stx-cdr term))
|
||||
(list (list (make-tail n)))
|
||||
(loop (stx-cdr term) (add1 n)))))
|
||||
(let ([seg0 (make-tail n)])
|
||||
(map (lambda (p) (cons seg0 p))
|
||||
(outer-loop term)))))]
|
||||
;; FIXME: more structured cases here: box, vector, ...
|
||||
[else null])))
|
||||
)
|
||||
;; pathseg-replace : syntax PathSeg syntax -> syntax
|
||||
(define (pathseg-replace stx pathseg x)
|
||||
(cond [(ref? pathseg) (pathseg-replace/ref stx (ref-n pathseg) x)]
|
||||
[(tail? pathseg) (pathseg-replace/tail stx (tail-n pathseg) x)]
|
||||
[else (error 'pathseg-replace "bad path: ~s" pathseg)]))
|
||||
|
||||
;; pathseg-replace/ref : syntax number syntax -> syntax
|
||||
(define (pathseg-replace/ref stx0 n0 x)
|
||||
(let loop ([n n0] [stx stx0])
|
||||
(unless (stx-pair? stx)
|
||||
(error 'pathseg-replace "ref path out of bounds for syntax: ~s, ~s" n0 stx0))
|
||||
(if (zero? n)
|
||||
(stx-replcar stx x)
|
||||
(stx-replcdr stx (loop (sub1 n) (stx-cdr stx))))))
|
||||
|
||||
;; pathseg-replace/tail : syntax number syntax -> syntax
|
||||
(define (pathseg-replace/tail stx0 n0 x)
|
||||
(let loop ([n n0] [stx stx0])
|
||||
(unless (stx-pair? stx)
|
||||
(error 'pathseg-replace "tail path out of bounds for syntax: ~s, ~s" n0 stx0))
|
||||
(if (zero? n)
|
||||
(stx-replcdr stx x)
|
||||
(stx-replcdr stx (loop (sub1 n) (stx-cdr stx))))))
|
||||
|
||||
;; stx-replcar : syntax syntax -> syntax
|
||||
(define (stx-replcar stx x)
|
||||
(cond [(pair? stx)
|
||||
(cons x (cdr stx))]
|
||||
[(syntax? stx)
|
||||
(datum->syntax stx (cons x (cdr (syntax-e stx))) stx stx)]
|
||||
[else (raise-type-error 'stx-replcar "stx-pair" stx)]))
|
||||
|
||||
;; stx-replcdr : syntax syntax -> syntax
|
||||
(define (stx-replcdr stx x)
|
||||
(cond [(pair? stx)
|
||||
(cons (car stx) x)]
|
||||
[(and (syntax? stx) (pair? (syntax-e stx)))
|
||||
(datum->syntax stx (cons (car (syntax-e stx)) x) stx stx)]
|
||||
[else (raise-type-error 'stx-replcdr "stx-pair" stx)]))
|
||||
|
||||
(define (sd x)
|
||||
(syntax->datum (datum->syntax #f x)))
|
||||
|
||||
;;=======
|
||||
|
||||
;; find-subterm-paths : syntax syntax -> (list-of Path)
|
||||
(define (find-subterm-paths subterm term)
|
||||
(let outer-loop ([term term])
|
||||
(cond [(eq? subterm term)
|
||||
(list null)]
|
||||
[(stx-pair? term)
|
||||
;; Optimized for lists...
|
||||
(let loop ([term term] [n 0])
|
||||
(if (stx-pair? term)
|
||||
(let* ([seg0 (make-ref n)])
|
||||
(append (map (lambda (p) (cons seg0 p)) (outer-loop (stx-car term)))
|
||||
(if (eq? subterm (stx-cdr term))
|
||||
(list (list (make-tail n)))
|
||||
(loop (stx-cdr term) (add1 n)))))
|
||||
(let ([seg0 (make-tail n)])
|
||||
(map (lambda (p) (cons seg0 p))
|
||||
(outer-loop term)))))]
|
||||
;; FIXME: more structured cases here: box, vector, ...
|
||||
[else null])))
|
||||
|
|
|
|||
|
|
@ -1,22 +1,22 @@
|
|||
|
||||
(module debug mzscheme
|
||||
(require (lib "plt-match.ss"))
|
||||
(require "trace.ss"
|
||||
"reductions.ss"
|
||||
"deriv-util.ss"
|
||||
"deriv-find.ss"
|
||||
"hide.ss"
|
||||
"hiding-policies.ss"
|
||||
"deriv.ss"
|
||||
"steps.ss")
|
||||
#lang scheme/base
|
||||
|
||||
(provide (all-from "trace.ss")
|
||||
(all-from "reductions.ss")
|
||||
(all-from "deriv.ss")
|
||||
(all-from "deriv-util.ss")
|
||||
(all-from "deriv-find.ss")
|
||||
(all-from "hiding-policies.ss")
|
||||
(all-from "hide.ss")
|
||||
(all-from "steps.ss")
|
||||
(all-from (lib "plt-match.ss")))
|
||||
)
|
||||
(require scheme/match
|
||||
"trace.ss"
|
||||
"reductions.ss"
|
||||
"deriv-util.ss"
|
||||
"deriv-find.ss"
|
||||
"hide.ss"
|
||||
"hiding-policies.ss"
|
||||
"deriv.ss"
|
||||
"steps.ss")
|
||||
|
||||
(provide (all-from-out "trace.ss")
|
||||
(all-from-out "reductions.ss")
|
||||
(all-from-out "deriv.ss")
|
||||
(all-from-out "deriv-util.ss")
|
||||
(all-from-out "deriv-find.ss")
|
||||
(all-from-out "hiding-policies.ss")
|
||||
(all-from-out "hide.ss")
|
||||
(all-from-out "steps.ss")
|
||||
(all-from-out scheme/match))
|
||||
|
|
|
|||
|
|
@ -1,187 +1,184 @@
|
|||
|
||||
(module deriv-c mzscheme
|
||||
(provide (all-defined))
|
||||
#lang scheme/base
|
||||
(provide (all-defined-out))
|
||||
|
||||
;; A Node(a) is:
|
||||
;; (make-node a ?a)
|
||||
(define-struct node (z1 z2) #f)
|
||||
|
||||
;; A TopDeriv is one of
|
||||
;; (make-lift-deriv <Node(Stx)> Deriv Stxs TopDeriv)
|
||||
;; Deriv
|
||||
|
||||
;; A Deriv is one of
|
||||
;; (make-mrule <Node(Stx)> Transformation Deriv)
|
||||
;; PrimDeriv
|
||||
(define-struct (deriv node) () #f)
|
||||
(define-struct (lift-deriv deriv) (first lift-stx second) #f)
|
||||
(define-struct (mrule deriv) (transformation next) #f)
|
||||
;; A Node(a) is:
|
||||
;; (make-node a ?a)
|
||||
(define-struct node (z1 z2) #:transparent)
|
||||
|
||||
;; A DerivLL is one of
|
||||
;; (make-lift/let-deriv <Node(Stx)> Deriv Stx Deriv)
|
||||
;; Deriv
|
||||
(define-struct (lift/let-deriv deriv) (first lift-stx second) #f)
|
||||
;; A TopDeriv is one of
|
||||
;; (make-lift-deriv <Node(Stx)> Deriv Stxs TopDeriv)
|
||||
;; Deriv
|
||||
|
||||
;; 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) #f)
|
||||
;; A Deriv is one of
|
||||
;; (make-mrule <Node(Stx)> Transformation Deriv)
|
||||
;; PrimDeriv
|
||||
(define-struct (deriv node) () #:transparent)
|
||||
(define-struct (lift-deriv deriv) (first lift-stx second) #:transparent)
|
||||
(define-struct (mrule deriv) (transformation next) #:transparent)
|
||||
|
||||
;; A LocalAction is one of
|
||||
;; (make-local-expansion <Node(Stx)> Stx ?Stx Boolean Deriv)
|
||||
;; (make-local-expansion/expr <Node(Stx)> Stx ?Stx Boolean ?Opaque Deriv)
|
||||
;; (make-local-lift Stx Identifier)
|
||||
;; (make-local-lift-end Stx)
|
||||
;; (make-local-bind BindSyntaxes)
|
||||
(define-struct (local-expansion node) (me1 me2 for-stx? inner) #f)
|
||||
(define-struct (local-expansion/expr node) (me1 me2 for-stx? opaque inner) #f)
|
||||
(define-struct local-lift (expr id) #f)
|
||||
(define-struct local-lift-end (decl) #f)
|
||||
(define-struct local-bind (bindrhs) #f)
|
||||
;; A DerivLL is one of
|
||||
;; (make-lift/let-deriv <Node(Stx)> Deriv Stx Deriv)
|
||||
;; Deriv
|
||||
(define-struct (lift/let-deriv deriv) (first lift-stx second) #:transparent)
|
||||
|
||||
;; Base = << Node(Stx) Rs ?exn >>
|
||||
(define-struct (base deriv) (resolves ?1) #f)
|
||||
;; 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)
|
||||
|
||||
;; A PrimDeriv is one of
|
||||
(define-struct (prule base) () #f)
|
||||
(define-struct (p:variable prule) () #f)
|
||||
;; A LocalAction is one of
|
||||
;; (make-local-expansion <Node(Stx)> Stx ?Stx Boolean Deriv)
|
||||
;; (make-local-expansion/expr <Node(Stx)> Stx ?Stx Boolean ?Opaque Deriv)
|
||||
;; (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-lift (expr id) #:transparent)
|
||||
(define-struct local-lift-end (decl) #:transparent)
|
||||
(define-struct local-bind (bindrhs) #: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) #f)
|
||||
(define-struct (p:#%module-begin prule) (pass1 pass2 ?2) #f)
|
||||
;; Base = << Node(Stx) Rs ?exn >>
|
||||
(define-struct (base deriv) (resolves ?1) #:transparent)
|
||||
|
||||
;; (make-p:define-syntaxes <Base> DerivLL)
|
||||
;; (make-p:define-values <Base> Deriv)
|
||||
(define-struct (p:define-syntaxes prule) (rhs ?2) #f)
|
||||
(define-struct (p:define-values prule) (rhs) #f)
|
||||
;; A PrimDeriv is one of
|
||||
(define-struct (prule base) () #:transparent)
|
||||
(define-struct (p:variable prule) () #:transparent)
|
||||
|
||||
;; (make-p:#%expression <Base> Deriv)
|
||||
;; (make-p:if <Base> Boolean Deriv Deriv Deriv)
|
||||
;; (make-p:wcm <Base> Deriv Deriv Deriv)
|
||||
;; (make-p:set! <Base> Rs Deriv)
|
||||
;; (make-p:set!-macro <Base> Rs Deriv)
|
||||
(define-struct (p:#%expression prule) (inner) #f)
|
||||
(define-struct (p:if prule) (full? test then else) #f)
|
||||
(define-struct (p:wcm prule) (key mark body) #f)
|
||||
(define-struct (p:set! prule) (id-resolves rhs) #f)
|
||||
(define-struct (p:set!-macro prule) (deriv) #f)
|
||||
;; (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:#%app <Base> Stx LDeriv)
|
||||
;; (make-p:begin <Base> LDeriv)
|
||||
;; (make-p:begin0 <Base> Deriv LDeriv)
|
||||
(define-struct (p:#%app prule) (tagged-stx lderiv) #f)
|
||||
(define-struct (p:begin prule) (lderiv) #f)
|
||||
(define-struct (p:begin0 prule) (first lderiv) #f)
|
||||
;; (make-p:define-syntaxes <Base> DerivLL)
|
||||
;; (make-p:define-values <Base> Deriv)
|
||||
(define-struct (p:define-syntaxes prule) (rhs ?2) #:transparent)
|
||||
(define-struct (p:define-values prule) (rhs) #:transparent)
|
||||
|
||||
;; (make-p:lambda <Base> LambdaRenames BDeriv)
|
||||
;; (make-p:case-lambda <Base> (list-of CaseLambdaClause))
|
||||
;; (make-p:let-values <Base> LetRenames (list-of Deriv) BDeriv)
|
||||
;; (make-p:letrec-values <Base> LetRenames (list-of Deriv) BDeriv)
|
||||
;; (make-p:letrec-syntaxes+values <Base> LSVRenames (list-of BindSyntaxes) (list-of Deriv) BDeriv)
|
||||
(define-struct (p:lambda prule) (renames body) #f)
|
||||
(define-struct (p:case-lambda prule) (renames+bodies) #f)
|
||||
(define-struct (p:let-values prule) (renames rhss body) #f)
|
||||
(define-struct (p:letrec-values prule) (renames rhss body) #f)
|
||||
(define-struct (p:letrec-syntaxes+values prule) (srenames sbindrhss vrenames vrhss body) #f)
|
||||
;; (make-p:#%expression <Base> Deriv)
|
||||
;; (make-p:if <Base> Boolean Deriv Deriv Deriv)
|
||||
;; (make-p:wcm <Base> Deriv Deriv Deriv)
|
||||
;; (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:wcm prule) (key mark body) #:transparent)
|
||||
(define-struct (p:set! prule) (id-resolves rhs) #:transparent)
|
||||
(define-struct (p:set!-macro prule) (deriv) #:transparent)
|
||||
|
||||
;; (make-p:stop <Base>)
|
||||
;; (make-p:unknown <Base>)
|
||||
;; (make-p:#%top <Base> Stx)
|
||||
;; (make-p:#%datum <Base> Stx)
|
||||
;; (make-p:quote <Base>)
|
||||
;; (make-p:quote-syntax <Base>)
|
||||
;; (make-p:require <Base>)
|
||||
;; (make-p:require-for-syntax <Base>)
|
||||
;; (make-p:require-for-template <Base>)
|
||||
;; (make-p:provide <Base>)
|
||||
(define-struct (p::STOP prule) () #f)
|
||||
(define-struct (p:stop p::STOP) () #f)
|
||||
(define-struct (p:unknown p::STOP) () #f)
|
||||
(define-struct (p:#%top p::STOP) (tagged-stx) #f)
|
||||
(define-struct (p:#%datum p::STOP) (tagged-stx) #f)
|
||||
(define-struct (p:quote p::STOP) () #f)
|
||||
(define-struct (p:quote-syntax p::STOP) () #f)
|
||||
(define-struct (p:require p::STOP) () #f)
|
||||
(define-struct (p:require-for-syntax p::STOP) () #f)
|
||||
(define-struct (p:require-for-template p::STOP) () #f)
|
||||
(define-struct (p:provide p::STOP) () #f)
|
||||
;; (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:begin prule) (lderiv) #:transparent)
|
||||
(define-struct (p:begin0 prule) (first lderiv) #:transparent)
|
||||
|
||||
;;+ (make-p:rename <Base> Renames Deriv)
|
||||
;;+ (make-p:synth <Base> (list-of SynthItem) ?exn)
|
||||
(define-struct (p:rename prule) (renames inner) #f)
|
||||
(define-struct (p:synth prule) (subterms ?2) #f)
|
||||
;; (make-p:lambda <Base> LambdaRenames BDeriv)
|
||||
;; (make-p:case-lambda <Base> (list-of CaseLambdaClause))
|
||||
;; (make-p:let-values <Base> LetRenames (list-of Deriv) BDeriv)
|
||||
;; (make-p:letrec-values <Base> LetRenames (list-of Deriv) BDeriv)
|
||||
;; (make-p:letrec-syntaxes+values <Base> LSVRenames (list-of BindSyntaxes) (list-of Deriv) BDeriv)
|
||||
(define-struct (p:lambda prule) (renames body) #:transparent)
|
||||
(define-struct (p:case-lambda prule) (renames+bodies) #:transparent)
|
||||
(define-struct (p:let-values prule) (renames rhss body) #:transparent)
|
||||
(define-struct (p:letrec-values prule) (renames rhss body) #:transparent)
|
||||
(define-struct (p:letrec-syntaxes+values prule) (srenames sbindrhss vrenames vrhss body) #:transparent)
|
||||
|
||||
;; (make-p:stop <Base>)
|
||||
;; (make-p:unknown <Base>)
|
||||
;; (make-p:#%top <Base> Stx)
|
||||
;; (make-p:#%datum <Base> Stx)
|
||||
;; (make-p:quote <Base>)
|
||||
;; (make-p:quote-syntax <Base>)
|
||||
;; (make-p:require <Base>)
|
||||
;; (make-p:require-for-syntax <Base>)
|
||||
;; (make-p:require-for-template <Base>)
|
||||
;; (make-p:provide <Base>)
|
||||
(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:quote p::STOP) () #:transparent)
|
||||
(define-struct (p:quote-syntax p::STOP) () #:transparent)
|
||||
(define-struct (p:require p::STOP) () #:transparent)
|
||||
(define-struct (p:require-for-syntax p::STOP) () #:transparent)
|
||||
(define-struct (p:require-for-template p::STOP) () #:transparent)
|
||||
(define-struct (p:provide p::STOP) () #:transparent)
|
||||
|
||||
;;+ (make-p:rename <Base> Renames Deriv)
|
||||
;;+ (make-p:synth <Base> (list-of SynthItem) ?exn)
|
||||
(define-struct (p:rename prule) (renames inner) #:transparent)
|
||||
(define-struct (p:synth prule) (subterms ?2) #:transparent)
|
||||
|
||||
|
||||
|
||||
;; A LDeriv is
|
||||
;; (make-lderiv <Node(Stxs)> ?exn (list-of Deriv))
|
||||
(define-struct (lderiv node) (?1 derivs) #f)
|
||||
|
||||
;; A BDeriv is
|
||||
;; (make-bderiv <Node(Stxs)> (list-of BRule) (U 'list 'letrec) LDeriv)
|
||||
(define-struct (bderiv node) (pass1 trans pass2) #f)
|
||||
;; A LDeriv is
|
||||
;; (make-lderiv <Node(Stxs)> ?exn (list-of Deriv))
|
||||
(define-struct (lderiv node) (?1 derivs) #:transparent)
|
||||
|
||||
;; A BRule is one of
|
||||
;; (make-b:error exn)
|
||||
;; (make-b:expr BlockRenames Deriv)
|
||||
;; (make-b:splice BlockRenames Deriv ?exn Stxs ?exn)
|
||||
;; (make-b:defvals BlockRenames Deriv ?exn)
|
||||
;; (make-b:defstx BlockRenames Deriv ?exn BindSyntaxes)
|
||||
;;i (make-b:begin BlockRenames Deriv (list-of Deriv))
|
||||
(define-struct b:error (?1) #f)
|
||||
(define-struct brule (renames) #f)
|
||||
(define-struct (b:expr brule) (head) #f)
|
||||
(define-struct (b:splice brule) (head ?1 tail ?2) #f)
|
||||
(define-struct (b:defvals brule) (head ?1) #f)
|
||||
(define-struct (b:defstx brule) (head ?1 bindrhs) #f)
|
||||
;;(define-struct (b:begin brule) (head inner) #f)
|
||||
;; A BDeriv is
|
||||
;; (make-bderiv <Node(Stxs)> (list-of BRule) (U 'list 'letrec) LDeriv)
|
||||
(define-struct (bderiv node) (pass1 trans pass2) #:transparent)
|
||||
|
||||
;; A BindSyntaxes is
|
||||
;; (make-bind-syntaxes DerivLL ?exn)
|
||||
(define-struct bind-syntaxes (rhs ?1) #f)
|
||||
;; A BRule is one of
|
||||
;; (make-b:error exn)
|
||||
;; (make-b:expr BlockRenames Deriv)
|
||||
;; (make-b:splice BlockRenames Deriv ?exn Stxs ?exn)
|
||||
;; (make-b:defvals BlockRenames Deriv ?exn)
|
||||
;; (make-b:defstx BlockRenames Deriv ?exn BindSyntaxes)
|
||||
;;i (make-b:begin BlockRenames Deriv (list-of Deriv))
|
||||
(define-struct b:error (?1) #:transparent)
|
||||
(define-struct brule (renames) #:transparent)
|
||||
(define-struct (b:expr brule) (head) #:transparent)
|
||||
(define-struct (b:splice brule) (head ?1 tail ?2) #:transparent)
|
||||
(define-struct (b:defvals brule) (head ?1) #:transparent)
|
||||
(define-struct (b:defstx brule) (head ?1 bindrhs) #:transparent)
|
||||
;;(define-struct (b:begin brule) (head inner) #:transparent)
|
||||
|
||||
;; A BindSyntaxes is
|
||||
;; (make-bind-syntaxes DerivLL ?exn)
|
||||
(define-struct bind-syntaxes (rhs ?1) #:transparent)
|
||||
|
||||
|
||||
;; A CaseLambdaClause is
|
||||
;; (make-clc ?exn CaseLambdaRename BDeriv)
|
||||
(define-struct clc (?1 renames body) #f)
|
||||
;; A CaseLambdaClause is
|
||||
;; (make-clc ?exn CaseLambdaRename BDeriv)
|
||||
(define-struct clc (?1 renames body) #:transparent)
|
||||
|
||||
;; A BlockRename is (cons Stx Stx)
|
||||
;; A BlockRename is (cons Stx Stx)
|
||||
|
||||
;; A ModPass1 is (list-of ModRule1)
|
||||
;; A ModPass2 is (list-of ModRule2)
|
||||
;; A ModPass1 is (list-of ModRule1)
|
||||
;; 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:lift-end Stxs)
|
||||
;; A ModRule2 is one of
|
||||
;; (make-mod:skip)
|
||||
;; (make-mod:cons Deriv)
|
||||
;; (make-mod:lift Deriv Stxs)
|
||||
(define-struct modrule () #f)
|
||||
(define-struct (mod:cons modrule) (head) #f)
|
||||
(define-struct (mod:prim modrule) (head prim) #f)
|
||||
(define-struct (mod:skip modrule) () #f)
|
||||
(define-struct (mod:splice modrule) (head ?1 tail) #f)
|
||||
(define-struct (mod:lift modrule) (head tail) #f)
|
||||
(define-struct (mod:lift-end modrule) (tail) #f)
|
||||
;; A ModRule1 is one of
|
||||
;; (make-mod:prim Deriv ModPrim)
|
||||
;; (make-mod:splice Deriv ?exn Stxs)
|
||||
;; (make-mod:lift Deriv 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:lift-end modrule) (tail) #:transparent)
|
||||
|
||||
;; A ModPrim is a PRule in:
|
||||
;; (make-p:define-values <Base> #f)
|
||||
;; (make-p:define-syntaxes <Base> Deriv)
|
||||
;; (make-p:require <Base>)
|
||||
;; (make-p:require-for-syntax <Base>)
|
||||
;; (make-p:require-for-template <Base>)
|
||||
;; (make-p:provide <Base>)
|
||||
;; #f
|
||||
;; A ModPrim is a PRule in:
|
||||
;; (make-p:define-values <Base> #:transparent)
|
||||
;; (make-p:define-syntaxes <Base> Deriv)
|
||||
;; (make-p:require <Base>)
|
||||
;; (make-p:require-for-syntax <Base>)
|
||||
;; (make-p:require-for-template <Base>)
|
||||
;; (make-p:provide <Base>)
|
||||
;; #f
|
||||
|
||||
;; A SynthItem is one of
|
||||
;; - (make-s:subterm Path Deriv)
|
||||
;; - (make-s:rename Path Stx Stx)
|
||||
(define-struct subitem () #f)
|
||||
(define-struct (s:subterm subitem) (path deriv) #f)
|
||||
(define-struct (s:rename subitem) (path before after) #f)
|
||||
|
||||
|
||||
)
|
||||
;; A SynthItem is one of
|
||||
;; - (make-s:subterm Path Deriv)
|
||||
;; - (make-s:rename Path Stx Stx)
|
||||
(define-struct subitem () #:transparent)
|
||||
(define-struct (s:subterm subitem) (path deriv) #:transparent)
|
||||
(define-struct (s:rename subitem) (path before after) #:transparent)
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,160 +1,158 @@
|
|||
|
||||
(module deriv-tokens mzscheme
|
||||
(require (lib "lex.ss" "parser-tools")
|
||||
"deriv.ss")
|
||||
(provide (all-defined))
|
||||
#lang scheme/base
|
||||
(require parser-tools/lex
|
||||
"deriv.ss")
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define-tokens basic-tokens
|
||||
(start ; .
|
||||
visit ; syntax
|
||||
resolve ; identifier
|
||||
next ; .
|
||||
next-group ; .
|
||||
enter-macro ; syntax
|
||||
macro-pre-transform ; syntax
|
||||
macro-post-transform ; syntax
|
||||
exit-macro ; syntax
|
||||
enter-prim ; syntax
|
||||
exit-prim ; syntax
|
||||
return ; syntax
|
||||
enter-block ; syntaxes
|
||||
block->list ; syntaxes
|
||||
block->letrec ; syntax(es?)
|
||||
splice ; syntaxes
|
||||
enter-list ; syntaxes
|
||||
exit-list ; syntaxes
|
||||
enter-check ; syntax
|
||||
exit-check ; syntax
|
||||
phase-up ; .
|
||||
module-body ; (list-of (cons syntax boolean))
|
||||
... ; .
|
||||
EOF ; .
|
||||
syntax-error ; exn
|
||||
lift-loop ; syntax
|
||||
lift/let-loop ; syntax
|
||||
module-lift-loop ; syntaxes
|
||||
module-lift-end-loop ; syntaxes
|
||||
lift ; (cons syntax id)
|
||||
lift-statement ; syntax
|
||||
enter-local ; syntax
|
||||
local-pre ; syntax
|
||||
local-post ; syntax
|
||||
exit-local ; syntax
|
||||
(define-tokens basic-tokens
|
||||
(start ; .
|
||||
visit ; syntax
|
||||
resolve ; identifier
|
||||
next ; .
|
||||
next-group ; .
|
||||
enter-macro ; syntax
|
||||
macro-pre-transform ; syntax
|
||||
macro-post-transform ; syntax
|
||||
exit-macro ; syntax
|
||||
enter-prim ; syntax
|
||||
exit-prim ; syntax
|
||||
return ; syntax
|
||||
enter-block ; syntaxes
|
||||
block->list ; syntaxes
|
||||
block->letrec ; syntax(es?)
|
||||
splice ; syntaxes
|
||||
enter-list ; syntaxes
|
||||
exit-list ; syntaxes
|
||||
enter-check ; syntax
|
||||
exit-check ; syntax
|
||||
phase-up ; .
|
||||
module-body ; (list-of (cons syntax boolean))
|
||||
... ; .
|
||||
EOF ; .
|
||||
syntax-error ; exn
|
||||
lift-loop ; syntax
|
||||
lift/let-loop ; syntax
|
||||
module-lift-loop ; syntaxes
|
||||
module-lift-end-loop ; syntaxes
|
||||
lift ; (cons syntax id)
|
||||
lift-statement ; syntax
|
||||
enter-local ; syntax
|
||||
local-pre ; syntax
|
||||
local-post ; syntax
|
||||
exit-local ; syntax
|
||||
|
||||
enter-local/expr ; syntax
|
||||
exit-local/expr ; (cons syntax expanded-expression)
|
||||
enter-local/expr ; syntax
|
||||
exit-local/expr ; (cons syntax expanded-expression)
|
||||
|
||||
variable ; (cons identifier identifier)
|
||||
variable ; (cons identifier identifier)
|
||||
|
||||
IMPOSSIBLE ; useful for error-handling clauses that have no NoError counterpart
|
||||
))
|
||||
IMPOSSIBLE ; useful for error-handling clauses that have no NoError counterpart
|
||||
))
|
||||
|
||||
(define-tokens renames-tokens
|
||||
(renames-lambda ; (cons syntax syntax)
|
||||
renames-case-lambda ; (cons syntax syntax)
|
||||
renames-let ; (cons (listof syntax) syntax)
|
||||
renames-letrec-syntaxes ; (cons (listof syntax) (cons (listof syntax) syntax))
|
||||
renames-block ; (cons syntax syntax) ... different, contains both pre+post
|
||||
))
|
||||
(define-tokens renames-tokens
|
||||
(renames-lambda ; (cons syntax syntax)
|
||||
renames-case-lambda ; (cons syntax syntax)
|
||||
renames-let ; (cons (listof syntax) syntax)
|
||||
renames-letrec-syntaxes ; (cons (listof syntax) (cons (listof syntax) syntax))
|
||||
renames-block ; (cons syntax syntax) ... different, contains both pre+post
|
||||
))
|
||||
|
||||
;; Empty tokens
|
||||
(define-tokens prim-tokens
|
||||
(prim-module prim-#%module-begin
|
||||
prim-define-syntaxes prim-define-values
|
||||
prim-if prim-wcm prim-begin prim-begin0 prim-#%app prim-lambda
|
||||
prim-case-lambda prim-let-values prim-let*-values prim-letrec-values
|
||||
prim-letrec-syntaxes+values prim-#%datum prim-#%top prim-stop
|
||||
prim-quote prim-quote-syntax prim-require prim-require-for-syntax
|
||||
prim-require-for-template prim-provide
|
||||
prim-set!
|
||||
prim-expression
|
||||
))
|
||||
;; Empty tokens
|
||||
(define-tokens prim-tokens
|
||||
(prim-module prim-#%module-begin
|
||||
prim-define-syntaxes prim-define-values
|
||||
prim-if prim-wcm prim-begin prim-begin0 prim-#%app prim-lambda
|
||||
prim-case-lambda prim-let-values prim-let*-values prim-letrec-values
|
||||
prim-letrec-syntaxes+values prim-#%datum prim-#%top prim-stop
|
||||
prim-quote prim-quote-syntax prim-require prim-require-for-syntax
|
||||
prim-require-for-template prim-provide
|
||||
prim-set!
|
||||
prim-expression
|
||||
))
|
||||
|
||||
;; ** Signals to tokens
|
||||
;; ** Signals to tokens
|
||||
|
||||
(define signal-mapping
|
||||
`((EOF . EOF)
|
||||
(error . ,token-syntax-error)
|
||||
(0 . ,token-visit)
|
||||
(1 . ,token-resolve)
|
||||
(2 . ,token-return)
|
||||
(3 . ,token-next)
|
||||
(4 . ,token-enter-list)
|
||||
(5 . ,token-exit-list)
|
||||
(6 . ,token-enter-prim)
|
||||
(7 . ,token-exit-prim)
|
||||
(8 . ,token-enter-macro)
|
||||
(9 . ,token-exit-macro)
|
||||
(10 . ,token-enter-block)
|
||||
(11 . ,token-splice)
|
||||
(12 . ,token-block->list)
|
||||
(13 . ,token-next-group)
|
||||
(14 . ,token-block->letrec)
|
||||
(16 . ,token-renames-let)
|
||||
(17 . ,token-renames-lambda)
|
||||
(18 . ,token-renames-case-lambda)
|
||||
(19 . ,token-renames-letrec-syntaxes)
|
||||
(20 . phase-up)
|
||||
(21 . ,token-macro-pre-transform)
|
||||
(22 . ,token-macro-post-transform)
|
||||
(23 . ,token-module-body)
|
||||
(24 . ,token-renames-block)
|
||||
|
||||
(100 . prim-stop)
|
||||
(101 . prim-module)
|
||||
(102 . prim-#%module-begin)
|
||||
(103 . prim-define-syntaxes)
|
||||
(104 . prim-define-values)
|
||||
(105 . prim-if)
|
||||
(106 . prim-wcm)
|
||||
(107 . prim-begin)
|
||||
(108 . prim-begin0)
|
||||
(109 . prim-#%app)
|
||||
(110 . prim-lambda)
|
||||
(111 . prim-case-lambda)
|
||||
(112 . prim-let-values)
|
||||
(113 . prim-letrec-values)
|
||||
(114 . prim-letrec-syntaxes+values)
|
||||
(115 . prim-#%datum)
|
||||
(116 . prim-#%top)
|
||||
(117 . prim-quote)
|
||||
(118 . prim-quote-syntax)
|
||||
(119 . prim-require)
|
||||
(120 . prim-require-for-syntax)
|
||||
(121 . prim-require-for-template)
|
||||
(122 . prim-provide)
|
||||
(123 . prim-set!)
|
||||
(124 . prim-let*-values)
|
||||
(125 . ,token-variable)
|
||||
(126 . ,token-enter-check)
|
||||
(127 . ,token-exit-check)
|
||||
(128 . ,token-lift-loop)
|
||||
(129 . ,token-lift)
|
||||
(130 . ,token-enter-local)
|
||||
(131 . ,token-exit-local)
|
||||
(132 . ,token-local-pre)
|
||||
(133 . ,token-local-post)
|
||||
(134 . ,token-lift-statement)
|
||||
(135 . ,token-module-lift-end-loop)
|
||||
(136 . ,token-lift/let-loop)
|
||||
(137 . ,token-module-lift-loop)
|
||||
(138 . prim-expression)
|
||||
(139 . ,token-enter-local/expr)
|
||||
(140 . ,token-exit-local/expr)
|
||||
(141 . ,token-start)
|
||||
))
|
||||
(define signal-mapping
|
||||
`((EOF . EOF)
|
||||
(error . ,token-syntax-error)
|
||||
(0 . ,token-visit)
|
||||
(1 . ,token-resolve)
|
||||
(2 . ,token-return)
|
||||
(3 . ,token-next)
|
||||
(4 . ,token-enter-list)
|
||||
(5 . ,token-exit-list)
|
||||
(6 . ,token-enter-prim)
|
||||
(7 . ,token-exit-prim)
|
||||
(8 . ,token-enter-macro)
|
||||
(9 . ,token-exit-macro)
|
||||
(10 . ,token-enter-block)
|
||||
(11 . ,token-splice)
|
||||
(12 . ,token-block->list)
|
||||
(13 . ,token-next-group)
|
||||
(14 . ,token-block->letrec)
|
||||
(16 . ,token-renames-let)
|
||||
(17 . ,token-renames-lambda)
|
||||
(18 . ,token-renames-case-lambda)
|
||||
(19 . ,token-renames-letrec-syntaxes)
|
||||
(20 . phase-up)
|
||||
(21 . ,token-macro-pre-transform)
|
||||
(22 . ,token-macro-post-transform)
|
||||
(23 . ,token-module-body)
|
||||
(24 . ,token-renames-block)
|
||||
|
||||
(100 . prim-stop)
|
||||
(101 . prim-module)
|
||||
(102 . prim-#%module-begin)
|
||||
(103 . prim-define-syntaxes)
|
||||
(104 . prim-define-values)
|
||||
(105 . prim-if)
|
||||
(106 . prim-wcm)
|
||||
(107 . prim-begin)
|
||||
(108 . prim-begin0)
|
||||
(109 . prim-#%app)
|
||||
(110 . prim-lambda)
|
||||
(111 . prim-case-lambda)
|
||||
(112 . prim-let-values)
|
||||
(113 . prim-letrec-values)
|
||||
(114 . prim-letrec-syntaxes+values)
|
||||
(115 . prim-#%datum)
|
||||
(116 . prim-#%top)
|
||||
(117 . prim-quote)
|
||||
(118 . prim-quote-syntax)
|
||||
(119 . prim-require)
|
||||
(120 . prim-require-for-syntax)
|
||||
(121 . prim-require-for-template)
|
||||
(122 . prim-provide)
|
||||
(123 . prim-set!)
|
||||
(124 . prim-let*-values)
|
||||
(125 . ,token-variable)
|
||||
(126 . ,token-enter-check)
|
||||
(127 . ,token-exit-check)
|
||||
(128 . ,token-lift-loop)
|
||||
(129 . ,token-lift)
|
||||
(130 . ,token-enter-local)
|
||||
(131 . ,token-exit-local)
|
||||
(132 . ,token-local-pre)
|
||||
(133 . ,token-local-post)
|
||||
(134 . ,token-lift-statement)
|
||||
(135 . ,token-module-lift-end-loop)
|
||||
(136 . ,token-lift/let-loop)
|
||||
(137 . ,token-module-lift-loop)
|
||||
(138 . prim-expression)
|
||||
(139 . ,token-enter-local/expr)
|
||||
(140 . ,token-exit-local/expr)
|
||||
(141 . ,token-start)
|
||||
))
|
||||
|
||||
(define (tokenize sig-n val pos)
|
||||
(let ([p (assv sig-n signal-mapping)])
|
||||
(if (pair? p)
|
||||
(make-position-token
|
||||
(cond [(procedure? (cdr p)) ((cdr p) val)]
|
||||
[(symbol? (cdr p)) (cdr p)])
|
||||
pos
|
||||
pos)
|
||||
(error 'tokenize "bad signal: ~s" sig-n))))
|
||||
(define (tokenize sig-n val pos)
|
||||
(let ([p (assv sig-n signal-mapping)])
|
||||
(if (pair? p)
|
||||
(make-position-token
|
||||
(cond [(procedure? (cdr p)) ((cdr p) val)]
|
||||
[(symbol? (cdr p)) (cdr p)])
|
||||
pos
|
||||
pos)
|
||||
(error 'tokenize "bad signal: ~s" sig-n))))
|
||||
|
||||
(define (signal->symbol sig-n)
|
||||
(cdr (assv sig-n signal-mapping)))
|
||||
|
||||
)
|
||||
(define (signal->symbol sig-n)
|
||||
(cdr (assv sig-n signal-mapping)))
|
||||
|
|
|
|||
|
|
@ -1,100 +1,100 @@
|
|||
|
||||
(module deriv-util mzscheme
|
||||
(require "deriv.ss"
|
||||
(lib "list.ss")
|
||||
(lib "plt-match.ss"))
|
||||
(require-for-syntax (lib "scheme/private/struct-info.ss"))
|
||||
#lang scheme/base
|
||||
(require (for-syntax scheme/base)
|
||||
(for-syntax scheme/private/struct-info)
|
||||
scheme/list
|
||||
scheme/match
|
||||
"deriv.ss")
|
||||
|
||||
(provide make
|
||||
(provide make
|
||||
|
||||
Wrap
|
||||
|
||||
ok-node?
|
||||
interrupted-node?
|
||||
Wrap
|
||||
|
||||
ok-node?
|
||||
interrupted-node?
|
||||
|
||||
wderiv-e1
|
||||
wderiv-e2
|
||||
wlderiv-es1
|
||||
wlderiv-es2
|
||||
wbderiv-es1
|
||||
wbderiv-es2
|
||||
wderiv-e1
|
||||
wderiv-e2
|
||||
wlderiv-es1
|
||||
wlderiv-es2
|
||||
wbderiv-es1
|
||||
wbderiv-es2
|
||||
|
||||
wderivlist-es2)
|
||||
|
||||
;; Wrap matcher
|
||||
;; Matches unwrapped, interrupted wrapped, or error wrapped
|
||||
(define-match-expander Wrap
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(Wrap S (var ...))
|
||||
(syntax/loc stx (struct S (var ...)))])))
|
||||
wderivlist-es2)
|
||||
|
||||
;; ----
|
||||
|
||||
(define (check sym pred type x)
|
||||
(unless (pred x)
|
||||
(raise-type-error sym type x)))
|
||||
|
||||
(define (ok-node? x)
|
||||
(check 'ok-node? node? "node" x)
|
||||
(and (node-z1 x) #t))
|
||||
(define (interrupted-node? x)
|
||||
(check 'interrupted-node? node? "node" x)
|
||||
(not (node-z2 x)))
|
||||
|
||||
|
||||
(define (wderiv-e1 x)
|
||||
(check 'wderiv-e1 deriv? "deriv" x)
|
||||
(node-z1 x))
|
||||
(define (wderiv-e2 x)
|
||||
(check 'wderiv-e2 deriv? "deriv" x)
|
||||
(node-z2 x))
|
||||
|
||||
(define (wlderiv-es1 x)
|
||||
(check 'wlderiv-es1 lderiv? "lderiv" x)
|
||||
(node-z1 x))
|
||||
(define (wlderiv-es2 x)
|
||||
(check 'wlderiv-es2 lderiv? "lderiv" x)
|
||||
(node-z2 x))
|
||||
|
||||
(define (wbderiv-es1 x)
|
||||
(check 'wbderiv-es1 bderiv? "bderiv" x)
|
||||
(node-z1 x))
|
||||
(define (wbderiv-es2 x)
|
||||
(check 'wbderiv-es2 bderiv? "bderiv" x))
|
||||
|
||||
;; wderivlist-es2 : (list-of WDeriv) -> (list-of Stx)/#f
|
||||
(define (wderivlist-es2 xs)
|
||||
(let ([es2 (map wderiv-e2 xs)])
|
||||
(and (andmap syntax? es2) es2)))
|
||||
|
||||
;; ----
|
||||
|
||||
(define-syntax (make stx)
|
||||
;; Wrap matcher
|
||||
;; Matches unwrapped, interrupted wrapped, or error wrapped
|
||||
(define-match-expander Wrap
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(make S expr ...)
|
||||
(unless (identifier? #'S)
|
||||
(raise-syntax-error #f "not an identifier" stx #'S))
|
||||
(let ()
|
||||
(define (no-info) (raise-syntax-error #f "not a struct" stx #'S))
|
||||
(define info
|
||||
(extract-struct-info
|
||||
(syntax-local-value #'S no-info)))
|
||||
(define constructor (list-ref info 1))
|
||||
(define accessors (list-ref info 3))
|
||||
(unless (identifier? #'constructor)
|
||||
(raise-syntax-error #f "constructor not available for struct" stx #'S))
|
||||
(unless (andmap identifier? accessors)
|
||||
(raise-syntax-error #f "incomplete info for struct type" stx #'S))
|
||||
(let ([num-slots (length accessors)]
|
||||
[num-provided (length (syntax->list #'(expr ...)))])
|
||||
(unless (= num-provided num-slots)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "wrong number of arguments for struct ~s (expected ~s)"
|
||||
(syntax-e #'S)
|
||||
num-slots)
|
||||
stx)))
|
||||
(with-syntax ([constructor constructor])
|
||||
#'(constructor expr ...)))]))
|
||||
)
|
||||
[(Wrap S (var ...))
|
||||
(syntax/loc stx (struct S (var ...)))])))
|
||||
|
||||
;; ----
|
||||
|
||||
(define (check sym pred type x)
|
||||
(unless (pred x)
|
||||
(raise-type-error sym type x)))
|
||||
|
||||
(define (ok-node? x)
|
||||
(check 'ok-node? node? "node" x)
|
||||
(and (node-z1 x) #t))
|
||||
(define (interrupted-node? x)
|
||||
(check 'interrupted-node? node? "node" x)
|
||||
(not (node-z2 x)))
|
||||
|
||||
|
||||
(define (wderiv-e1 x)
|
||||
(check 'wderiv-e1 deriv? "deriv" x)
|
||||
(node-z1 x))
|
||||
(define (wderiv-e2 x)
|
||||
(check 'wderiv-e2 deriv? "deriv" x)
|
||||
(node-z2 x))
|
||||
|
||||
(define (wlderiv-es1 x)
|
||||
(check 'wlderiv-es1 lderiv? "lderiv" x)
|
||||
(node-z1 x))
|
||||
(define (wlderiv-es2 x)
|
||||
(check 'wlderiv-es2 lderiv? "lderiv" x)
|
||||
(node-z2 x))
|
||||
|
||||
(define (wbderiv-es1 x)
|
||||
(check 'wbderiv-es1 bderiv? "bderiv" x)
|
||||
(node-z1 x))
|
||||
(define (wbderiv-es2 x)
|
||||
(check 'wbderiv-es2 bderiv? "bderiv" x))
|
||||
|
||||
;; wderivlist-es2 : (list-of WDeriv) -> (list-of Stx)/#f
|
||||
(define (wderivlist-es2 xs)
|
||||
(let ([es2 (map wderiv-e2 xs)])
|
||||
(and (andmap syntax? es2) es2)))
|
||||
|
||||
;; ----
|
||||
|
||||
(define-syntax (make stx)
|
||||
(syntax-case stx ()
|
||||
[(make S expr ...)
|
||||
(unless (identifier? #'S)
|
||||
(raise-syntax-error #f "not an identifier" stx #'S))
|
||||
(let ()
|
||||
(define (no-info) (raise-syntax-error #f "not a struct" stx #'S))
|
||||
(define info
|
||||
(extract-struct-info
|
||||
(syntax-local-value #'S no-info)))
|
||||
(define constructor (list-ref info 1))
|
||||
(define accessors (list-ref info 3))
|
||||
(unless (identifier? #'constructor)
|
||||
(raise-syntax-error #f "constructor not available for struct" stx #'S))
|
||||
(unless (andmap identifier? accessors)
|
||||
(raise-syntax-error #f "incomplete info for struct type" stx #'S))
|
||||
(let ([num-slots (length accessors)]
|
||||
[num-provided (length (syntax->list #'(expr ...)))])
|
||||
(unless (= num-provided num-slots)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "wrong number of arguments for struct ~s (expected ~s)"
|
||||
(syntax-e #'S)
|
||||
num-slots)
|
||||
stx)))
|
||||
(with-syntax ([constructor constructor])
|
||||
#'(constructor expr ...)))]))
|
||||
|
|
|
|||
|
|
@ -1,370 +1,368 @@
|
|||
|
||||
(module deriv mzscheme
|
||||
(require (lib "contract.ss")
|
||||
(lib "stx.ss" "syntax")
|
||||
"deriv-c.ss")
|
||||
#lang scheme/base
|
||||
(require scheme/contract
|
||||
syntax/stx
|
||||
"deriv-c.ss")
|
||||
|
||||
;; NO CONTRACTS
|
||||
|
||||
#;(provide (all-from "deriv-c.ss"))
|
||||
(provide (all-from-out "deriv-c.ss"))
|
||||
|
||||
;; CONTRACTS
|
||||
|
||||
(define (?? c) (or/c c false/c))
|
||||
#|
|
||||
|
||||
(define (stx? x)
|
||||
(or (syntax? x)
|
||||
(and (pair? x) (stx? (car x)) (stx? (cdr x)))
|
||||
(null? x)))
|
||||
|
||||
(define (stx-list-like? x)
|
||||
(let ([x (stx->list x)])
|
||||
(and x (andmap syntax? x))))
|
||||
(define (?? c) (or/c c false/c))
|
||||
|
||||
(define syntax/f (?? syntax?))
|
||||
(define syntaxes/c stx-list-like?)
|
||||
(define syntaxes/f (?? syntaxes/c))
|
||||
(define resolves/c (listof identifier?))
|
||||
(define (stx? x)
|
||||
(or (syntax? x)
|
||||
(and (pair? x) (stx? (car x)) (stx? (cdr x)))
|
||||
(null? x)))
|
||||
|
||||
(define localaction/c
|
||||
(or/c local-expansion? local-expansion/expr? local-lift?
|
||||
local-lift-end? local-bind?))
|
||||
|
||||
(provide/contract
|
||||
(struct node
|
||||
([z1 any/c]
|
||||
[z2 any/c]))
|
||||
(struct (deriv node)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]))
|
||||
(struct (lift-deriv deriv)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[first deriv?]
|
||||
[lift-stx syntax?]
|
||||
[second deriv?]))
|
||||
(struct (mrule deriv)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[transformation transformation?]
|
||||
[next (?? deriv?)]))
|
||||
(struct (lift/let-deriv deriv)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[first deriv?]
|
||||
[lift-stx syntax?]
|
||||
[second deriv?]))
|
||||
(struct (transformation node)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[me1 (?? syntax?)]
|
||||
[locals (?? (listof localaction/c))]
|
||||
[?2 (?? exn?)]
|
||||
[me2 (?? syntax?)]
|
||||
[seq number?]))
|
||||
(struct (local-expansion node)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[me1 syntax?]
|
||||
[me2 syntax/f]
|
||||
[for-stx? boolean?]
|
||||
[inner deriv?]))
|
||||
(struct (local-expansion/expr node)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[me1 syntax?]
|
||||
[me2 syntax/f]
|
||||
[for-stx? boolean?]
|
||||
[opaque any/c]
|
||||
[inner deriv?]))
|
||||
(struct local-lift
|
||||
([expr syntax?]
|
||||
[id identifier?]))
|
||||
(struct local-lift-end
|
||||
([decl syntax?]))
|
||||
(struct local-bind
|
||||
([bindrhs bind-syntaxes?]))
|
||||
(struct (base deriv)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (prule base)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:variable prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:module prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[one-body-form? boolean?]
|
||||
[mb (?? deriv?)]
|
||||
[?2 (?? exn?)]
|
||||
[body (?? deriv?)]))
|
||||
(struct (p:#%module-begin prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[pass1 (?? (listof modrule?))]
|
||||
[pass2 (?? (listof modrule?))]
|
||||
[?2 (?? exn?)]))
|
||||
(struct (p:define-syntaxes prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[rhs (?? deriv?)]
|
||||
[?2 (?? exn?)]))
|
||||
(struct (p:define-values prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[rhs (?? deriv?)]))
|
||||
(struct (p:#%expression prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[inner (?? deriv?)]))
|
||||
(struct (p:if prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[full? boolean?]
|
||||
[test (?? deriv?)]
|
||||
[then (?? deriv?)]
|
||||
[else (?? deriv?)]))
|
||||
(struct (p:wcm prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[key (?? deriv?)]
|
||||
[mark (?? deriv?)]
|
||||
[body (?? deriv?)]))
|
||||
(struct (p:set! prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[id-resolves (?? resolves/c)]
|
||||
[rhs (?? deriv?)]))
|
||||
(struct (p:set!-macro prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[deriv (?? deriv?)]))
|
||||
(struct (p:#%app prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[tagged-stx syntax/f]
|
||||
[lderiv (?? lderiv?)]))
|
||||
(struct (p:begin prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[lderiv (?? lderiv?)]))
|
||||
(struct (p:begin0 prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[first (?? deriv?)]
|
||||
[lderiv (?? lderiv?)]))
|
||||
(struct (p:lambda prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[renames any/c] ;; fixme
|
||||
[body (?? bderiv?)]))
|
||||
(struct (p:case-lambda prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[renames+bodies (listof clc?)]))
|
||||
(struct (p:let-values prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[renames any/c] ;; fixme
|
||||
[rhss (?? (listof deriv?))]
|
||||
[body (?? bderiv?)]))
|
||||
(struct (p:letrec-values prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[renames any/c] ;; fixme
|
||||
[rhss (?? (listof deriv?))]
|
||||
[body (?? bderiv?)]))
|
||||
(struct (p:letrec-syntaxes+values prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[srenames any/c] ;; fixme
|
||||
[sbindrhss (?? (listof bind-syntaxes?))]
|
||||
[vrenames any/c] ;; fixme
|
||||
[vrhss (?? (listof deriv?))]
|
||||
[body (?? bderiv?)]))
|
||||
(struct (p::STOP prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:stop p::STOP)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:unknown p::STOP)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:#%top p::STOP)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[tagged-stx syntax/f]))
|
||||
(struct (p:#%datum p::STOP)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[tagged-stx syntax/f]))
|
||||
(struct (p:quote p::STOP)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:quote-syntax p::STOP)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:require p::STOP)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:require-for-syntax p::STOP)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:require-for-template p::STOP)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:provide p::STOP)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:rename prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[renames any/c]
|
||||
[inner (?? deriv?)]))
|
||||
(struct (p:synth prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[subterms (?? (listof subitem?))]
|
||||
[?2 (?? exn?)]))
|
||||
(define (stx-list-like? x)
|
||||
(let ([x (stx->list x)])
|
||||
(and x (andmap syntax? x))))
|
||||
|
||||
(struct (lderiv node)
|
||||
([z1 stx?]
|
||||
[z2 syntaxes/f]
|
||||
[?1 (?? exn?)]
|
||||
[derivs (?? (listof deriv?))]))
|
||||
(struct (bderiv node)
|
||||
([z1 stx?]
|
||||
[z2 syntaxes/f]
|
||||
[pass1 (?? (listof (or/c b:error? brule?)))]
|
||||
[trans (symbols 'list 'letrec)]
|
||||
[pass2 (?? lderiv?)]))
|
||||
(define syntax/f (?? syntax?))
|
||||
(define syntaxes/c stx-list-like?)
|
||||
(define syntaxes/f (?? syntaxes/c))
|
||||
(define resolves/c (listof identifier?))
|
||||
|
||||
(struct b:error
|
||||
([?1 exn?]))
|
||||
(struct brule
|
||||
([renames any/c]))
|
||||
(struct (b:expr brule)
|
||||
([renames any/c]
|
||||
[head deriv?]))
|
||||
(struct (b:splice brule)
|
||||
([renames any/c]
|
||||
[head deriv?]
|
||||
[?1 (?? exn?)]
|
||||
[tail (?? stx?)]
|
||||
[?2 (?? exn?)]))
|
||||
(struct (b:defvals brule)
|
||||
([renames any/c]
|
||||
[head deriv?]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (b:defstx brule)
|
||||
([renames any/c]
|
||||
[head deriv?]
|
||||
[?1 (?? exn?)]
|
||||
[bindrhs (?? bind-syntaxes?)]))
|
||||
(define localaction/c
|
||||
(or/c local-expansion? local-expansion/expr? local-lift?
|
||||
local-lift-end? local-bind?))
|
||||
|
||||
(struct bind-syntaxes
|
||||
([rhs deriv?]
|
||||
[?1 (?? exn?)]))
|
||||
(provide/contract
|
||||
(struct node
|
||||
([z1 any/c]
|
||||
[z2 any/c]))
|
||||
(struct (deriv node)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]))
|
||||
(struct (lift-deriv deriv)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[first deriv?]
|
||||
[lift-stx syntax?]
|
||||
[second deriv?]))
|
||||
(struct (mrule deriv)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[transformation transformation?]
|
||||
[next (?? deriv?)]))
|
||||
(struct (lift/let-deriv deriv)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[first deriv?]
|
||||
[lift-stx syntax?]
|
||||
[second deriv?]))
|
||||
(struct (transformation node)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[me1 (?? syntax?)]
|
||||
[locals (?? (listof localaction/c))]
|
||||
[?2 (?? exn?)]
|
||||
[me2 (?? syntax?)]
|
||||
[seq number?]))
|
||||
(struct (local-expansion node)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[me1 syntax?]
|
||||
[me2 syntax/f]
|
||||
[for-stx? boolean?]
|
||||
[inner deriv?]))
|
||||
(struct (local-expansion/expr node)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[me1 syntax?]
|
||||
[me2 syntax/f]
|
||||
[for-stx? boolean?]
|
||||
[opaque any/c]
|
||||
[inner deriv?]))
|
||||
(struct local-lift
|
||||
([expr syntax?]
|
||||
[id identifier?]))
|
||||
(struct local-lift-end
|
||||
([decl syntax?]))
|
||||
(struct local-bind
|
||||
([bindrhs bind-syntaxes?]))
|
||||
(struct (base deriv)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (prule base)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:variable prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:module prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[one-body-form? boolean?]
|
||||
[mb (?? deriv?)]
|
||||
[?2 (?? exn?)]
|
||||
[body (?? deriv?)]))
|
||||
(struct (p:#%module-begin prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[pass1 (?? (listof modrule?))]
|
||||
[pass2 (?? (listof modrule?))]
|
||||
[?2 (?? exn?)]))
|
||||
(struct (p:define-syntaxes prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[rhs (?? deriv?)]
|
||||
[?2 (?? exn?)]))
|
||||
(struct (p:define-values prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[rhs (?? deriv?)]))
|
||||
(struct (p:#%expression prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[inner (?? deriv?)]))
|
||||
(struct (p:if prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[full? boolean?]
|
||||
[test (?? deriv?)]
|
||||
[then (?? deriv?)]
|
||||
[else (?? deriv?)]))
|
||||
(struct (p:wcm prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[key (?? deriv?)]
|
||||
[mark (?? deriv?)]
|
||||
[body (?? deriv?)]))
|
||||
(struct (p:set! prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[id-resolves (?? resolves/c)]
|
||||
[rhs (?? deriv?)]))
|
||||
(struct (p:set!-macro prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[deriv (?? deriv?)]))
|
||||
(struct (p:#%app prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[tagged-stx syntax/f]
|
||||
[lderiv (?? lderiv?)]))
|
||||
(struct (p:begin prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[lderiv (?? lderiv?)]))
|
||||
(struct (p:begin0 prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[first (?? deriv?)]
|
||||
[lderiv (?? lderiv?)]))
|
||||
(struct (p:lambda prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[renames any/c] ;; fixme
|
||||
[body (?? bderiv?)]))
|
||||
(struct (p:case-lambda prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[renames+bodies (listof clc?)]))
|
||||
(struct (p:let-values prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[renames any/c] ;; fixme
|
||||
[rhss (?? (listof deriv?))]
|
||||
[body (?? bderiv?)]))
|
||||
(struct (p:letrec-values prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[renames any/c] ;; fixme
|
||||
[rhss (?? (listof deriv?))]
|
||||
[body (?? bderiv?)]))
|
||||
(struct (p:letrec-syntaxes+values prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[srenames any/c] ;; fixme
|
||||
[sbindrhss (?? (listof bind-syntaxes?))]
|
||||
[vrenames any/c] ;; fixme
|
||||
[vrhss (?? (listof deriv?))]
|
||||
[body (?? bderiv?)]))
|
||||
(struct (p::STOP prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:stop p::STOP)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:unknown p::STOP)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:#%top p::STOP)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[tagged-stx syntax/f]))
|
||||
(struct (p:#%datum p::STOP)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[tagged-stx syntax/f]))
|
||||
(struct (p:quote p::STOP)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:quote-syntax p::STOP)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:require p::STOP)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:require-for-syntax p::STOP)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:require-for-template p::STOP)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:provide p::STOP)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (p:rename prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[renames any/c]
|
||||
[inner (?? deriv?)]))
|
||||
(struct (p:synth prule)
|
||||
([z1 syntax?]
|
||||
[z2 syntax/f]
|
||||
[resolves resolves/c]
|
||||
[?1 (?? exn?)]
|
||||
[subterms (?? (listof subitem?))]
|
||||
[?2 (?? exn?)]))
|
||||
|
||||
(struct clc
|
||||
([?1 (?? exn?)]
|
||||
[renames any/c]
|
||||
[body (?? bderiv?)]))
|
||||
(struct (lderiv node)
|
||||
([z1 stx?]
|
||||
[z2 syntaxes/f]
|
||||
[?1 (?? exn?)]
|
||||
[derivs (?? (listof deriv?))]))
|
||||
(struct (bderiv node)
|
||||
([z1 stx?]
|
||||
[z2 syntaxes/f]
|
||||
[pass1 (?? (listof (or/c b:error? brule?)))]
|
||||
[trans (symbols 'list 'letrec)]
|
||||
[pass2 (?? lderiv?)]))
|
||||
|
||||
(struct modrule ())
|
||||
(struct (mod:cons modrule)
|
||||
([head deriv?]))
|
||||
(struct (mod:prim modrule)
|
||||
([head deriv?]
|
||||
[prim (?? deriv?)]))
|
||||
(struct (mod:skip modrule) ())
|
||||
(struct (mod:splice modrule)
|
||||
([head deriv?]
|
||||
[?1 (?? exn?)]
|
||||
[tail (?? stx?)]))
|
||||
(struct (mod:lift modrule)
|
||||
([head deriv?]
|
||||
[tail syntaxes/c]))
|
||||
(struct (mod:lift-end modrule)
|
||||
([tail syntaxes/c]))
|
||||
(struct b:error
|
||||
([?1 exn?]))
|
||||
(struct brule
|
||||
([renames any/c]))
|
||||
(struct (b:expr brule)
|
||||
([renames any/c]
|
||||
[head deriv?]))
|
||||
(struct (b:splice brule)
|
||||
([renames any/c]
|
||||
[head deriv?]
|
||||
[?1 (?? exn?)]
|
||||
[tail (?? stx?)]
|
||||
[?2 (?? exn?)]))
|
||||
(struct (b:defvals brule)
|
||||
([renames any/c]
|
||||
[head deriv?]
|
||||
[?1 (?? exn?)]))
|
||||
(struct (b:defstx brule)
|
||||
([renames any/c]
|
||||
[head deriv?]
|
||||
[?1 (?? exn?)]
|
||||
[bindrhs (?? bind-syntaxes?)]))
|
||||
|
||||
(struct subitem ())
|
||||
(struct (s:subterm subitem)
|
||||
([path any/c]
|
||||
[deriv deriv?]))
|
||||
(struct (s:rename subitem)
|
||||
([path any/c]
|
||||
[before syntax?]
|
||||
[after syntax?]))
|
||||
))
|
||||
(struct bind-syntaxes
|
||||
([rhs deriv?]
|
||||
[?1 (?? exn?)]))
|
||||
|
||||
(struct clc
|
||||
([?1 (?? exn?)]
|
||||
[renames any/c]
|
||||
[body (?? bderiv?)]))
|
||||
|
||||
(struct modrule ())
|
||||
(struct (mod:cons modrule)
|
||||
([head deriv?]))
|
||||
(struct (mod:prim modrule)
|
||||
([head deriv?]
|
||||
[prim (?? deriv?)]))
|
||||
(struct (mod:skip modrule) ())
|
||||
(struct (mod:splice modrule)
|
||||
([head deriv?]
|
||||
[?1 (?? exn?)]
|
||||
[tail (?? stx?)]))
|
||||
(struct (mod:lift modrule)
|
||||
([head deriv?]
|
||||
[tail syntaxes/c]))
|
||||
(struct (mod:lift-end modrule)
|
||||
([tail syntaxes/c]))
|
||||
|
||||
(struct subitem ())
|
||||
(struct (s:subterm subitem)
|
||||
([path any/c]
|
||||
[deriv deriv?]))
|
||||
(struct (s:rename subitem)
|
||||
([path any/c]
|
||||
[before syntax?]
|
||||
[after syntax?])))
|
||||
|#
|
||||
|
|
|
|||
|
|
@ -1,100 +1,101 @@
|
|||
|
||||
(module hiding-policies mzscheme
|
||||
(require (lib "plt-match.ss")
|
||||
(lib "boundmap.ss" "syntax"))
|
||||
(provide (all-defined))
|
||||
#lang scheme/base
|
||||
(require (for-syntax scheme/base)
|
||||
scheme/match
|
||||
syntax/boundmap)
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define-struct hiding-policy
|
||||
(opaque-modules opaque-ids opaque-kernel opaque-libs transparent-ids))
|
||||
(define-struct hiding-policy
|
||||
(opaque-modules opaque-ids opaque-kernel opaque-libs transparent-ids)
|
||||
#:mutable)
|
||||
|
||||
(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 (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 (policy-hide-kernel p)
|
||||
(set-hiding-policy-opaque-kernel! p #t))
|
||||
(define (policy-unhide-kernel p)
|
||||
(set-hiding-policy-opaque-kernel! p #f))
|
||||
(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 (policy-hide-libs p)
|
||||
(set-hiding-policy-opaque-libs! p #t))
|
||||
(define (policy-unhide-libs p)
|
||||
(set-hiding-policy-opaque-libs! p #f))
|
||||
(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 (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-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 (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 (new-hiding-policy)
|
||||
(make-hiding-policy (make-hash-table)
|
||||
(make-module-identifier-mapping)
|
||||
#f
|
||||
#f
|
||||
(make-module-identifier-mapping)))
|
||||
|
||||
;; ---
|
||||
|
||||
(define-syntax inline
|
||||
(syntax-rules ()
|
||||
[(inline ([name expr] ...) . body)
|
||||
(let-syntax ([name
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[xx (identifier? #'xx) #'expr]))] ...)
|
||||
. body)]))
|
||||
(define (new-standard-hiding-policy)
|
||||
(let ([p (new-hiding-policy)])
|
||||
(policy-hide-kernel p)
|
||||
(policy-hide-libs p)
|
||||
p))
|
||||
|
||||
(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-syntax inline
|
||||
(syntax-rules ()
|
||||
[(inline ([name expr] ...) . body)
|
||||
(let-syntax ([name
|
||||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
[xx (identifier? #'xx) #'expr]))] ...)
|
||||
. body)]))
|
||||
|
||||
(define (lib-module? 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)]
|
||||
[else #f]))))
|
||||
)
|
||||
(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 (lib-module? 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)]
|
||||
[else #f]))))
|
||||
|
|
|
|||
|
|
@ -1,444 +1,445 @@
|
|||
|
||||
#lang scheme/base
|
||||
|
||||
(require (for-syntax scheme/base)
|
||||
scheme/list
|
||||
scheme/contract
|
||||
"deriv.ss"
|
||||
"stx-util.ss"
|
||||
"steps.ss")
|
||||
(provide (all-from-out "steps.ss")
|
||||
context
|
||||
big-context
|
||||
current-derivation
|
||||
current-definites
|
||||
learn-definites
|
||||
current-frontier
|
||||
add-frontier
|
||||
blaze-frontier
|
||||
rename-frontier
|
||||
with-context
|
||||
with-derivation
|
||||
with-new-local-context
|
||||
|
||||
RSunit
|
||||
RSzero
|
||||
RSbind
|
||||
RSadd
|
||||
RSseq
|
||||
RSforeach
|
||||
RS-steps
|
||||
|
||||
CC
|
||||
R
|
||||
revappend
|
||||
|
||||
walk
|
||||
walk/foci
|
||||
walk/mono
|
||||
stumble
|
||||
stumble/E)
|
||||
|
||||
;; FIXME: Steps are pairs of Configurations
|
||||
;; Configurations contain contexts, definites, etc.
|
||||
|
||||
(module reductions-engine mzscheme
|
||||
(require (lib "list.ss")
|
||||
"deriv.ss"
|
||||
"stx-util.ss"
|
||||
"steps.ss")
|
||||
(require (lib "contract.ss"))
|
||||
(provide (all-from "steps.ss"))
|
||||
;; context: parameter of Context
|
||||
(define context (make-parameter null))
|
||||
|
||||
(provide context
|
||||
big-context
|
||||
current-derivation
|
||||
current-definites
|
||||
learn-definites
|
||||
current-frontier
|
||||
add-frontier
|
||||
blaze-frontier
|
||||
rename-frontier
|
||||
with-context
|
||||
with-derivation
|
||||
with-new-local-context
|
||||
;; big-context: parameter of BigContext
|
||||
(define big-context (make-parameter null))
|
||||
|
||||
RSunit
|
||||
RSzero
|
||||
RSbind
|
||||
RSadd
|
||||
RSseq
|
||||
RSforeach
|
||||
RS-steps
|
||||
|
||||
CC
|
||||
R
|
||||
revappend)
|
||||
(provide walk
|
||||
walk/foci
|
||||
walk/mono
|
||||
stumble
|
||||
stumble/E)
|
||||
;; current-derivation : parameter of Derivation
|
||||
(define current-derivation (make-parameter #f))
|
||||
|
||||
;; context: parameter of Context
|
||||
(define context (make-parameter null))
|
||||
;; current-definites : parameter of (list-of identifier)
|
||||
(define current-definites (make-parameter null))
|
||||
|
||||
;; big-context: parameter of BigContext
|
||||
(define big-context (make-parameter null))
|
||||
;; current-frontier : parameter of (list-of syntax)
|
||||
(define current-frontier (make-parameter null))
|
||||
|
||||
;; current-derivation : parameter of Derivation
|
||||
(define current-derivation (make-parameter #f))
|
||||
(define-syntax with-context
|
||||
(syntax-rules ()
|
||||
[(with-context f . body)
|
||||
(let ([c (context)])
|
||||
(parameterize ([context (cons f c)])
|
||||
(let () . body)))]))
|
||||
|
||||
;; current-definites : parameter of (list-of identifier)
|
||||
(define current-definites (make-parameter null))
|
||||
(define-syntax with-derivation
|
||||
(syntax-rules ()
|
||||
[(with-derivation d . body)
|
||||
(parameterize ((current-derivation d)) . body)]))
|
||||
|
||||
;; current-frontier : parameter of (list-of syntax)
|
||||
(define current-frontier (make-parameter null))
|
||||
(define-syntax with-new-local-context
|
||||
(syntax-rules ()
|
||||
[(with-new-local-context e . body)
|
||||
(parameterize ([big-context
|
||||
(cons (make-bigframe (current-derivation) (context) (list e) e)
|
||||
(big-context))]
|
||||
[context null])
|
||||
. body)]))
|
||||
|
||||
(define-syntax with-context
|
||||
(syntax-rules ()
|
||||
[(with-context f . body)
|
||||
(let ([c (context)])
|
||||
(parameterize ([context (cons f c)])
|
||||
(let () . body)))]))
|
||||
(define (learn-definites ids)
|
||||
(current-definites
|
||||
(append ids (current-definites))))
|
||||
|
||||
(define-syntax with-derivation
|
||||
(syntax-rules ()
|
||||
[(with-derivation d . body)
|
||||
(parameterize ((current-derivation d)) . body)]))
|
||||
|
||||
(define-syntax with-new-local-context
|
||||
(syntax-rules ()
|
||||
[(with-new-local-context e . body)
|
||||
(parameterize ([big-context
|
||||
(cons (make-bigframe (current-derivation) (context) (list e) e)
|
||||
(big-context))]
|
||||
[context null])
|
||||
. body)]))
|
||||
(define (get-frontier) (or (current-frontier) null))
|
||||
|
||||
(define (learn-definites ids)
|
||||
(current-definites
|
||||
(append ids (current-definites))))
|
||||
(define (add-frontier stxs)
|
||||
(current-frontier
|
||||
(let ([frontier0 (current-frontier)])
|
||||
(and frontier0 (append stxs frontier0)))))
|
||||
|
||||
(define (get-frontier) (or (current-frontier) null))
|
||||
|
||||
(define (add-frontier stxs)
|
||||
(current-frontier
|
||||
(let ([frontier0 (current-frontier)])
|
||||
(and frontier0 (append stxs frontier0)))))
|
||||
|
||||
(define (blaze-frontier stx)
|
||||
(current-frontier
|
||||
(let ([frontier0 (current-frontier)])
|
||||
(and frontier0
|
||||
(remq stx frontier0)))))
|
||||
(define (blaze-frontier stx)
|
||||
(current-frontier
|
||||
(let ([frontier0 (current-frontier)])
|
||||
(and frontier0
|
||||
(remq stx frontier0)))))
|
||||
|
||||
;; -----------------------------------
|
||||
;; -----------------------------------
|
||||
|
||||
;; RS: The "reductions monad"
|
||||
;; (RS a) = (values ReductionSequence ?a ?exn)
|
||||
;; Not a proper monad, because of 'values'
|
||||
|
||||
(define-syntax ->RS/c
|
||||
(syntax-rules ()
|
||||
[(->RS/c domain-c ...)
|
||||
(-> domain-c ...
|
||||
(values (listof protostep?) any/c (or/c exn? false/c)))]))
|
||||
|
||||
(define/contract RSzero
|
||||
(->RS/c)
|
||||
(lambda () (values null #f #f)))
|
||||
|
||||
(define/contract RSunit
|
||||
(->RS/c any/c)
|
||||
(lambda (v)
|
||||
(values null v #f)))
|
||||
|
||||
(define/contract RSbind
|
||||
(->RS/c (->RS/c) (->RS/c any/c))
|
||||
(lambda (a f)
|
||||
(let-values ([(rseq1 final1 exn1) (a)])
|
||||
(if (not exn1)
|
||||
(let-values ([(rseq2 final2 exn2) (f final1)])
|
||||
(values (append rseq1 rseq2) final2 exn2))
|
||||
(values rseq1 final1 exn1)))))
|
||||
;; RS: The "reductions monad"
|
||||
;; (RS a) = (values ReductionSequence ?a ?exn)
|
||||
;; Not a proper monad, because of 'values'
|
||||
|
||||
(define/contract RSseq
|
||||
(->RS/c (->RS/c) (->RS/c))
|
||||
(lambda (a b)
|
||||
(RSbind a (lambda (_) (b)))))
|
||||
(define-syntax ->RS/c
|
||||
(syntax-rules ()
|
||||
[(->RS/c domain-c ...)
|
||||
(-> domain-c ...
|
||||
(values (listof protostep?) any/c (or/c exn? false/c)))]))
|
||||
|
||||
(define/contract RSforeach
|
||||
(->RS/c (->RS/c any/c) (listof any/c))
|
||||
(lambda (f xs)
|
||||
(let loop ([xs xs])
|
||||
(if (pair? xs)
|
||||
(RSseq (lambda () (f (car xs)))
|
||||
(lambda () (loop (cdr xs))))
|
||||
(RSunit (void))))))
|
||||
|
||||
(define/contract RSadd
|
||||
(->RS/c (listof protostep?) (->RS/c))
|
||||
(lambda (steps a)
|
||||
(let-values ([(rseq1 final1 exn1) (a)])
|
||||
(values (append steps rseq1) final1 exn1))))
|
||||
(define/contract RSzero
|
||||
(->RS/c)
|
||||
(lambda () (values null #f #f)))
|
||||
|
||||
(define-syntax RS-steps
|
||||
(syntax-rules ()
|
||||
[(RS-steps expr)
|
||||
(let-values ([(rseq final exn) expr])
|
||||
rseq)]))
|
||||
|
||||
;; CC
|
||||
;; the context constructor
|
||||
(define-syntax (CC stx)
|
||||
(syntax-case stx ()
|
||||
[(CC HOLE expr pattern)
|
||||
#'(syntax-copier HOLE expr pattern)]))
|
||||
(define/contract RSunit
|
||||
(->RS/c any/c)
|
||||
(lambda (v)
|
||||
(values null v #f)))
|
||||
|
||||
;; (R stx R-clause ...)
|
||||
;; 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]
|
||||
;; [#:rename/no-step pattern stx stx]
|
||||
;; [#:reductions expr]
|
||||
;; [#:learn ids]
|
||||
;; [#:frontier stxs]
|
||||
;; [#:when test R-clause ...]
|
||||
;; [#:if/np test R-clause ...]
|
||||
;; [generator hole fill]
|
||||
|
||||
;; R
|
||||
;; the threaded reductions engine
|
||||
(define/contract RSbind
|
||||
(->RS/c (->RS/c) (->RS/c any/c))
|
||||
(lambda (a f)
|
||||
(let-values ([(rseq1 final1 exn1) (a)])
|
||||
(if (not exn1)
|
||||
(let-values ([(rseq2 final2 exn2) (f final1)])
|
||||
(values (append rseq1 rseq2) final2 exn2))
|
||||
(values rseq1 final1 exn1)))))
|
||||
|
||||
;; (R form . clauses) : (values (list-of Step) ?stx ?exn)
|
||||
(define/contract RSseq
|
||||
(->RS/c (->RS/c) (->RS/c))
|
||||
(lambda (a b)
|
||||
(RSbind a (lambda (_) (b)))))
|
||||
|
||||
(define-syntax R
|
||||
(syntax-rules ()
|
||||
[(R form . clauses)
|
||||
(R** #f _ [#:set-syntax form] . clauses)]))
|
||||
|
||||
(define-syntax R**
|
||||
(syntax-rules (! =>)
|
||||
;; Base: done
|
||||
[(R** form-var pattern)
|
||||
(RSunit form-var)]
|
||||
|
||||
;; Base: explicit continuation
|
||||
[(R** f p => k)
|
||||
(k f)]
|
||||
|
||||
;; Error-point case
|
||||
[(R** f p [! maybe-exn] . more)
|
||||
(let ([x maybe-exn])
|
||||
(unless (or (not x) (exn? x))
|
||||
(raise-type-error 'R "exception" x))
|
||||
(if x
|
||||
(values (list (stumble f x)) #f x)
|
||||
(R** f p . more)))]
|
||||
|
||||
;; Change patterns
|
||||
[(R** f p [#:pattern p2] . more)
|
||||
(R** f p2 . more)]
|
||||
|
||||
;; Bind pattern variables
|
||||
[(R** f p [#:bind pattern rhs] . more)
|
||||
(with-syntax ([pattern (with-syntax ([p f]) rhs)])
|
||||
(R** f p . more))]
|
||||
|
||||
;; Bind variables
|
||||
[(R** f p [#:let-values (var ...) rhs] . more)
|
||||
(let-values ([(var ...) (with-syntax ([p f]) rhs)])
|
||||
(R** f p . more))]
|
||||
|
||||
;; Change syntax
|
||||
[(R** f p [#:set-syntax form] . more)
|
||||
(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)
|
||||
(with-syntax ([p f])
|
||||
(values form2 description))])
|
||||
(RSadd (list (walk f form2-var description-var))
|
||||
(lambda () (R** form2-var 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])
|
||||
(values form2 foci1 foci2 description))])
|
||||
(rename-frontier f form2-var)
|
||||
(with-context (make-renames foci1-var foci2-var)
|
||||
(RSadd (list (walk/foci foci1-var foci2-var
|
||||
f form2-var
|
||||
description-var))
|
||||
(lambda () (R** form2-var p . more)))))]
|
||||
|
||||
;; Change syntax with rename (but no step)
|
||||
[(R** f p [#:rename/no-step pvar from to] . more)
|
||||
(let-values ([(from-var to-var)
|
||||
(with-syntax ([p f]) (values from to))])
|
||||
(let ([f2 (with-syntax ([p f])
|
||||
(with-syntax ([pvar to])
|
||||
(syntax p)))])
|
||||
(rename-frontier from-var to-var)
|
||||
(with-context (make-renames from-var to-var)
|
||||
(R** f2 p . more))))]
|
||||
|
||||
;; Add in arbitrary other steps
|
||||
[(R** f p [#:reductions steps] . more)
|
||||
(RSseq (lambda () steps)
|
||||
(lambda () (R** f p . more)))]
|
||||
|
||||
;; Add to definites
|
||||
[(R** f p [#:learn ids] . more)
|
||||
(begin (learn-definites (with-syntax ([p f]) ids))
|
||||
(R** f p . more))]
|
||||
|
||||
;; Add to frontier
|
||||
[(R** f p [#:frontier stxs] . more)
|
||||
(begin (add-frontier (with-syntax ([p f]) stxs))
|
||||
(R** f p . more))]
|
||||
|
||||
;; Conditional (pattern changes lost afterwards ...)
|
||||
[(R** f p [#:if/np test [consequent ...] [alternate ...]] . more)
|
||||
(let ([continue (lambda (f2) (R** f2 p . more))])
|
||||
(if (with-syntax ([p f]) test)
|
||||
(R** f p consequent ... => continue)
|
||||
(R** f p alternate ... => continue)))]
|
||||
|
||||
;; Conditional (pattern changes lost afterwards ...)
|
||||
[(R** f p [#:when/np test consequent ...] . more)
|
||||
(let ([continue (lambda (f2) (R** f2 p . more))])
|
||||
(if (with-syntax ([p f]) test)
|
||||
(R** f p consequent ... => continue)
|
||||
(continue f)))]
|
||||
|
||||
;; Conditional
|
||||
[(R** f p [#:when test consequent ...] . more)
|
||||
(define/contract RSforeach
|
||||
(->RS/c (->RS/c any/c) (listof any/c))
|
||||
(lambda (f xs)
|
||||
(let loop ([xs xs])
|
||||
(if (pair? xs)
|
||||
(RSseq (lambda () (f (car xs)))
|
||||
(lambda () (loop (cdr xs))))
|
||||
(RSunit (void))))))
|
||||
|
||||
(define/contract RSadd
|
||||
(->RS/c (listof protostep?) (->RS/c))
|
||||
(lambda (steps a)
|
||||
(let-values ([(rseq1 final1 exn1) (a)])
|
||||
(values (append steps rseq1) final1 exn1))))
|
||||
|
||||
(define-syntax RS-steps
|
||||
(syntax-rules ()
|
||||
[(RS-steps expr)
|
||||
(let-values ([(rseq final exn) expr])
|
||||
rseq)]))
|
||||
|
||||
;; CC
|
||||
;; the context constructor
|
||||
(define-syntax (CC stx)
|
||||
(syntax-case stx ()
|
||||
[(CC HOLE expr pattern)
|
||||
#'(syntax-copier HOLE expr pattern)]))
|
||||
|
||||
;; (R stx R-clause ...)
|
||||
;; 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]
|
||||
;; [#:rename/no-step pattern stx stx]
|
||||
;; [#:reductions expr]
|
||||
;; [#:learn ids]
|
||||
;; [#:frontier stxs]
|
||||
;; [#:when test R-clause ...]
|
||||
;; [#: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)]))
|
||||
|
||||
(define-syntax R**
|
||||
(syntax-rules (! =>)
|
||||
;; Base: done
|
||||
[(R** form-var pattern)
|
||||
(RSunit form-var)]
|
||||
|
||||
;; Base: explicit continuation
|
||||
[(R** f p => k)
|
||||
(k f)]
|
||||
|
||||
;; Error-point case
|
||||
[(R** f p [! maybe-exn] . more)
|
||||
(let ([x maybe-exn])
|
||||
(unless (or (not x) (exn? x))
|
||||
(raise-type-error 'R "exception" x))
|
||||
(if x
|
||||
(values (list (stumble f x)) #f x)
|
||||
(R** f p . more)))]
|
||||
|
||||
;; Change patterns
|
||||
[(R** f p [#:pattern p2] . more)
|
||||
(R** f p2 . more)]
|
||||
|
||||
;; Bind pattern variables
|
||||
[(R** f p [#:bind pattern rhs] . more)
|
||||
(with-syntax ([pattern (with-syntax ([p f]) rhs)])
|
||||
(R** f p . more))]
|
||||
|
||||
;; Bind variables
|
||||
[(R** f p [#:let-values (var ...) rhs] . more)
|
||||
(let-values ([(var ...) (with-syntax ([p f]) rhs)])
|
||||
(R** f p . more))]
|
||||
|
||||
;; Change syntax
|
||||
[(R** f p [#:set-syntax form] . more)
|
||||
(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)
|
||||
(with-syntax ([p f])
|
||||
(values form2 description))])
|
||||
(RSadd (list (walk f form2-var description-var))
|
||||
(lambda () (R** form2-var 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])
|
||||
(values form2 foci1 foci2 description))])
|
||||
(rename-frontier f form2-var)
|
||||
(with-context (make-renames foci1-var foci2-var)
|
||||
(RSadd (list (walk/foci foci1-var foci2-var
|
||||
f form2-var
|
||||
description-var))
|
||||
(lambda () (R** form2-var p . more)))))]
|
||||
|
||||
;; Change syntax with rename (but no step)
|
||||
[(R** f p [#:rename/no-step pvar from to] . more)
|
||||
(let-values ([(from-var to-var)
|
||||
(with-syntax ([p f]) (values from to))])
|
||||
(let ([f2 (with-syntax ([p f])
|
||||
(with-syntax ([pvar to])
|
||||
(syntax p)))])
|
||||
(rename-frontier from-var to-var)
|
||||
(with-context (make-renames from-var to-var)
|
||||
(R** f2 p . more))))]
|
||||
|
||||
;; Add in arbitrary other steps
|
||||
[(R** f p [#:reductions steps] . more)
|
||||
(RSseq (lambda () steps)
|
||||
(lambda () (R** f p . more)))]
|
||||
|
||||
;; Add to definites
|
||||
[(R** f p [#:learn ids] . more)
|
||||
(begin (learn-definites (with-syntax ([p f]) ids))
|
||||
(R** f p . more))]
|
||||
|
||||
;; Add to frontier
|
||||
[(R** f p [#:frontier stxs] . more)
|
||||
(begin (add-frontier (with-syntax ([p f]) stxs))
|
||||
(R** f p . more))]
|
||||
|
||||
;; Conditional (pattern changes lost afterwards ...)
|
||||
[(R** f p [#:if/np test [consequent ...] [alternate ...]] . more)
|
||||
(let ([continue (lambda (f2) (R** f2 p . more))])
|
||||
(if (with-syntax ([p f]) test)
|
||||
(R** f p consequent ... . more)
|
||||
(R** f p . more))]
|
||||
|
||||
;; Subterm handling
|
||||
[(R** f p [generator hole fill] . more)
|
||||
(let ([k (lambda (f2) (R** f2 p . more))])
|
||||
(Run f p generator hole fill k))]))
|
||||
(R** f p consequent ... => continue)
|
||||
(R** f p alternate ... => continue)))]
|
||||
|
||||
;; Conditional (pattern changes lost afterwards ...)
|
||||
[(R** f p [#:when/np test consequent ...] . more)
|
||||
(let ([continue (lambda (f2) (R** f2 p . more))])
|
||||
(if (with-syntax ([p f]) test)
|
||||
(R** f p consequent ... => continue)
|
||||
(continue f)))]
|
||||
|
||||
;; Conditional
|
||||
[(R** f p [#:when test consequent ...] . more)
|
||||
(if (with-syntax ([p f]) test)
|
||||
(R** f p consequent ... . more)
|
||||
(R** f p . more))]
|
||||
|
||||
;; Subterm handling
|
||||
[(R** f p [generator hole fill] . more)
|
||||
(let ([k (lambda (f2) (R** f2 p . more))])
|
||||
(Run f p generator hole fill k))]))
|
||||
|
||||
|
||||
(define-syntax Run
|
||||
(syntax-rules ()
|
||||
[(Run f p generator hole fill k)
|
||||
(let ([reducer (with-syntax ([p f]) (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)
|
||||
(and (identifier? #':::)
|
||||
(module-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)))]
|
||||
;; 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-multiple : (a -> RS(b)) ((list-of b) -> c) (list-of a) (list-of b) (c -> RS(d))
|
||||
;; -> RS(d)
|
||||
;; For example: a = Deriv; b = c = d = Syntax
|
||||
(define (run-multiple f ctx fills suffix k)
|
||||
(let loop ([fills fills] [prefix null] [suffix suffix])
|
||||
(cond
|
||||
[(pair? fills)
|
||||
(RSbind (lambda ()
|
||||
(with-context ctx
|
||||
(with-context (lambda (x) (revappend prefix (cons x (cdr suffix))))
|
||||
(f (car fills)))))
|
||||
(lambda (final)
|
||||
(loop (cdr fills)
|
||||
(cons final prefix)
|
||||
(cdr suffix))))]
|
||||
[(null? fills)
|
||||
(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-syntax Run
|
||||
(syntax-rules ()
|
||||
[(Run f p generator hole fill k)
|
||||
(let ([reducer (with-syntax ([p f]) (generator))])
|
||||
(Run* reducer f p hole fill k))]))
|
||||
|
||||
(define (rename-frontier from to)
|
||||
(current-frontier
|
||||
(with-handlers ([exn:fail? (lambda _ #f)])
|
||||
(apply append
|
||||
(map (make-rename-mapping from to)
|
||||
(current-frontier))))))
|
||||
|
||||
(define (make-rename-mapping from0 to0)
|
||||
(define table (make-hash-table))
|
||||
(let loop ([from from0] [to to0])
|
||||
(cond [(syntax? from)
|
||||
(hash-table-put! table from (flatten-syntaxes to))
|
||||
(loop (syntax-e from) to)]
|
||||
[(syntax? to)
|
||||
(loop from (syntax-e to))]
|
||||
[(pair? from)
|
||||
#;(unless (pair? to)
|
||||
(fprintf (current-error-port)
|
||||
"from:\n~s\n\n" (syntax-object->datum from0))
|
||||
(fprintf (current-error-port)
|
||||
"to:\n~s\n\n" (syntax-object->datum to0))
|
||||
(error 'frontier-renaming))
|
||||
(loop (car from) (car to))
|
||||
(loop (cdr from) (cdr to))]
|
||||
[(vector? from)
|
||||
(loop (vector->list from) (vector->list to))]
|
||||
[(box? from)
|
||||
(loop (unbox from) (unbox to))]
|
||||
[else (void)]))
|
||||
(lambda (stx)
|
||||
(let ([replacement (hash-table-get table stx #f)])
|
||||
(if replacement
|
||||
(begin #;(printf " replacing ~s with ~s~n" stx replacement)
|
||||
replacement)
|
||||
(begin #;(printf " not replacing ~s~n" stx)
|
||||
(list stx))))))
|
||||
(define-syntax (Run* stx)
|
||||
(syntax-case stx ()
|
||||
;; Implementation of subterm handling for (hole ...) sequences
|
||||
[(Run* f form-var pattern (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)))]
|
||||
;; 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))]))
|
||||
|
||||
(define (flatten-syntaxes x)
|
||||
(cond [(syntax? x)
|
||||
(list x)]
|
||||
[(pair? x)
|
||||
(append (flatten-syntaxes (car x))
|
||||
(flatten-syntaxes (cdr x)))]
|
||||
[(vector? x)
|
||||
(flatten-syntaxes (vector->list x))]
|
||||
[(box? x)
|
||||
(flatten-syntaxes (unbox x))]
|
||||
[else null]))
|
||||
;; run-multiple : (a -> RS(b)) ((list-of b) -> c) (list-of a) (list-of b) (c -> RS(d))
|
||||
;; -> RS(d)
|
||||
;; For example: a = Deriv; b = c = d = Syntax
|
||||
(define (run-multiple f ctx fills suffix k)
|
||||
(let loop ([fills fills] [prefix null] [suffix suffix])
|
||||
(cond
|
||||
[(pair? fills)
|
||||
(RSbind (lambda ()
|
||||
(with-context ctx
|
||||
(with-context (lambda (x) (revappend prefix (cons x (cdr suffix))))
|
||||
(f (car fills)))))
|
||||
(lambda (final)
|
||||
(loop (cdr fills)
|
||||
(cons final prefix)
|
||||
(cdr suffix))))]
|
||||
[(null? fills)
|
||||
(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)))))
|
||||
|
||||
;; walk : syntax(es) syntax(es) StepType -> Reduction
|
||||
;; Lifts a local step into a term step.
|
||||
(define (walk e1 e2 type)
|
||||
(make-step (current-derivation) (big-context) type (context)
|
||||
(current-definites) (get-frontier)
|
||||
(foci e1) (foci e2) e1 e2))
|
||||
|
||||
;; walk/foci : syntaxes syntaxes syntax syntax StepType -> Reduction
|
||||
(define (walk/foci foci1 foci2 Ee1 Ee2 type)
|
||||
(make-step (current-derivation) (big-context) type (context)
|
||||
(current-definites) (get-frontier)
|
||||
(foci foci1) (foci foci2) Ee1 Ee2))
|
||||
;; Rename mapping
|
||||
|
||||
;; walk/mono : syntax StepType -> Reduction
|
||||
(define (walk/mono e1 type)
|
||||
(make-mono (current-derivation) (big-context) type (context)
|
||||
(current-definites) (get-frontier)
|
||||
(foci e1) e1))
|
||||
|
||||
;; stumble : syntax exception -> Reduction
|
||||
(define (stumble stx exn)
|
||||
(make-misstep (current-derivation) (big-context) 'error (context)
|
||||
(current-definites) (get-frontier)
|
||||
(foci stx) stx exn))
|
||||
|
||||
;; stumble/E : syntax(s) syntax exn -> Reduction
|
||||
(define (stumble/E focus Ee1 exn)
|
||||
(make-misstep (current-derivation) (big-context) 'error (context)
|
||||
(current-definites) (get-frontier)
|
||||
(foci focus) Ee1 exn))
|
||||
|
||||
;; ------------------------------------
|
||||
|
||||
(define (revappend a b)
|
||||
(cond [(pair? a) (revappend (cdr a) (cons (car a) b))]
|
||||
[(null? a) b]))
|
||||
(define (rename-frontier from to)
|
||||
(current-frontier
|
||||
(with-handlers ([exn:fail? (lambda _ #f)])
|
||||
(apply append
|
||||
(map (make-rename-mapping from to)
|
||||
(current-frontier))))))
|
||||
|
||||
(define (foci x)
|
||||
(if (list? x)
|
||||
x
|
||||
(list x)))
|
||||
)
|
||||
(define (make-rename-mapping from0 to0)
|
||||
(define table (make-hash-table))
|
||||
(let loop ([from from0] [to to0])
|
||||
(cond [(syntax? from)
|
||||
(hash-table-put! table from (flatten-syntaxes to))
|
||||
(loop (syntax-e from) to)]
|
||||
[(syntax? to)
|
||||
(loop from (syntax-e to))]
|
||||
[(pair? from)
|
||||
#;(unless (pair? to)
|
||||
(fprintf (current-error-port)
|
||||
"from:\n~s\n\n" (syntax->datum from0))
|
||||
(fprintf (current-error-port)
|
||||
"to:\n~s\n\n" (syntax->datum to0))
|
||||
(error 'frontier-renaming))
|
||||
(loop (car from) (car to))
|
||||
(loop (cdr from) (cdr to))]
|
||||
[(vector? from)
|
||||
(loop (vector->list from) (vector->list to))]
|
||||
[(box? from)
|
||||
(loop (unbox from) (unbox to))]
|
||||
[else (void)]))
|
||||
(lambda (stx)
|
||||
(let ([replacement (hash-table-get table stx #f)])
|
||||
(if replacement
|
||||
(begin #;(printf " replacing ~s with ~s~n" stx replacement)
|
||||
replacement)
|
||||
(begin #;(printf " not replacing ~s~n" stx)
|
||||
(list stx))))))
|
||||
|
||||
(define (flatten-syntaxes x)
|
||||
(cond [(syntax? x)
|
||||
(list x)]
|
||||
[(pair? x)
|
||||
(append (flatten-syntaxes (car x))
|
||||
(flatten-syntaxes (cdr x)))]
|
||||
[(vector? x)
|
||||
(flatten-syntaxes (vector->list x))]
|
||||
[(box? x)
|
||||
(flatten-syntaxes (unbox x))]
|
||||
[else null]))
|
||||
|
||||
;; -----------------------------------
|
||||
|
||||
;; walk : syntax(es) syntax(es) StepType -> Reduction
|
||||
;; Lifts a local step into a term step.
|
||||
(define (walk e1 e2 type)
|
||||
(make-step (current-derivation) (big-context) type (context)
|
||||
(current-definites) (get-frontier)
|
||||
(foci e1) (foci e2) e1 e2))
|
||||
|
||||
;; walk/foci : syntaxes syntaxes syntax syntax StepType -> Reduction
|
||||
(define (walk/foci foci1 foci2 Ee1 Ee2 type)
|
||||
(make-step (current-derivation) (big-context) type (context)
|
||||
(current-definites) (get-frontier)
|
||||
(foci foci1) (foci foci2) Ee1 Ee2))
|
||||
|
||||
;; walk/mono : syntax StepType -> Reduction
|
||||
(define (walk/mono e1 type)
|
||||
(make-mono (current-derivation) (big-context) type (context)
|
||||
(current-definites) (get-frontier)
|
||||
(foci e1) e1))
|
||||
|
||||
;; stumble : syntax exception -> Reduction
|
||||
(define (stumble stx exn)
|
||||
(make-misstep (current-derivation) (big-context) 'error (context)
|
||||
(current-definites) (get-frontier)
|
||||
(foci stx) stx exn))
|
||||
|
||||
;; stumble/E : syntax(s) syntax exn -> Reduction
|
||||
(define (stumble/E focus Ee1 exn)
|
||||
(make-misstep (current-derivation) (big-context) 'error (context)
|
||||
(current-definites) (get-frontier)
|
||||
(foci focus) Ee1 exn))
|
||||
|
||||
;; ------------------------------------
|
||||
|
||||
(define (revappend a b)
|
||||
(cond [(pair? a) (revappend (cdr a) (cons (car a) b))]
|
||||
[(null? a) b]))
|
||||
|
||||
(define (foci x)
|
||||
(if (list? x)
|
||||
x
|
||||
(list x)))
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,116 +1,115 @@
|
|||
|
||||
(module steps mzscheme
|
||||
(require "deriv.ss"
|
||||
"deriv-util.ss"
|
||||
"deriv-find.ss")
|
||||
(provide (all-defined))
|
||||
#lang scheme/base
|
||||
(require "deriv.ss"
|
||||
"deriv-util.ss"
|
||||
"deriv-find.ss")
|
||||
(provide (all-defined-out))
|
||||
|
||||
;; A ReductionSequence is a (list-of Reduction)
|
||||
;; A ReductionSequence is a (list-of Reduction)
|
||||
|
||||
;; A ProtoStep is (make-protostep Derivation BigContext StepType Context Definites)
|
||||
;; A ProtoStep is (make-protostep Derivation BigContext StepType Context Definites)
|
||||
|
||||
;; A Context is a list of Frames
|
||||
;; A Frame is either:
|
||||
;; - (syntax -> syntax)
|
||||
;; - (make-renames syntax syntax)
|
||||
;; - 'phase-up
|
||||
(define-struct renames (old new))
|
||||
;; A Context is a list of Frames
|
||||
;; A Frame is either:
|
||||
;; - (syntax -> syntax)
|
||||
;; - (make-renames syntax syntax)
|
||||
;; - 'phase-up
|
||||
(define-struct renames (old new))
|
||||
|
||||
;; A Definite is a (list-of identifier)
|
||||
;; A Definite is a (list-of identifier)
|
||||
|
||||
;; A BigContext is (list-of BigFrame)
|
||||
;; A BigFrame is (make-bigframe Derivation Context Syntaxes Syntax)
|
||||
(define-struct bigframe (deriv ctx foci e))
|
||||
;; A BigContext is (list-of BigFrame)
|
||||
;; A BigFrame is (make-bigframe Derivation Context Syntaxes Syntax)
|
||||
(define-struct bigframe (deriv ctx foci e))
|
||||
|
||||
;; A Reduction is one of
|
||||
;; - (make-step ... Syntaxes Syntaxes Syntax Syntax)
|
||||
;; - (make-mono ... Syntaxes Syntax)
|
||||
;; - (make-misstep ... Syntax Syntax Exception)
|
||||
;; A Reduction is one of
|
||||
;; - (make-step ... Syntaxes Syntaxes Syntax Syntax)
|
||||
;; - (make-mono ... Syntaxes Syntax)
|
||||
;; - (make-misstep ... Syntax Syntax Exception)
|
||||
|
||||
(define-struct protostep (deriv lctx type ctx definites frontier) #f)
|
||||
(define-struct protostep (deriv lctx type ctx definites frontier) #:transparent)
|
||||
|
||||
(define-struct (step protostep) (foci1 foci2 e1 e2) #f)
|
||||
(define-struct (mono protostep) (foci1 e1) #f)
|
||||
(define-struct (misstep protostep) (foci1 e1 exn) #f)
|
||||
(define-struct (step protostep) (foci1 foci2 e1 e2) #:transparent)
|
||||
(define-struct (mono protostep) (foci1 e1) #:transparent)
|
||||
(define-struct (misstep protostep) (foci1 e1 exn) #:transparent)
|
||||
|
||||
;; context-fill : Context Syntax -> Syntax
|
||||
(define (context-fill ctx stx)
|
||||
(let loop ([ctx ctx] [stx stx])
|
||||
(if (null? ctx)
|
||||
stx
|
||||
(let ([frame0 (car ctx)])
|
||||
(if (procedure? frame0)
|
||||
(loop (cdr ctx) (frame0 stx))
|
||||
(loop (cdr ctx) stx))))))
|
||||
;; context-fill : Context Syntax -> Syntax
|
||||
(define (context-fill ctx stx)
|
||||
(let loop ([ctx ctx] [stx stx])
|
||||
(if (null? ctx)
|
||||
stx
|
||||
(let ([frame0 (car ctx)])
|
||||
(if (procedure? frame0)
|
||||
(loop (cdr ctx) (frame0 stx))
|
||||
(loop (cdr ctx) stx))))))
|
||||
|
||||
;; context-env : Context -> (list-of identifier)
|
||||
(define (context-env ctx)
|
||||
(let loop ([ctx ctx] [env null])
|
||||
(if (null? ctx)
|
||||
env
|
||||
(let ([frame0 (car ctx)])
|
||||
(if (renames? frame0)
|
||||
(loop (cdr ctx)
|
||||
(append (flatten-identifiers (renames-new frame0))
|
||||
env))
|
||||
(loop (cdr ctx) env))))))
|
||||
;; context-env : Context -> (list-of identifier)
|
||||
(define (context-env ctx)
|
||||
(let loop ([ctx ctx] [env null])
|
||||
(if (null? ctx)
|
||||
env
|
||||
(let ([frame0 (car ctx)])
|
||||
(if (renames? frame0)
|
||||
(loop (cdr ctx)
|
||||
(append (flatten-identifiers (renames-new frame0))
|
||||
env))
|
||||
(loop (cdr ctx) env))))))
|
||||
|
||||
(define (step-term1 s)
|
||||
(context-fill (protostep-ctx s) (step-e1 s)))
|
||||
(define (step-term2 s)
|
||||
(context-fill (protostep-ctx s) (step-e2 s)))
|
||||
(define (step-term1 s)
|
||||
(context-fill (protostep-ctx s) (step-e1 s)))
|
||||
(define (step-term2 s)
|
||||
(context-fill (protostep-ctx s) (step-e2 s)))
|
||||
|
||||
(define (mono-term1 s)
|
||||
(context-fill (protostep-ctx s) (mono-e1 s)))
|
||||
(define (mono-term1 s)
|
||||
(context-fill (protostep-ctx s) (mono-e1 s)))
|
||||
|
||||
(define (misstep-term1 s)
|
||||
(context-fill (protostep-ctx s) (misstep-e1 s)))
|
||||
(define (misstep-term1 s)
|
||||
(context-fill (protostep-ctx s) (misstep-e1 s)))
|
||||
|
||||
(define (bigframe-term bf)
|
||||
(context-fill (bigframe-ctx bf) (bigframe-e bf)))
|
||||
(define (bigframe-term bf)
|
||||
(context-fill (bigframe-ctx bf) (bigframe-e bf)))
|
||||
|
||||
;; A StepType is a simple in the following alist.
|
||||
;; A StepType is a simple in the following alist.
|
||||
|
||||
(define step-type-meanings
|
||||
'((macro . "Macro transformation")
|
||||
|
||||
(rename-lambda . "Rename formal parameters")
|
||||
(rename-case-lambda . "Rename formal parameters")
|
||||
(rename-let-values . "Rename bound variables")
|
||||
(rename-letrec-values . "Rename bound variables")
|
||||
(rename-lsv . "Rename bound variables")
|
||||
(lsv-remove-syntax . "Remove syntax bindings")
|
||||
(define step-type-meanings
|
||||
'((macro . "Macro transformation")
|
||||
|
||||
(rename-lambda . "Rename formal parameters")
|
||||
(rename-case-lambda . "Rename formal parameters")
|
||||
(rename-let-values . "Rename bound variables")
|
||||
(rename-letrec-values . "Rename bound variables")
|
||||
(rename-lsv . "Rename bound variables")
|
||||
(lsv-remove-syntax . "Remove syntax bindings")
|
||||
|
||||
(resolve-variable . "Resolve variable (remove extra marks)")
|
||||
(tag-module-begin . "Tag #%module-begin")
|
||||
(tag-app . "Tag application")
|
||||
(tag-datum . "Tag datum")
|
||||
(tag-top . "Tag top-level variable")
|
||||
(capture-lifts . "Capture lifts")
|
||||
(resolve-variable . "Resolve variable (remove extra marks)")
|
||||
(tag-module-begin . "Tag #%module-begin")
|
||||
(tag-app . "Tag application")
|
||||
(tag-datum . "Tag datum")
|
||||
(tag-top . "Tag top-level variable")
|
||||
(capture-lifts . "Capture lifts")
|
||||
|
||||
(local-lift . "Macro lifted expression to top-level")
|
||||
(module-lift . "Macro lifted declaration to end of module")
|
||||
(block->letrec . "Transform block to letrec")
|
||||
(splice-block . "Splice block-level begin")
|
||||
(splice-module . "Splice module-level begin")
|
||||
(splice-lifts . "Splice definitions from lifted expressions")
|
||||
(splice-module-lifts . "Splice lifted module declarations")
|
||||
(local-lift . "Macro lifted expression to top-level")
|
||||
(module-lift . "Macro lifted declaration to end of module")
|
||||
(block->letrec . "Transform block to letrec")
|
||||
(splice-block . "Splice block-level begin")
|
||||
(splice-module . "Splice module-level begin")
|
||||
(splice-lifts . "Splice definitions from lifted expressions")
|
||||
(splice-module-lifts . "Splice lifted module declarations")
|
||||
|
||||
(error . "Error")))
|
||||
(error . "Error")))
|
||||
|
||||
(define (step-type->string x)
|
||||
(cond [(assq x step-type-meanings) => cdr]
|
||||
[(string? x) x]
|
||||
[else (error 'step-type->string "not a step type: ~s" x)]))
|
||||
(define (step-type->string x)
|
||||
(cond [(assq x step-type-meanings) => cdr]
|
||||
[(string? x) x]
|
||||
[else (error 'step-type->string "not a step type: ~s" x)]))
|
||||
|
||||
(define (rename-step? x)
|
||||
(memq (protostep-type x)
|
||||
'(rename-lambda
|
||||
rename-case-lambda
|
||||
rename-let-values
|
||||
rename-letrec-values
|
||||
rename-lsv)))
|
||||
(define (rename-step? x)
|
||||
(memq (protostep-type x)
|
||||
'(rename-lambda
|
||||
rename-case-lambda
|
||||
rename-let-values
|
||||
rename-letrec-values
|
||||
rename-lsv)))
|
||||
|
||||
(define (rewrite-step? x)
|
||||
(and (step? x) (not (rename-step? x))))
|
||||
)
|
||||
(define (rewrite-step? x)
|
||||
(and (step? x) (not (rename-step? x))))
|
||||
|
|
|
|||
|
|
@ -1,100 +1,99 @@
|
|||
|
||||
(module stx-util mzscheme
|
||||
(require (lib "stx.ss" "syntax"))
|
||||
|
||||
(provide (all-defined)
|
||||
(all-from (lib "stx.ss" "syntax")))
|
||||
|
||||
(define (d->so template datum)
|
||||
(if (syntax? template)
|
||||
(datum->syntax-object template datum template template)
|
||||
datum))
|
||||
|
||||
(define-syntax (syntax-copier stx)
|
||||
(syntax-case stx ()
|
||||
[(syntax-copier hole expr pattern)
|
||||
#'(let ([expr-var expr])
|
||||
(lambda (in-the-hole)
|
||||
(with-syntax ([pattern expr-var])
|
||||
(with-syntax ([hole in-the-hole])
|
||||
(syntax/restamp pattern #'pattern expr-var)))))]))
|
||||
|
||||
(define-syntax syntax/skeleton
|
||||
(syntax-rules ()
|
||||
[(syntax/skeleton old-expr pattern)
|
||||
(syntax/restamp pattern #'pattern old-expr)]))
|
||||
|
||||
|
||||
;; FIXME: Need to avoid turning syntax lists into syntax pairs
|
||||
(define-syntax (syntax/restamp stx)
|
||||
(syntax-case stx (...)
|
||||
[(syntax/restamp (pa (... ...)) new-expr old-expr)
|
||||
#`(let ([new-parts (stx->list new-expr)]
|
||||
[old-parts (stx->list old-expr)])
|
||||
;; FIXME
|
||||
(unless (= (length new-parts) (length old-parts))
|
||||
(printf "** syntax/restamp~n~s~n" (quote-syntax #,stx))
|
||||
(printf "pattern : ~s~n" (syntax-object->datum #'(pa (... ...))))
|
||||
(printf "old parts: ~s~n" (map syntax-object->datum old-parts))
|
||||
(printf "new parts: ~s~n" (map syntax-object->datum new-parts)))
|
||||
(d->so
|
||||
old-expr
|
||||
(map (lambda (new old) (syntax/restamp pa new old))
|
||||
new-parts
|
||||
old-parts)))]
|
||||
[(syntax/restamp (pa . pb) new-expr old-expr)
|
||||
;; FIXME
|
||||
#'(begin
|
||||
(unless (and (stx-pair? new-expr) (stx-pair? old-expr))
|
||||
(printf "** syntax/restamp~n~s~n" (quote-syntax #,stx))
|
||||
(printf "pattern : ~s~n" (syntax-object->datum (quote-syntax (pa . pb))))
|
||||
(printf "old parts: ~s~n" old-expr)
|
||||
(printf "new parts: ~s~n" new-expr))
|
||||
(let ([na (stx-car new-expr)]
|
||||
[nb (stx-cdr new-expr)]
|
||||
[oa (stx-car old-expr)]
|
||||
[ob (stx-cdr old-expr)])
|
||||
(d->so old-expr
|
||||
(cons (syntax/restamp pa na oa)
|
||||
(syntax/restamp pb nb ob)))))]
|
||||
[(syntax/restamp pvar new-expr old-expr)
|
||||
#'new-expr]))
|
||||
#lang scheme/base
|
||||
(require (for-syntax scheme/base)
|
||||
syntax/stx)
|
||||
|
||||
(define (iota n)
|
||||
(let loop ([i 0])
|
||||
(if (< i n)
|
||||
(cons i (loop (add1 i)))
|
||||
null)))
|
||||
(provide (all-defined-out)
|
||||
(all-from-out syntax/stx))
|
||||
|
||||
;; stx-take : syntax-list number -> (list-of syntax)
|
||||
(define (stx-take items n)
|
||||
(cond [(zero? n) null]
|
||||
[else (cons (stx-car items) (stx-take (stx-cdr items) (sub1 n)))]))
|
||||
(define (d->so template datum)
|
||||
(if (syntax? template)
|
||||
(datum->syntax template datum template template)
|
||||
datum))
|
||||
|
||||
(define (take-if-possible items n)
|
||||
(unless (number? n)
|
||||
(raise-type-error 'take-if-possible "number" n))
|
||||
(if (and (pair? items) (positive? n))
|
||||
(cons (car items) (take-if-possible (cdr items) (sub1 n)))
|
||||
null))
|
||||
(define-syntax (syntax-copier stx)
|
||||
(syntax-case stx ()
|
||||
[(syntax-copier hole expr pattern)
|
||||
#'(let ([expr-var expr])
|
||||
(lambda (in-the-hole)
|
||||
(with-syntax ([pattern expr-var])
|
||||
(with-syntax ([hole in-the-hole])
|
||||
(syntax/restamp pattern #'pattern expr-var)))))]))
|
||||
|
||||
;; stx-improper-length : syntax -> number
|
||||
(define (stx-improper-length stx)
|
||||
(let loop ([stx stx] [n 0])
|
||||
(if (stx-pair? stx)
|
||||
(loop (stx-cdr stx) (add1 n))
|
||||
n)))
|
||||
(define-syntax syntax/skeleton
|
||||
(syntax-rules ()
|
||||
[(syntax/skeleton old-expr pattern)
|
||||
(syntax/restamp pattern #'pattern old-expr)]))
|
||||
|
||||
(define (stx->list* stx)
|
||||
(cond [(pair? stx)
|
||||
(cons (car stx) (stx->list* (cdr stx)))]
|
||||
[(null? stx)
|
||||
null]
|
||||
[(syntax? stx)
|
||||
(let ([x (syntax-e stx)])
|
||||
(if (pair? x)
|
||||
(cons (car x) (stx->list* (cdr x)))
|
||||
(list stx)))]
|
||||
[else null]))
|
||||
|
||||
)
|
||||
;; FIXME: Need to avoid turning syntax lists into syntax pairs
|
||||
(define-syntax (syntax/restamp stx)
|
||||
(syntax-case stx (...)
|
||||
[(syntax/restamp (pa (... ...)) new-expr old-expr)
|
||||
#`(let ([new-parts (stx->list new-expr)]
|
||||
[old-parts (stx->list old-expr)])
|
||||
;; FIXME
|
||||
(unless (= (length new-parts) (length old-parts))
|
||||
(printf "** syntax/restamp~n~s~n" (quote-syntax #,stx))
|
||||
(printf "pattern : ~s~n" (syntax->datum #'(pa (... ...))))
|
||||
(printf "old parts: ~s~n" (map syntax->datum old-parts))
|
||||
(printf "new parts: ~s~n" (map syntax->datum new-parts)))
|
||||
(d->so
|
||||
old-expr
|
||||
(map (lambda (new old) (syntax/restamp pa new old))
|
||||
new-parts
|
||||
old-parts)))]
|
||||
[(syntax/restamp (pa . pb) new-expr old-expr)
|
||||
;; FIXME
|
||||
#'(begin
|
||||
(unless (and (stx-pair? new-expr) (stx-pair? old-expr))
|
||||
(printf "** syntax/restamp~n~s~n" (quote-syntax #,stx))
|
||||
(printf "pattern : ~s~n" (syntax->datum (quote-syntax (pa . pb))))
|
||||
(printf "old parts: ~s~n" old-expr)
|
||||
(printf "new parts: ~s~n" new-expr))
|
||||
(let ([na (stx-car new-expr)]
|
||||
[nb (stx-cdr new-expr)]
|
||||
[oa (stx-car old-expr)]
|
||||
[ob (stx-cdr old-expr)])
|
||||
(d->so old-expr
|
||||
(cons (syntax/restamp pa na oa)
|
||||
(syntax/restamp pb nb ob)))))]
|
||||
[(syntax/restamp pvar new-expr old-expr)
|
||||
#'new-expr]))
|
||||
|
||||
(define (iota n)
|
||||
(let loop ([i 0])
|
||||
(if (< i n)
|
||||
(cons i (loop (add1 i)))
|
||||
null)))
|
||||
|
||||
;; stx-take : syntax-list number -> (list-of syntax)
|
||||
(define (stx-take items n)
|
||||
(cond [(zero? n) null]
|
||||
[else (cons (stx-car items) (stx-take (stx-cdr items) (sub1 n)))]))
|
||||
|
||||
(define (take-if-possible items n)
|
||||
(unless (number? n)
|
||||
(raise-type-error 'take-if-possible "number" n))
|
||||
(if (and (pair? items) (positive? n))
|
||||
(cons (car items) (take-if-possible (cdr items) (sub1 n)))
|
||||
null))
|
||||
|
||||
;; stx-improper-length : syntax -> number
|
||||
(define (stx-improper-length stx)
|
||||
(let loop ([stx stx] [n 0])
|
||||
(if (stx-pair? stx)
|
||||
(loop (stx-cdr stx) (add1 n))
|
||||
n)))
|
||||
|
||||
(define (stx->list* stx)
|
||||
(cond [(pair? stx)
|
||||
(cons (car stx) (stx->list* (cdr stx)))]
|
||||
[(null? stx)
|
||||
null]
|
||||
[(syntax? stx)
|
||||
(let ([x (syntax-e stx)])
|
||||
(if (pair? x)
|
||||
(cons (car x) (stx->list* (cdr x)))
|
||||
(list stx)))]
|
||||
[else null]))
|
||||
|
|
|
|||
|
|
@ -1,37 +1,36 @@
|
|||
|
||||
(module trace-raw mzscheme
|
||||
(require "../syntax-browser.ss"
|
||||
(lib "class.ss")
|
||||
(lib "lex.ss" "parser-tools")
|
||||
"deriv-tokens.ss"
|
||||
"deriv-parser.ss")
|
||||
(provide (all-defined))
|
||||
#lang scheme/base
|
||||
(require scheme/class
|
||||
parser-tools/lex
|
||||
"deriv-tokens.ss"
|
||||
"deriv-parser.ss"
|
||||
"../syntax-browser.ss")
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define current-expand-observe
|
||||
(dynamic-require ''#%expobs 'current-expand-observe))
|
||||
(define current-expand-observe
|
||||
(dynamic-require ''#%expobs 'current-expand-observe))
|
||||
|
||||
(define (go-trace sexpr)
|
||||
(define events null)
|
||||
(define pos 0)
|
||||
(define browser (make-syntax-browser))
|
||||
(define (show sig+val)
|
||||
(define sig (car sig+val))
|
||||
(define val (cdr sig+val))
|
||||
(define t (tokenize sig val pos))
|
||||
(send browser add-text
|
||||
(format "Signal: ~s: ~s~n"
|
||||
pos
|
||||
(token-name (position-token-token t))))
|
||||
(when val
|
||||
(send browser add-syntax
|
||||
(datum->syntax #f val)))
|
||||
(set! pos (add1 pos)))
|
||||
(parameterize ((current-expand-observe
|
||||
(lambda (sig val)
|
||||
(define t (tokenize sig val pos))
|
||||
(set! events (cons (cons sig val) events))
|
||||
#;(show (cons sig val)))))
|
||||
(expand sexpr)
|
||||
(for-each show (reverse events))))
|
||||
|
||||
(define (go-trace sexpr)
|
||||
(define events null)
|
||||
(define pos 0)
|
||||
(define browser (make-syntax-browser))
|
||||
(define (show sig+val)
|
||||
(define sig (car sig+val))
|
||||
(define val (cdr sig+val))
|
||||
(define t (tokenize sig val pos))
|
||||
(send browser add-text
|
||||
(format "Signal: ~s: ~s~n"
|
||||
pos
|
||||
(token-name (position-token-token t))))
|
||||
(when val
|
||||
(send browser add-syntax
|
||||
(datum->syntax-object #f val)))
|
||||
(set! pos (add1 pos)))
|
||||
(parameterize ((current-expand-observe
|
||||
(lambda (sig val)
|
||||
(define t (tokenize sig val pos))
|
||||
(set! events (cons (cons sig val) events))
|
||||
#;(show (cons sig val)))))
|
||||
(expand sexpr)
|
||||
(for-each show (reverse events))))
|
||||
|
||||
)
|
||||
|
|
@ -1,73 +1,73 @@
|
|||
|
||||
(module trace mzscheme
|
||||
(require (lib "lex.ss" "parser-tools"))
|
||||
(require "deriv.ss"
|
||||
"deriv-parser.ss"
|
||||
"deriv-tokens.ss")
|
||||
#lang scheme/base
|
||||
(require scheme/promise
|
||||
parser-tools/lex
|
||||
"deriv.ss"
|
||||
"deriv-parser.ss"
|
||||
"deriv-tokens.ss")
|
||||
|
||||
(provide trace
|
||||
trace*
|
||||
trace/result
|
||||
trace-verbose?
|
||||
events->token-generator
|
||||
current-expand-observe)
|
||||
(provide trace
|
||||
trace*
|
||||
trace/result
|
||||
trace-verbose?
|
||||
events->token-generator
|
||||
current-expand-observe)
|
||||
|
||||
(define current-expand-observe
|
||||
(dynamic-require ''#%expobs 'current-expand-observe))
|
||||
(define current-expand-observe
|
||||
(dynamic-require ''#%expobs 'current-expand-observe))
|
||||
|
||||
(define trace-verbose? (make-parameter #f))
|
||||
(define trace-verbose? (make-parameter #f))
|
||||
|
||||
;; trace : stx -> Deriv
|
||||
(define (trace stx)
|
||||
(let-values ([(result events derivp) (trace* stx expand)])
|
||||
(force derivp)))
|
||||
;; trace : stx -> Deriv
|
||||
(define (trace stx)
|
||||
(let-values ([(result events derivp) (trace* stx expand)])
|
||||
(force derivp)))
|
||||
|
||||
;; trace/result : stx -> stx/exn Deriv
|
||||
(define (trace/result stx)
|
||||
(let-values ([(result events derivp) (trace* stx expand)])
|
||||
(values result
|
||||
(force derivp))))
|
||||
;; trace/result : stx -> stx/exn Deriv
|
||||
(define (trace/result stx)
|
||||
(let-values ([(result events derivp) (trace* stx expand)])
|
||||
(values result
|
||||
(force derivp))))
|
||||
|
||||
;; trace* : stx (stx -> stx) -> stx/exn (list-of event) (promise-of Deriv)
|
||||
(define (trace* stx expander)
|
||||
(let-values ([(result events) (expand/events stx expander)])
|
||||
(values result
|
||||
events
|
||||
(delay (parse-derivation
|
||||
(events->token-generator events))))))
|
||||
;; trace* : stx (stx -> stx) -> stx/exn (list-of event) (promise-of Deriv)
|
||||
(define (trace* stx expander)
|
||||
(let-values ([(result events) (expand/events stx expander)])
|
||||
(values result
|
||||
events
|
||||
(delay (parse-derivation
|
||||
(events->token-generator events))))))
|
||||
|
||||
;; events->token-generator : (list-of event) -> (-> token)
|
||||
(define (events->token-generator events)
|
||||
(let ([pos 0])
|
||||
(lambda ()
|
||||
(define sig+val (car events))
|
||||
(set! events (cdr events))
|
||||
(let* ([sig (car sig+val)]
|
||||
[val (cdr sig+val)]
|
||||
[t (tokenize sig val pos)])
|
||||
(when (trace-verbose?)
|
||||
(printf "~s: ~s~n" pos
|
||||
(token-name (position-token-token t))))
|
||||
(set! pos (add1 pos))
|
||||
t))))
|
||||
;; events->token-generator : (list-of event) -> (-> token)
|
||||
(define (events->token-generator events)
|
||||
(let ([pos 0])
|
||||
(lambda ()
|
||||
(define sig+val (car events))
|
||||
(set! events (cdr events))
|
||||
(let* ([sig (car sig+val)]
|
||||
[val (cdr sig+val)]
|
||||
[t (tokenize sig val pos)])
|
||||
(when (trace-verbose?)
|
||||
(printf "~s: ~s~n" pos
|
||||
(token-name (position-token-token t))))
|
||||
(set! pos (add1 pos))
|
||||
t))))
|
||||
|
||||
;; expand/events : stx (stx -> stx) -> stx/exn (list-of event)
|
||||
(define (expand/events sexpr expander)
|
||||
(let ([events null])
|
||||
(define (add! x)
|
||||
(set! events (cons x events)))
|
||||
(parameterize ((current-expand-observe
|
||||
(let ([c 0])
|
||||
(lambda (sig val)
|
||||
(set! c (add1 c))
|
||||
(add! (cons sig val))))))
|
||||
(let ([result
|
||||
(with-handlers ([(lambda (exn) #t)
|
||||
(lambda (exn)
|
||||
(add! (cons 'error exn))
|
||||
exn)])
|
||||
(expander sexpr))])
|
||||
(add! (cons 'EOF #f))
|
||||
(values result
|
||||
(reverse events))))))
|
||||
)
|
||||
;; expand/events : stx (stx -> stx) -> stx/exn (list-of event)
|
||||
(define (expand/events sexpr expander)
|
||||
(let ([events null])
|
||||
(define (add! x)
|
||||
(set! events (cons x events)))
|
||||
(parameterize ((current-expand-observe
|
||||
(let ([c 0])
|
||||
(lambda (sig val)
|
||||
(set! c (add1 c))
|
||||
(add! (cons sig val))))))
|
||||
(let ([result
|
||||
(with-handlers ([(lambda (exn) #t)
|
||||
(lambda (exn)
|
||||
(add! (cons 'error exn))
|
||||
exn)])
|
||||
(expander sexpr))])
|
||||
(add! (cons 'EOF #f))
|
||||
(values result
|
||||
(reverse events))))))
|
||||
|
|
|
|||
|
|
@ -1,50 +1,49 @@
|
|||
|
||||
(module yacc-ext mzscheme
|
||||
|
||||
(require (prefix yacc: (lib "yacc.ss" "parser-tools")))
|
||||
(provide parser
|
||||
options
|
||||
productions
|
||||
definitions)
|
||||
|
||||
(define-syntax options
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "options keyword used out of context" stx)))
|
||||
|
||||
(define-syntax productions
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "productions keyword used out of context" stx)))
|
||||
#lang scheme/base
|
||||
(require (prefix-in yacc: parser-tools/yacc)
|
||||
(for-syntax scheme/base))
|
||||
(provide parser
|
||||
options
|
||||
productions
|
||||
definitions)
|
||||
|
||||
(define-syntax definitions
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "definitions keyword used out of context" stx)))
|
||||
(define-syntax options
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "options keyword used out of context" stx)))
|
||||
|
||||
(define-syntax (parser stx)
|
||||
(syntax-case stx ()
|
||||
[(parser form ...)
|
||||
(let ([stop-list (list #'begin #'options #'productions #'definitions)]
|
||||
[forms (syntax->list #'(form ...))])
|
||||
(define-values (opts prods defs)
|
||||
(let loop ([forms forms] [opts null] [prods null] [defs null])
|
||||
(if (pair? forms)
|
||||
(let ([eform0 (local-expand (car forms) 'expression stop-list)]
|
||||
[forms (cdr forms)])
|
||||
(syntax-case eform0 (begin options productions definitions)
|
||||
[(begin subform ...)
|
||||
(loop (append (syntax->list #'(subform ...)) forms) opts prods defs)]
|
||||
[(options subform ...)
|
||||
(loop forms (append (syntax->list #'(subform ...)) opts) prods defs)]
|
||||
[(productions subform ...)
|
||||
(loop forms opts (append (syntax->list #'(subform ...)) prods) defs)]
|
||||
[(definitions subform ...)
|
||||
(loop forms opts prods (append (syntax->list #'(subform ...)) defs))]
|
||||
[else
|
||||
(raise-syntax-error #f "bad parser subform" eform0)]))
|
||||
(values opts prods defs))))
|
||||
(with-syntax ([(opt ...) opts]
|
||||
[(prod ...) prods]
|
||||
[(def ...) defs])
|
||||
#'(let ()
|
||||
def ...
|
||||
(#%expression (yacc:parser opt ... (grammar prod ...))))))]))
|
||||
)
|
||||
(define-syntax productions
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "productions keyword used out of context" stx)))
|
||||
|
||||
(define-syntax definitions
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "definitions keyword used out of context" stx)))
|
||||
|
||||
(define-syntax (parser stx)
|
||||
(syntax-case stx ()
|
||||
[(parser form ...)
|
||||
(let ([stop-list (list #'begin #'options #'productions #'definitions)]
|
||||
[forms (syntax->list #'(form ...))])
|
||||
(define-values (opts prods defs)
|
||||
(let loop ([forms forms] [opts null] [prods null] [defs null])
|
||||
(if (pair? forms)
|
||||
(let ([eform0 (local-expand (car forms) 'expression stop-list)]
|
||||
[forms (cdr forms)])
|
||||
(syntax-case eform0 (begin options productions definitions)
|
||||
[(begin subform ...)
|
||||
(loop (append (syntax->list #'(subform ...)) forms) opts prods defs)]
|
||||
[(options subform ...)
|
||||
(loop forms (append (syntax->list #'(subform ...)) opts) prods defs)]
|
||||
[(productions subform ...)
|
||||
(loop forms opts (append (syntax->list #'(subform ...)) prods) defs)]
|
||||
[(definitions subform ...)
|
||||
(loop forms opts prods (append (syntax->list #'(subform ...)) defs))]
|
||||
[else
|
||||
(raise-syntax-error #f "bad parser subform" eform0)]))
|
||||
(values opts prods defs))))
|
||||
(with-syntax ([(opt ...) opts]
|
||||
[(prod ...) prods]
|
||||
[(def ...) defs])
|
||||
#'(let ()
|
||||
def ...
|
||||
(#%expression (yacc:parser opt ... (grammar prod ...))))))]))
|
||||
|
|
|
|||
|
|
@ -1,302 +1,302 @@
|
|||
|
||||
(module yacc-interrupted mzscheme
|
||||
(require-for-syntax (lib "etc.ss"))
|
||||
(require "yacc-ext.ss")
|
||||
(provide ! ? !!
|
||||
define-production-splitter
|
||||
skipped-token-values
|
||||
%skipped
|
||||
%action)
|
||||
#lang scheme/base
|
||||
(require (for-syntax scheme/base)
|
||||
(for-syntax mzlib/etc)
|
||||
"yacc-ext.ss")
|
||||
(provide ! ? !!
|
||||
define-production-splitter
|
||||
skipped-token-values
|
||||
%skipped
|
||||
%action)
|
||||
|
||||
;; Grammar macros for "interrupted parses"
|
||||
;; Grammar macros for "interrupted parses"
|
||||
|
||||
(define-syntax !
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "keyword ! used out of context" stx)))
|
||||
(define-syntax !
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "keyword ! used out of context" stx)))
|
||||
|
||||
(define-syntax !!
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "keyword !! used out of context" stx)))
|
||||
(define-syntax !!
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "keyword !! used out of context" stx)))
|
||||
|
||||
(define-syntax ?
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "keyword ? used out of context" stx)))
|
||||
(define-syntax ?
|
||||
(lambda (stx)
|
||||
(raise-syntax-error #f "keyword ? used out of context" stx)))
|
||||
|
||||
(define-syntax define-production-splitter
|
||||
(syntax-rules ()
|
||||
[(define-production-splitter name ok intW)
|
||||
(define-syntax name
|
||||
(make-production-splitter #'ok #'intW))]))
|
||||
(define-syntax define-production-splitter
|
||||
(syntax-rules ()
|
||||
[(define-production-splitter name ok intW)
|
||||
(define-syntax name
|
||||
(make-production-splitter #'ok #'intW))]))
|
||||
|
||||
(define-for-syntax (partition-options/alternates forms)
|
||||
(let loop ([forms forms] [options null] [alts null])
|
||||
(if (pair? forms)
|
||||
(syntax-case (car forms) ()
|
||||
[(#:args . args)
|
||||
(loop (cdr forms) (cons (cons #:args #'args) options) alts)]
|
||||
[(#:skipped expr)
|
||||
(loop (cdr forms) (cons (cons #:skipped #'expr) options) alts)]
|
||||
[(#:wrap)
|
||||
(loop (cdr forms) (cons (cons #:wrap #t) options) alts)]
|
||||
[(#:no-wrap)
|
||||
(loop (cdr forms) (cons (cons #:no-wrap #t) options) alts)]
|
||||
[(kw . args)
|
||||
(keyword? (syntax-e #'kw))
|
||||
(raise-syntax-error 'split "bad keyword" (car forms))]
|
||||
[(pattern action)
|
||||
(loop (cdr forms) options (cons (cons #'pattern #'action) alts))]
|
||||
[other
|
||||
(raise-syntax-error 'split "bad grammar option or alternate" #'other)])
|
||||
(values options (reverse alts)))))
|
||||
(define-for-syntax (partition-options/alternates forms)
|
||||
(let loop ([forms forms] [options null] [alts null])
|
||||
(if (pair? forms)
|
||||
(syntax-case (car forms) ()
|
||||
[(#:args . args)
|
||||
(loop (cdr forms) (cons (cons '#:args #'args) options) alts)]
|
||||
[(#:skipped expr)
|
||||
(loop (cdr forms) (cons (cons '#:skipped #'expr) options) alts)]
|
||||
[(#:wrap)
|
||||
(loop (cdr forms) (cons (cons '#:wrap #t) options) alts)]
|
||||
[(#:no-wrap)
|
||||
(loop (cdr forms) (cons (cons '#:no-wrap #t) options) alts)]
|
||||
[(kw . args)
|
||||
(keyword? (syntax-e #'kw))
|
||||
(raise-syntax-error 'split "bad keyword" (car forms))]
|
||||
[(pattern action)
|
||||
(loop (cdr forms) options (cons (cons #'pattern #'action) alts))]
|
||||
[other
|
||||
(raise-syntax-error 'split "bad grammar option or alternate" #'other)])
|
||||
(values options (reverse alts)))))
|
||||
|
||||
(define-for-syntax (symbol+ . args)
|
||||
(define (norm x)
|
||||
(cond [(identifier? x) (norm (syntax-e x))]
|
||||
[(string? x) x]
|
||||
[(number? x) (number->string x)]
|
||||
[(symbol? x) (symbol->string x)]))
|
||||
(string->symbol (apply string-append (map norm args))))
|
||||
(define-for-syntax (symbol+ . args)
|
||||
(define (norm x)
|
||||
(cond [(identifier? x) (norm (syntax-e x))]
|
||||
[(string? x) x]
|
||||
[(number? x) (number->string x)]
|
||||
[(symbol? x) (symbol->string x)]))
|
||||
(string->symbol (apply string-append (map norm args))))
|
||||
|
||||
(define-for-syntax (I symbol)
|
||||
(syntax-local-introduce
|
||||
(syntax-local-get-shadower (datum->syntax-object #f symbol))))
|
||||
(define-for-syntax (I symbol)
|
||||
(syntax-local-introduce
|
||||
(syntax-local-get-shadower (datum->syntax #f symbol))))
|
||||
|
||||
(define-for-syntax ($name n)
|
||||
(I (symbol+ '$ n)))
|
||||
(define-for-syntax ($name n)
|
||||
(I (symbol+ '$ n)))
|
||||
|
||||
(define-for-syntax (interrupted-name s)
|
||||
(I (symbol+ s '/Interrupted)))
|
||||
(define-for-syntax (interrupted-name s)
|
||||
(I (symbol+ s '/Interrupted)))
|
||||
|
||||
(define-for-syntax (skipped-name s)
|
||||
(I (symbol+ s '/Skipped)))
|
||||
(define-for-syntax (skipped-name s)
|
||||
(I (symbol+ s '/Skipped)))
|
||||
|
||||
(define-for-syntax (elaborate-skipped-tail head tail position args mk-action)
|
||||
(define-values (new-tail new-arguments)
|
||||
(let loop ([parts tail] [position position] [rtail null] [arguments null])
|
||||
(syntax-case parts (? ! !!)
|
||||
[()
|
||||
(values (reverse rtail) (reverse arguments))]
|
||||
[(! . parts-rest)
|
||||
(loop #'parts-rest position rtail (cons #'#f arguments))]
|
||||
[(!! . parts-rest)
|
||||
(raise-syntax-error 'split
|
||||
"cannot have !! after potential error"
|
||||
#'!!)]
|
||||
[((? NT) . parts-rest)
|
||||
(loop #'(NT . parts-rest) position rtail arguments)]
|
||||
[(NT . parts-rest)
|
||||
(identifier? #'NT)
|
||||
(loop #'parts-rest
|
||||
(add1 position)
|
||||
(cons (skipped-name #'NT) rtail)
|
||||
(cons ($name position) arguments))])))
|
||||
(define arguments (append (reverse args) new-arguments))
|
||||
(cons #`(#,head . #,new-tail)
|
||||
(mk-action arguments)))
|
||||
|
||||
(define-for-syntax ((make-elaborate-successful-alternate wrap? okW) alt)
|
||||
(define pattern (car alt))
|
||||
(define action-function (cdr alt))
|
||||
(define-values (new-patterns arguments)
|
||||
(let loop ([parts pattern] [rpattern null] [position 1] [args null])
|
||||
(syntax-case parts (? ! !!)
|
||||
[() (values (list (reverse rpattern)) (reverse args))]
|
||||
[(! . parts-rest)
|
||||
(loop #'parts-rest rpattern position (cons #'#f args))]
|
||||
[(!!)
|
||||
(values null null)]
|
||||
[((? NT) . parts-rest)
|
||||
(loop (cons #'NT #'parts-rest) rpattern position args)]
|
||||
[(NT . parts-rest)
|
||||
(identifier? #'NT)
|
||||
(loop #'parts-rest (cons #'NT rpattern)
|
||||
(add1 position) (cons ($name position) args))])))
|
||||
(map (lambda (new-pattern)
|
||||
(cons (datum->syntax-object #f new-pattern pattern)
|
||||
#`(#,action-function #,(if wrap? okW #'values) #,@arguments)))
|
||||
new-patterns))
|
||||
|
||||
(define-for-syntax ((make-elaborate-interrupted-alternate wrap? intW) alt)
|
||||
(define pattern (car alt))
|
||||
(define action-function (cdr alt))
|
||||
(define (int-action args)
|
||||
(let ([wrapf (if wrap? #`(lambda (x) (#,intW x)) #'values)])
|
||||
#`(#,action-function #,wrapf #,@args)))
|
||||
(let loop ([parts pattern] [position 1] [args null])
|
||||
(define-for-syntax (elaborate-skipped-tail head tail position args mk-action)
|
||||
(define-values (new-tail new-arguments)
|
||||
(let loop ([parts tail] [position position] [rtail null] [arguments null])
|
||||
(syntax-case parts (? ! !!)
|
||||
[()
|
||||
;; Can't be interrupted
|
||||
null]
|
||||
(values (reverse rtail) (reverse arguments))]
|
||||
[(! . parts-rest)
|
||||
(cons
|
||||
;; Error occurs
|
||||
(elaborate-skipped-tail (I 'syntax-error)
|
||||
#'parts-rest
|
||||
(add1 position)
|
||||
(cons ($name position) args)
|
||||
int-action)
|
||||
;; Error doesn't occur
|
||||
(loop #'parts-rest position (cons #'#f args)))]
|
||||
[(!!)
|
||||
(cons
|
||||
(elaborate-skipped-tail (I 'syntax-error)
|
||||
#'()
|
||||
(add1 position)
|
||||
(cons ($name position) args)
|
||||
int-action)
|
||||
null)]
|
||||
(loop #'parts-rest position rtail (cons #'#f arguments))]
|
||||
[(!! . parts-rest)
|
||||
(raise-syntax-error 'split
|
||||
"cannot have !! after potential error"
|
||||
#'!!)]
|
||||
[((? NT) . parts-rest)
|
||||
(cons
|
||||
;; NT is interrupted
|
||||
(elaborate-skipped-tail (I (symbol+ #'NT '/Interrupted))
|
||||
#'parts-rest
|
||||
(add1 position)
|
||||
(cons ($name position) args)
|
||||
int-action)
|
||||
;; NT is not interrupted
|
||||
(loop #'(NT . parts-rest) position args))]
|
||||
[(part0 . parts-rest)
|
||||
(identifier? #'part0)
|
||||
(map (lambda (clause) (cons #`(part0 . #,(car clause)) (cdr clause)))
|
||||
(loop #'parts-rest (add1 position) (cons ($name position) args)))])))
|
||||
(loop #'(NT . parts-rest) position rtail arguments)]
|
||||
[(NT . parts-rest)
|
||||
(identifier? #'NT)
|
||||
(loop #'parts-rest
|
||||
(add1 position)
|
||||
(cons (skipped-name #'NT) rtail)
|
||||
(cons ($name position) arguments))])))
|
||||
(define arguments (append (reverse args) new-arguments))
|
||||
(cons #`(#,head . #,new-tail)
|
||||
(mk-action arguments)))
|
||||
|
||||
(define-for-syntax (generate-action-name nt pos)
|
||||
(syntax-local-get-shadower
|
||||
(datum->syntax-object #f (symbol+ 'action-for- nt '/ pos))))
|
||||
|
||||
(define-for-syntax ((make-rewrite-alt+def nt args-spec) alt pos)
|
||||
(define pattern (car alt))
|
||||
(define action (cdr alt))
|
||||
(define-values (var-indexes non-var-indexes)
|
||||
(let loop ([pattern pattern] [n 1] [vars null] [nonvars null])
|
||||
(syntax-case pattern ()
|
||||
[(first . more)
|
||||
(syntax-case #'first (! ? !!)
|
||||
[!
|
||||
(loop #'more (add1 n) (cons n vars) nonvars)]
|
||||
[(! . _)
|
||||
(define-for-syntax ((make-elaborate-successful-alternate wrap? okW) alt)
|
||||
(define pattern (car alt))
|
||||
(define action-function (cdr alt))
|
||||
(define-values (new-patterns arguments)
|
||||
(let loop ([parts pattern] [rpattern null] [position 1] [args null])
|
||||
(syntax-case parts (? ! !!)
|
||||
[() (values (list (reverse rpattern)) (reverse args))]
|
||||
[(! . parts-rest)
|
||||
(loop #'parts-rest rpattern position (cons #'#f args))]
|
||||
[(!!)
|
||||
(values null null)]
|
||||
[((? NT) . parts-rest)
|
||||
(loop (cons #'NT #'parts-rest) rpattern position args)]
|
||||
[(NT . parts-rest)
|
||||
(identifier? #'NT)
|
||||
(loop #'parts-rest (cons #'NT rpattern)
|
||||
(add1 position) (cons ($name position) args))])))
|
||||
(map (lambda (new-pattern)
|
||||
(cons (datum->syntax #f new-pattern pattern)
|
||||
#`(#,action-function #,(if wrap? okW #'values) #,@arguments)))
|
||||
new-patterns))
|
||||
|
||||
(define-for-syntax ((make-elaborate-interrupted-alternate wrap? intW) alt)
|
||||
(define pattern (car alt))
|
||||
(define action-function (cdr alt))
|
||||
(define (int-action args)
|
||||
(let ([wrapf (if wrap? #`(lambda (x) (#,intW x)) #'values)])
|
||||
#`(#,action-function #,wrapf #,@args)))
|
||||
(let loop ([parts pattern] [position 1] [args null])
|
||||
(syntax-case parts (? ! !!)
|
||||
[()
|
||||
;; Can't be interrupted
|
||||
null]
|
||||
[(! . parts-rest)
|
||||
(cons
|
||||
;; Error occurs
|
||||
(elaborate-skipped-tail (I 'syntax-error)
|
||||
#'parts-rest
|
||||
(add1 position)
|
||||
(cons ($name position) args)
|
||||
int-action)
|
||||
;; Error doesn't occur
|
||||
(loop #'parts-rest position (cons #'#f args)))]
|
||||
[(!!)
|
||||
(cons
|
||||
(elaborate-skipped-tail (I 'syntax-error)
|
||||
#'()
|
||||
(add1 position)
|
||||
(cons ($name position) args)
|
||||
int-action)
|
||||
null)]
|
||||
[((? NT) . parts-rest)
|
||||
(cons
|
||||
;; NT is interrupted
|
||||
(elaborate-skipped-tail (I (symbol+ #'NT '/Interrupted))
|
||||
#'parts-rest
|
||||
(add1 position)
|
||||
(cons ($name position) args)
|
||||
int-action)
|
||||
;; NT is not interrupted
|
||||
(loop #'(NT . parts-rest) position args))]
|
||||
[(part0 . parts-rest)
|
||||
(identifier? #'part0)
|
||||
(map (lambda (clause) (cons #`(part0 . #,(car clause)) (cdr clause)))
|
||||
(loop #'parts-rest (add1 position) (cons ($name position) args)))])))
|
||||
|
||||
(define-for-syntax (generate-action-name nt pos)
|
||||
(syntax-local-get-shadower
|
||||
(datum->syntax #f (symbol+ 'action-for- nt '/ pos))))
|
||||
|
||||
(define-for-syntax ((make-rewrite-alt+def nt args-spec) alt pos)
|
||||
(define pattern (car alt))
|
||||
(define action (cdr alt))
|
||||
(define-values (var-indexes non-var-indexes)
|
||||
(let loop ([pattern pattern] [n 1] [vars null] [nonvars null])
|
||||
(syntax-case pattern ()
|
||||
[(first . more)
|
||||
(syntax-case #'first (! ? !!)
|
||||
[!
|
||||
(loop #'more (add1 n) (cons n vars) nonvars)]
|
||||
[(! . _)
|
||||
(raise-syntax-error 'split
|
||||
"misuse of ! grammar form"
|
||||
pattern #'first)]
|
||||
[!!
|
||||
(when (pair? (syntax-e #'more))
|
||||
(raise-syntax-error 'split
|
||||
"misuse of ! grammar form"
|
||||
pattern #'first)]
|
||||
[!!
|
||||
(when (pair? (syntax-e #'more))
|
||||
(raise-syntax-error 'split
|
||||
"nothing may follow !!"
|
||||
pattern))
|
||||
(loop #'more (add1 n) (cons n vars) nonvars)]
|
||||
[(!! . _)
|
||||
(raise-syntax-error 'split
|
||||
"misuse of !! grammar form"
|
||||
pattern #'first)]
|
||||
[(? NT)
|
||||
(identifier? #'NT)
|
||||
(loop #'more (add1 n) (cons n vars) nonvars)]
|
||||
[(? . _)
|
||||
(raise-syntax-error 'split
|
||||
"misuse of ? grammar form"
|
||||
pattern #'first)]
|
||||
[NT
|
||||
(identifier? #'NT)
|
||||
(loop #'more (add1 n) (cons n vars) nonvars)]
|
||||
[other
|
||||
(raise-syntax-error 'rewrite-pattern
|
||||
"invalid grammar pattern"
|
||||
pattern #'first)])]
|
||||
[()
|
||||
(values (reverse vars) (reverse nonvars))])))
|
||||
(define variables (map $name var-indexes))
|
||||
(define non-var-names (map $name non-var-indexes))
|
||||
(define action-function (generate-action-name nt pos))
|
||||
(cons (cons pattern action-function)
|
||||
(with-syntax ([(var ...) variables]
|
||||
[(nonvar ...) non-var-names]
|
||||
[action-function action-function]
|
||||
[action action])
|
||||
#`(define (action-function wrap var ...)
|
||||
(let-syntax ([nonvar invalid-$name-use] ...)
|
||||
#,(if args-spec
|
||||
#`(lambda #,args-spec (wrap action))
|
||||
#`(wrap action)))))))
|
||||
"nothing may follow !!"
|
||||
pattern))
|
||||
(loop #'more (add1 n) (cons n vars) nonvars)]
|
||||
[(!! . _)
|
||||
(raise-syntax-error 'split
|
||||
"misuse of !! grammar form"
|
||||
pattern #'first)]
|
||||
[(? NT)
|
||||
(identifier? #'NT)
|
||||
(loop #'more (add1 n) (cons n vars) nonvars)]
|
||||
[(? . _)
|
||||
(raise-syntax-error 'split
|
||||
"misuse of ? grammar form"
|
||||
pattern #'first)]
|
||||
[NT
|
||||
(identifier? #'NT)
|
||||
(loop #'more (add1 n) (cons n vars) nonvars)]
|
||||
[other
|
||||
(raise-syntax-error 'rewrite-pattern
|
||||
"invalid grammar pattern"
|
||||
pattern #'first)])]
|
||||
[()
|
||||
(values (reverse vars) (reverse nonvars))])))
|
||||
(define variables (map $name var-indexes))
|
||||
(define non-var-names (map $name non-var-indexes))
|
||||
(define action-function (generate-action-name nt pos))
|
||||
(cons (cons pattern action-function)
|
||||
(with-syntax ([(var ...) variables]
|
||||
[(nonvar ...) non-var-names]
|
||||
[action-function action-function]
|
||||
[action action])
|
||||
#`(define (action-function wrap var ...)
|
||||
(let-syntax ([nonvar invalid-$name-use] ...)
|
||||
#,(if args-spec
|
||||
#`(lambda #,args-spec (wrap action))
|
||||
#`(wrap action)))))))
|
||||
|
||||
(define-for-syntax (invalid-$name-use stx)
|
||||
(raise-syntax-error #f "no value for positional variable" stx))
|
||||
(define-for-syntax (invalid-$name-use stx)
|
||||
(raise-syntax-error #f "no value for positional variable" stx))
|
||||
|
||||
;; An alternate is (cons pattern action-expr)
|
||||
;; An alternate* is (cons pattern action-function-name)
|
||||
;; An alternate is (cons pattern action-expr)
|
||||
;; An alternate* is (cons pattern action-function-name)
|
||||
|
||||
(define-for-syntax ((make-production-splitter okW intW) stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (name form ...))
|
||||
(let ()
|
||||
(define-values (options alternates0)
|
||||
(partition-options/alternates (syntax->list #'(form ...))))
|
||||
(define wrap?
|
||||
(let ([wrap? (assq #:wrap options)]
|
||||
[no-wrap? (assq #:no-wrap options)])
|
||||
(unless (and (or wrap? no-wrap?) (not (and wrap? no-wrap?)))
|
||||
(raise-syntax-error 'split
|
||||
"must specify exactly one of #:wrap, #:no-wrap"
|
||||
stx))
|
||||
(and wrap? #t)))
|
||||
(define args-spec
|
||||
(let ([p (assq #:args options)]) (and p (cdr p))))
|
||||
(define rewrite-alt+def (make-rewrite-alt+def #'name args-spec))
|
||||
(define alternates+definitions
|
||||
(map rewrite-alt+def alternates0 (build-list (length alternates0) add1)))
|
||||
(define alternates (map car alternates+definitions))
|
||||
(define action-definitions (map cdr alternates+definitions))
|
||||
(define elaborate-successful-alternate
|
||||
(make-elaborate-successful-alternate wrap? okW))
|
||||
(define elaborate-interrupted-alternate
|
||||
(make-elaborate-interrupted-alternate wrap? intW))
|
||||
(define successful-alternates
|
||||
(apply append (map elaborate-successful-alternate alternates)))
|
||||
(define interrupted-alternates
|
||||
(apply append (map elaborate-interrupted-alternate alternates)))
|
||||
(with-syntax ([((success-pattern . success-action) ...)
|
||||
successful-alternates]
|
||||
[((interrupted-pattern . interrupted-action) ...)
|
||||
interrupted-alternates]
|
||||
[skip-spec (assq #:skipped options)]
|
||||
[args-spec (assq #:args options)]
|
||||
[name/Skipped (I (symbol+ #'name '/Skipped))]
|
||||
[name/Interrupted (I (symbol+ #'name '/Interrupted))]
|
||||
[%action ((syntax-local-certifier) #'%action)])
|
||||
#`(begin
|
||||
(definitions #,@action-definitions)
|
||||
(productions
|
||||
(name [success-pattern success-action] ...)
|
||||
#,(if (pair? interrupted-alternates)
|
||||
#'(name/Interrupted [interrupted-pattern interrupted-action]
|
||||
...)
|
||||
#'(name/Interrupted [(IMPOSSIBLE) #f]))
|
||||
(name/Skipped [() (%skipped args-spec skip-spec)])))))]))
|
||||
(define-for-syntax ((make-production-splitter okW intW) stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (name form ...))
|
||||
(let ()
|
||||
(define-values (options alternates0)
|
||||
(partition-options/alternates (syntax->list #'(form ...))))
|
||||
(define wrap?
|
||||
(let ([wrap? (assq '#:wrap options)]
|
||||
[no-wrap? (assq '#:no-wrap options)])
|
||||
(unless (and (or wrap? no-wrap?) (not (and wrap? no-wrap?)))
|
||||
(raise-syntax-error 'split
|
||||
"must specify exactly one of #:wrap, #:no-wrap"
|
||||
stx))
|
||||
(and wrap? #t)))
|
||||
(define args-spec
|
||||
(let ([p (assq '#:args options)]) (and p (cdr p))))
|
||||
(define rewrite-alt+def (make-rewrite-alt+def #'name args-spec))
|
||||
(define alternates+definitions
|
||||
(map rewrite-alt+def alternates0 (build-list (length alternates0) add1)))
|
||||
(define alternates (map car alternates+definitions))
|
||||
(define action-definitions (map cdr alternates+definitions))
|
||||
(define elaborate-successful-alternate
|
||||
(make-elaborate-successful-alternate wrap? okW))
|
||||
(define elaborate-interrupted-alternate
|
||||
(make-elaborate-interrupted-alternate wrap? intW))
|
||||
(define successful-alternates
|
||||
(apply append (map elaborate-successful-alternate alternates)))
|
||||
(define interrupted-alternates
|
||||
(apply append (map elaborate-interrupted-alternate alternates)))
|
||||
(with-syntax ([((success-pattern . success-action) ...)
|
||||
successful-alternates]
|
||||
[((interrupted-pattern . interrupted-action) ...)
|
||||
interrupted-alternates]
|
||||
[skip-spec (assq '#:skipped options)]
|
||||
[args-spec (assq '#:args options)]
|
||||
[name/Skipped (I (symbol+ #'name '/Skipped))]
|
||||
[name/Interrupted (I (symbol+ #'name '/Interrupted))]
|
||||
[%action ((syntax-local-certifier) #'%action)])
|
||||
#`(begin
|
||||
(definitions #,@action-definitions)
|
||||
(productions
|
||||
(name [success-pattern success-action] ...)
|
||||
#,(if (pair? interrupted-alternates)
|
||||
#'(name/Interrupted [interrupted-pattern interrupted-action]
|
||||
...)
|
||||
#'(name/Interrupted [(IMPOSSIBLE) #f]))
|
||||
(name/Skipped [() (%skipped args-spec skip-spec)])))))]))
|
||||
|
||||
(define-syntax (skipped-token-values stx)
|
||||
(syntax-case stx ()
|
||||
[(skipped-token-values)
|
||||
#'(begin)]
|
||||
[(skipped-token-values name . more)
|
||||
(identifier? #'name)
|
||||
(with-syntax ([name/Skipped (I (symbol+ #'name '/Skipped))])
|
||||
#'(begin (productions (name/Skipped [() #f]))
|
||||
(skipped-token-values . more)))]
|
||||
[(skipped-token-values (name value) . more)
|
||||
(with-syntax ([name/Skipped (I (symbol+ #'name '/Skipped))])
|
||||
#'(begin (productions (name/Skipped [() value]))
|
||||
(skipped-token-values . more)))]))
|
||||
(define-syntax (skipped-token-values stx)
|
||||
(syntax-case stx ()
|
||||
[(skipped-token-values)
|
||||
#'(begin)]
|
||||
[(skipped-token-values name . more)
|
||||
(identifier? #'name)
|
||||
(with-syntax ([name/Skipped (I (symbol+ #'name '/Skipped))])
|
||||
#'(begin (productions (name/Skipped [() #f]))
|
||||
(skipped-token-values . more)))]
|
||||
[(skipped-token-values (name value) . more)
|
||||
(with-syntax ([name/Skipped (I (symbol+ #'name '/Skipped))])
|
||||
#'(begin (productions (name/Skipped [() value]))
|
||||
(skipped-token-values . more)))]))
|
||||
|
||||
(define-syntax (%skipped stx)
|
||||
(syntax-case stx ()
|
||||
[(%skipped args (#:skipped . expr))
|
||||
#'(%action args expr)]
|
||||
[(%skipped args #f)
|
||||
#'(%action args #f)]))
|
||||
(define-syntax (%skipped stx)
|
||||
(syntax-case stx ()
|
||||
[(%skipped args (#:skipped . expr))
|
||||
#'(%action args expr)]
|
||||
[(%skipped args #f)
|
||||
#'(%action args #f)]))
|
||||
|
||||
(define-syntax (%action stx)
|
||||
(syntax-case stx ()
|
||||
[(%action (#:args . args) action)
|
||||
#'(lambda args action)]
|
||||
[(%action #f action)
|
||||
#'action]))
|
||||
)
|
||||
(define-syntax (%action stx)
|
||||
(syntax-case stx ()
|
||||
[(%action (#:args . args) action)
|
||||
#'(lambda args action)]
|
||||
[(%action #f action)
|
||||
#'action]))
|
||||
|
|
|
|||
|
|
@ -1,140 +1,139 @@
|
|||
|
||||
(module stepper-text mzscheme
|
||||
(require (lib "list.ss")
|
||||
(lib "pretty.ss")
|
||||
"model/trace.ss"
|
||||
"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
|
||||
stepper-text)
|
||||
#lang scheme/base
|
||||
(require scheme/list
|
||||
scheme/pretty
|
||||
"model/trace.ss"
|
||||
"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
|
||||
stepper-text)
|
||||
|
||||
(define expand/step-text
|
||||
(case-lambda
|
||||
[(stx) (expand/step-text stx #f)]
|
||||
[(stx show)
|
||||
(define s (stepper-text stx (->show-function show)))
|
||||
(s 'all)]))
|
||||
|
||||
(define stepper-text
|
||||
(define expand/step-text
|
||||
(case-lambda
|
||||
[(stx) (expand/step-text stx #f)]
|
||||
[(stx show)
|
||||
(define s (stepper-text stx (->show-function show)))
|
||||
(s 'all)]))
|
||||
|
||||
(define stepper-text
|
||||
(case-lambda
|
||||
[(stx) (internal-stepper stx #f)]
|
||||
[(stx show) (internal-stepper stx (->show-function show))]))
|
||||
|
||||
;; internal procedures
|
||||
|
||||
(define (internal-stepper stx show?)
|
||||
(define steps (get-steps stx show?))
|
||||
(define used-steps null)
|
||||
(define partition (new-bound-partition))
|
||||
(define dispatch
|
||||
(case-lambda
|
||||
[(stx) (internal-stepper stx #f)]
|
||||
[(stx show) (internal-stepper stx (->show-function show))]))
|
||||
|
||||
;; internal procedures
|
||||
[() (dispatch 'next)]
|
||||
[(sym)
|
||||
(case sym
|
||||
((next)
|
||||
(if (pair? steps)
|
||||
(begin (show-step (car steps) partition)
|
||||
(set! used-steps (cons (car steps) used-steps))
|
||||
(set! steps (cdr steps)))
|
||||
#f))
|
||||
((prev)
|
||||
(if (pair? used-steps)
|
||||
(begin (show-step (car used-steps) partition)
|
||||
(set! steps (cons (car used-steps) steps))
|
||||
(set! used-steps (cdr used-steps)))
|
||||
#f))
|
||||
((all)
|
||||
(when (pair? steps)
|
||||
(dispatch 'next)
|
||||
(dispatch 'all))))]))
|
||||
dispatch)
|
||||
|
||||
(define (internal-stepper stx show?)
|
||||
(define steps (get-steps stx show?))
|
||||
(define used-steps null)
|
||||
(define partition (new-bound-partition))
|
||||
(define dispatch
|
||||
(case-lambda
|
||||
[() (dispatch 'next)]
|
||||
[(sym)
|
||||
(case sym
|
||||
((next)
|
||||
(if (pair? steps)
|
||||
(begin (show-step (car steps) partition)
|
||||
(set! used-steps (cons (car steps) used-steps))
|
||||
(set! steps (cdr steps)))
|
||||
#f))
|
||||
((prev)
|
||||
(if (pair? used-steps)
|
||||
(begin (show-step (car used-steps) partition)
|
||||
(set! steps (cons (car used-steps) steps))
|
||||
(set! used-steps (cdr used-steps)))
|
||||
#f))
|
||||
((all)
|
||||
(when (pair? steps)
|
||||
(dispatch 'next)
|
||||
(dispatch 'all))))]))
|
||||
dispatch)
|
||||
|
||||
(define (get-steps stx show?)
|
||||
(define deriv (trace stx))
|
||||
(define hderiv
|
||||
(if show? (hide/policy deriv show?) deriv))
|
||||
(define (ok? x)
|
||||
(or (rewrite-step? x) (misstep? x)))
|
||||
(filter ok? (reductions hderiv)))
|
||||
|
||||
(define (show-step step partition)
|
||||
(cond [(step? step)
|
||||
(display (step-type->string (protostep-type step)))
|
||||
(newline)
|
||||
(show-term (step-term1 step) partition)
|
||||
(display " ==>")
|
||||
(newline)
|
||||
(show-term (step-term2 step) partition)
|
||||
(newline)]
|
||||
[(misstep? step)
|
||||
(display (exn-message (misstep-exn step)))
|
||||
(newline)
|
||||
(show-term (misstep-term1 step) partition)]))
|
||||
|
||||
(define (show-term stx partition)
|
||||
(define-values (datum flat=>stx stx=>flat)
|
||||
(table stx partition 0 'always))
|
||||
(define identifier-list
|
||||
(filter identifier? (hash-table-map stx=>flat (lambda (k v) k))))
|
||||
(define (pp-size-hook obj display-like? port)
|
||||
(cond [(syntax-dummy? obj)
|
||||
(let ((ostring (open-output-string)))
|
||||
((if display-like? display write)
|
||||
(syntax-dummy-val obj)
|
||||
ostring)
|
||||
(string-length (get-output-string ostring)))]
|
||||
[else #f]))
|
||||
(define (pp-print-hook obj display-like? port)
|
||||
(cond [(syntax-dummy? obj)
|
||||
((if display-like? display write) (syntax-dummy-val obj) port)]
|
||||
[else
|
||||
(error 'pretty-print-hook "unexpected special value: ~e" obj)]))
|
||||
(define (pp-extend-style-table)
|
||||
(let* ([ids identifier-list]
|
||||
[syms (map (lambda (x) (hash-table-get stx=>flat x)) ids)]
|
||||
[like-syms (map syntax-e ids)])
|
||||
(pretty-print-extend-style-table (pp-better-style-table)
|
||||
syms
|
||||
like-syms)))
|
||||
(define (pp-better-style-table)
|
||||
(pretty-print-extend-style-table (pretty-print-current-style-table)
|
||||
(map car extended-style-list)
|
||||
(map cdr extended-style-list)))
|
||||
(parameterize
|
||||
([pretty-print-size-hook pp-size-hook]
|
||||
[pretty-print-print-hook pp-print-hook]
|
||||
[pretty-print-current-style-table (pp-extend-style-table)]
|
||||
;; Printing parameters (mzscheme manual 7.9.1.4)
|
||||
[print-unreadable #t]
|
||||
[print-graph #f]
|
||||
[print-struct #f]
|
||||
[print-box #t]
|
||||
[print-vector-length #t]
|
||||
[print-hash-table #f]
|
||||
[print-honu #f])
|
||||
(pretty-print datum)))
|
||||
|
||||
(define (->show-function show)
|
||||
(cond [(procedure? show)
|
||||
show]
|
||||
[(list? show)
|
||||
(lambda (id)
|
||||
(ormap (lambda (x) (module-identifier=? x id))
|
||||
show))]
|
||||
[(hiding-policy? show)
|
||||
(lambda (x) (policy-show-macro? show x))]
|
||||
[(eq? show #f)
|
||||
#f]
|
||||
[else
|
||||
(error 'expand/trace-text
|
||||
"expected procedure or list of identifiers for macros to show; got: ~e"
|
||||
show)]))
|
||||
(define (get-steps stx show?)
|
||||
(define deriv (trace stx))
|
||||
(define hderiv
|
||||
(if show? (hide/policy deriv show?) deriv))
|
||||
(define (ok? x)
|
||||
(or (rewrite-step? x) (misstep? x)))
|
||||
(filter ok? (reductions hderiv)))
|
||||
|
||||
(define extended-style-list
|
||||
'((define-values . define)
|
||||
(define-syntaxes . define-syntax)))
|
||||
)
|
||||
(define (show-step step partition)
|
||||
(cond [(step? step)
|
||||
(display (step-type->string (protostep-type step)))
|
||||
(newline)
|
||||
(show-term (step-term1 step) partition)
|
||||
(display " ==>")
|
||||
(newline)
|
||||
(show-term (step-term2 step) partition)
|
||||
(newline)]
|
||||
[(misstep? step)
|
||||
(display (exn-message (misstep-exn step)))
|
||||
(newline)
|
||||
(show-term (misstep-term1 step) partition)]))
|
||||
|
||||
(define (show-term stx partition)
|
||||
(define-values (datum flat=>stx stx=>flat)
|
||||
(table stx partition 0 'always))
|
||||
(define identifier-list
|
||||
(filter identifier? (hash-table-map stx=>flat (lambda (k v) k))))
|
||||
(define (pp-size-hook obj display-like? port)
|
||||
(cond [(syntax-dummy? obj)
|
||||
(let ((ostring (open-output-string)))
|
||||
((if display-like? display write)
|
||||
(syntax-dummy-val obj)
|
||||
ostring)
|
||||
(string-length (get-output-string ostring)))]
|
||||
[else #f]))
|
||||
(define (pp-print-hook obj display-like? port)
|
||||
(cond [(syntax-dummy? obj)
|
||||
((if display-like? display write) (syntax-dummy-val obj) port)]
|
||||
[else
|
||||
(error 'pretty-print-hook "unexpected special value: ~e" obj)]))
|
||||
(define (pp-extend-style-table)
|
||||
(let* ([ids identifier-list]
|
||||
[syms (map (lambda (x) (hash-table-get stx=>flat x)) ids)]
|
||||
[like-syms (map syntax-e ids)])
|
||||
(pretty-print-extend-style-table (pp-better-style-table)
|
||||
syms
|
||||
like-syms)))
|
||||
(define (pp-better-style-table)
|
||||
(pretty-print-extend-style-table (pretty-print-current-style-table)
|
||||
(map car extended-style-list)
|
||||
(map cdr extended-style-list)))
|
||||
(parameterize
|
||||
([pretty-print-size-hook pp-size-hook]
|
||||
[pretty-print-print-hook pp-print-hook]
|
||||
[pretty-print-current-style-table (pp-extend-style-table)]
|
||||
;; Printing parameters (mzscheme manual 7.9.1.4)
|
||||
[print-unreadable #t]
|
||||
[print-graph #f]
|
||||
[print-struct #f]
|
||||
[print-box #t]
|
||||
[print-vector-length #t]
|
||||
[print-hash-table #f]
|
||||
[print-honu #f])
|
||||
(pretty-print datum)))
|
||||
|
||||
(define (->show-function show)
|
||||
(cond [(procedure? show)
|
||||
show]
|
||||
[(list? show)
|
||||
(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
|
||||
(error 'expand/trace-text
|
||||
"expected procedure or list of identifiers for macros to show; got: ~e"
|
||||
show)]))
|
||||
|
||||
(define extended-style-list
|
||||
'((define-values . define)
|
||||
(define-syntaxes . define-syntax)))
|
||||
|
|
|
|||
|
|
@ -1,8 +1,7 @@
|
|||
|
||||
(module stepper mzscheme
|
||||
(require "view/view.ss")
|
||||
(provide expand/step)
|
||||
|
||||
(define (expand/step stx)
|
||||
(go stx))
|
||||
)
|
||||
#lang scheme/base
|
||||
(require "view/view.ss")
|
||||
(provide expand/step)
|
||||
|
||||
(define (expand/step stx)
|
||||
(go stx))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
|
||||
(module syntax-browser mzscheme
|
||||
(require "syntax-browser/frame.ss")
|
||||
(provide browse-syntax
|
||||
browse-syntaxes
|
||||
make-syntax-browser)
|
||||
)
|
||||
#lang scheme/base
|
||||
(require "syntax-browser/frame.ss")
|
||||
(provide browse-syntax
|
||||
browse-syntaxes
|
||||
make-syntax-browser)
|
||||
|
|
|
|||
|
|
@ -1,76 +1,75 @@
|
|||
|
||||
(module controller mzscheme
|
||||
(require (lib "class.ss")
|
||||
"interfaces.ss"
|
||||
"partition.ss"
|
||||
"../util/notify.ss")
|
||||
(provide controller%)
|
||||
#lang scheme/base
|
||||
(require scheme/class
|
||||
"interfaces.ss"
|
||||
"partition.ss"
|
||||
"../util/notify.ss")
|
||||
(provide controller%)
|
||||
|
||||
;; displays-manager-mixin
|
||||
(define displays-manager-mixin
|
||||
(mixin () (displays-manager<%>)
|
||||
;; displays : (list-of display<%>)
|
||||
(field [displays null])
|
||||
;; displays-manager-mixin
|
||||
(define displays-manager-mixin
|
||||
(mixin () (displays-manager<%>)
|
||||
;; displays : (list-of display<%>)
|
||||
(field [displays null])
|
||||
|
||||
;; add-syntax-display : display<%> -> void
|
||||
(define/public (add-syntax-display c)
|
||||
(set! displays (cons c displays)))
|
||||
;; add-syntax-display : display<%> -> void
|
||||
(define/public (add-syntax-display c)
|
||||
(set! displays (cons c displays)))
|
||||
|
||||
;; remove-all-syntax-displays : -> void
|
||||
(define/public (remove-all-syntax-displays)
|
||||
(set! displays null))
|
||||
;; remove-all-syntax-displays : -> void
|
||||
(define/public (remove-all-syntax-displays)
|
||||
(set! displays null))
|
||||
|
||||
(super-new)))
|
||||
(super-new)))
|
||||
|
||||
;; selection-manager-mixin
|
||||
(define selection-manager-mixin
|
||||
(mixin (displays-manager<%>) (selection-manager<%>)
|
||||
(inherit-field displays)
|
||||
(field/notify selected-syntax (new notify-box% (value #f)))
|
||||
|
||||
(super-new)
|
||||
(listen-selected-syntax
|
||||
(lambda (new-value)
|
||||
(for-each (lambda (display) (send display refresh))
|
||||
displays)))))
|
||||
|
||||
;; mark-manager-mixin
|
||||
(define mark-manager-mixin
|
||||
(mixin () (mark-manager<%>)
|
||||
(init-field [primary-partition (new-bound-partition)])
|
||||
(super-new)
|
||||
;; selection-manager-mixin
|
||||
(define selection-manager-mixin
|
||||
(mixin (displays-manager<%>) (selection-manager<%>)
|
||||
(inherit-field displays)
|
||||
(field/notify selected-syntax (new notify-box% (value #f)))
|
||||
|
||||
(super-new)
|
||||
(listen-selected-syntax
|
||||
(lambda (new-value)
|
||||
(for-each (lambda (display) (send display refresh))
|
||||
displays)))))
|
||||
|
||||
;; get-primary-partition : -> partition
|
||||
(define/public-final (get-primary-partition)
|
||||
primary-partition)
|
||||
;; mark-manager-mixin
|
||||
(define mark-manager-mixin
|
||||
(mixin () (mark-manager<%>)
|
||||
(init-field [primary-partition (new-bound-partition)])
|
||||
(super-new)
|
||||
|
||||
;; reset-primary-partition : -> void
|
||||
(define/public-final (reset-primary-partition)
|
||||
(set! primary-partition (new-bound-partition)))))
|
||||
;; get-primary-partition : -> partition
|
||||
(define/public-final (get-primary-partition)
|
||||
primary-partition)
|
||||
|
||||
;; secondary-partition-mixin
|
||||
(define secondary-partition-mixin
|
||||
(mixin (displays-manager<%>) (secondary-partition<%>)
|
||||
(inherit-field displays)
|
||||
(field/notify identifier=? (new notify-box% (value #f)))
|
||||
(field/notify secondary-partition (new notify-box% (value #f)))
|
||||
;; reset-primary-partition : -> void
|
||||
(define/public-final (reset-primary-partition)
|
||||
(set! primary-partition (new-bound-partition)))))
|
||||
|
||||
(listen-identifier=?
|
||||
(lambda (name+proc)
|
||||
(set-secondary-partition
|
||||
(and name+proc
|
||||
(new partition% (relation (cdr name+proc)))))))
|
||||
(listen-secondary-partition
|
||||
(lambda (p)
|
||||
(for-each (lambda (d) (send d refresh))
|
||||
displays)))
|
||||
(super-new)))
|
||||
;; secondary-partition-mixin
|
||||
(define secondary-partition-mixin
|
||||
(mixin (displays-manager<%>) (secondary-partition<%>)
|
||||
(inherit-field displays)
|
||||
(field/notify identifier=? (new notify-box% (value #f)))
|
||||
(field/notify secondary-partition (new notify-box% (value #f)))
|
||||
|
||||
(define controller%
|
||||
(class (secondary-partition-mixin
|
||||
(selection-manager-mixin
|
||||
(mark-manager-mixin
|
||||
(displays-manager-mixin
|
||||
object%))))
|
||||
(super-new)))
|
||||
)
|
||||
(listen-identifier=?
|
||||
(lambda (name+proc)
|
||||
(set-secondary-partition
|
||||
(and name+proc
|
||||
(new partition% (relation (cdr name+proc)))))))
|
||||
(listen-secondary-partition
|
||||
(lambda (p)
|
||||
(for-each (lambda (d) (send d refresh))
|
||||
displays)))
|
||||
(super-new)))
|
||||
|
||||
(define controller%
|
||||
(class (secondary-partition-mixin
|
||||
(selection-manager-mixin
|
||||
(mark-manager-mixin
|
||||
(displays-manager-mixin
|
||||
object%))))
|
||||
(super-new)))
|
||||
|
|
|
|||
|
|
@ -1,251 +1,250 @@
|
|||
|
||||
(module display mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "plt-match.ss")
|
||||
"params.ss"
|
||||
"pretty-printer.ss"
|
||||
"interfaces.ss"
|
||||
"util.ss")
|
||||
(provide print-syntax-to-editor
|
||||
code-style)
|
||||
#lang scheme/base
|
||||
(require scheme/class
|
||||
scheme/gui
|
||||
scheme/match
|
||||
"params.ss"
|
||||
"pretty-printer.ss"
|
||||
"interfaces.ss"
|
||||
"util.ss")
|
||||
(provide print-syntax-to-editor
|
||||
code-style)
|
||||
|
||||
;; print-syntax-to-editor : syntax text controller<%> -> display<%>
|
||||
(define (print-syntax-to-editor stx text controller)
|
||||
(new display% (syntax stx) (text text) (controller controller)))
|
||||
;; print-syntax-to-editor : syntax text controller<%> -> display<%>
|
||||
(define (print-syntax-to-editor stx text controller)
|
||||
(new display% (syntax stx) (text text) (controller controller)))
|
||||
|
||||
;; FIXME: assumes text never moves
|
||||
;; FIXME: assumes text never moves
|
||||
|
||||
;; display%
|
||||
(define display%
|
||||
(class* object% (display<%>)
|
||||
(init ((stx syntax)))
|
||||
(init-field text)
|
||||
(init-field controller)
|
||||
;; display%
|
||||
(define display%
|
||||
(class* object% (display<%>)
|
||||
(init ((stx syntax)))
|
||||
(init-field text)
|
||||
(init-field controller)
|
||||
|
||||
(define start-anchor (new anchor-snip%))
|
||||
(define end-anchor (new anchor-snip%))
|
||||
(define range #f)
|
||||
(define extra-styles (make-hash-table))
|
||||
(define start-anchor (new anchor-snip%))
|
||||
(define end-anchor (new anchor-snip%))
|
||||
(define range #f)
|
||||
(define extra-styles (make-hash-table))
|
||||
|
||||
;; render-syntax : syntax -> void
|
||||
(define/public (render-syntax stx)
|
||||
(with-unlock text
|
||||
(send text delete (get-start-position) (get-end-position))
|
||||
(set! range
|
||||
(print-syntax stx text controller
|
||||
(lambda () (get-start-position))
|
||||
(lambda () (get-end-position))))
|
||||
(apply-primary-partition-styles))
|
||||
(refresh))
|
||||
;; render-syntax : syntax -> void
|
||||
(define/public (render-syntax stx)
|
||||
(with-unlock text
|
||||
(send text delete (get-start-position) (get-end-position))
|
||||
(set! range
|
||||
(print-syntax stx text controller
|
||||
(lambda () (get-start-position))
|
||||
(lambda () (get-end-position))))
|
||||
(apply-primary-partition-styles))
|
||||
(refresh))
|
||||
|
||||
;; refresh : -> void
|
||||
;; Clears all highlighting and reapplies all non-foreground styles.
|
||||
(define/public (refresh)
|
||||
(with-unlock text
|
||||
(send* text
|
||||
(begin-edit-sequence)
|
||||
(change-style unhighlight-d (get-start-position) (get-end-position)))
|
||||
(apply-extra-styles)
|
||||
(let ([selected-syntax (send controller get-selected-syntax)])
|
||||
(apply-secondary-partition-styles selected-syntax)
|
||||
(apply-selection-styles selected-syntax))
|
||||
(send* text
|
||||
(end-edit-sequence))))
|
||||
;; refresh : -> void
|
||||
;; Clears all highlighting and reapplies all non-foreground styles.
|
||||
(define/public (refresh)
|
||||
(with-unlock text
|
||||
(send* text
|
||||
(begin-edit-sequence)
|
||||
(change-style unhighlight-d (get-start-position) (get-end-position)))
|
||||
(apply-extra-styles)
|
||||
(let ([selected-syntax (send controller get-selected-syntax)])
|
||||
(apply-secondary-partition-styles selected-syntax)
|
||||
(apply-selection-styles selected-syntax))
|
||||
(send* text
|
||||
(end-edit-sequence))))
|
||||
|
||||
;; cached-start-position : number
|
||||
(define cached-start-position #f)
|
||||
;; cached-start-position : number
|
||||
(define cached-start-position #f)
|
||||
|
||||
;; get-start-position : -> number
|
||||
(define/public-final (get-start-position)
|
||||
(unless cached-start-position
|
||||
(set! cached-start-position (send text get-snip-position start-anchor)))
|
||||
cached-start-position)
|
||||
;; get-start-position : -> number
|
||||
(define/public-final (get-start-position)
|
||||
(unless cached-start-position
|
||||
(set! cached-start-position (send text get-snip-position start-anchor)))
|
||||
cached-start-position)
|
||||
|
||||
;; get-end-position : -> number
|
||||
(define/public-final (get-end-position)
|
||||
(send text get-snip-position end-anchor))
|
||||
;; get-end-position : -> number
|
||||
(define/public-final (get-end-position)
|
||||
(send text get-snip-position end-anchor))
|
||||
|
||||
;; relative->text-position : number -> number
|
||||
;; FIXME: might be slow to find start every time!
|
||||
(define/public-final (relative->text-position pos)
|
||||
(+ pos (get-start-position)))
|
||||
;; relative->text-position : number -> number
|
||||
;; FIXME: might be slow to find start every time!
|
||||
(define/public-final (relative->text-position pos)
|
||||
(+ pos (get-start-position)))
|
||||
|
||||
;; Styling
|
||||
;; Styling
|
||||
|
||||
;; get-range : -> range<%>
|
||||
(define/public (get-range) range)
|
||||
|
||||
;; highlight-syntaxes : (list-of syntax) string -> void
|
||||
(define/public (highlight-syntaxes stxs hi-color)
|
||||
(let ([style-delta (highlight-style-delta hi-color #f)])
|
||||
(for-each (lambda (stx) (hash-table-put! extra-styles stx style-delta))
|
||||
stxs))
|
||||
(refresh))
|
||||
;; get-range : -> range<%>
|
||||
(define/public (get-range) range)
|
||||
|
||||
;; highlight-syntaxes : (list-of syntax) string -> void
|
||||
(define/public (highlight-syntaxes stxs hi-color)
|
||||
(let ([style-delta (highlight-style-delta hi-color #f)])
|
||||
(for-each (lambda (stx) (hash-table-put! extra-styles stx style-delta))
|
||||
stxs))
|
||||
(refresh))
|
||||
|
||||
;; apply-extra-styles : -> void
|
||||
;; Applies externally-added styles (such as highlighting)
|
||||
(define/private (apply-extra-styles)
|
||||
(hash-table-for-each
|
||||
extra-styles
|
||||
(lambda (hi-stx style-delta)
|
||||
(let ([rs (send range get-ranges hi-stx)])
|
||||
(for-each (lambda (r) (restyle-range r style-delta)) rs)))))
|
||||
;; apply-extra-styles : -> void
|
||||
;; Applies externally-added styles (such as highlighting)
|
||||
(define/private (apply-extra-styles)
|
||||
(hash-table-for-each
|
||||
extra-styles
|
||||
(lambda (hi-stx style-delta)
|
||||
(let ([rs (send range get-ranges hi-stx)])
|
||||
(for-each (lambda (r) (restyle-range r style-delta)) rs)))))
|
||||
|
||||
;; apply-secondary-partition-styles : selected-syntax -> void
|
||||
;; If the selected syntax is an identifier, then styles all identifiers
|
||||
;; in the same partition in blue.
|
||||
(define/private (apply-secondary-partition-styles selected-syntax)
|
||||
(when (identifier? selected-syntax)
|
||||
(let ([partition (send controller get-secondary-partition)])
|
||||
(when partition
|
||||
(for-each (lambda (id)
|
||||
(when (send partition same-partition? selected-syntax id)
|
||||
(draw-secondary-connection id)))
|
||||
(send range get-identifier-list))))))
|
||||
;; apply-secondary-partition-styles : selected-syntax -> void
|
||||
;; If the selected syntax is an identifier, then styles all identifiers
|
||||
;; in the same partition in blue.
|
||||
(define/private (apply-secondary-partition-styles selected-syntax)
|
||||
(when (identifier? selected-syntax)
|
||||
(let ([partition (send controller get-secondary-partition)])
|
||||
(when partition
|
||||
(for-each (lambda (id)
|
||||
(when (send partition same-partition? selected-syntax id)
|
||||
(draw-secondary-connection id)))
|
||||
(send range get-identifier-list))))))
|
||||
|
||||
;; apply-selection-styles : syntax -> void
|
||||
;; Styles subterms eq to the selected syntax
|
||||
(define/private (apply-selection-styles selected-syntax)
|
||||
(let ([rs (send range get-ranges selected-syntax)])
|
||||
(for-each (lambda (r) (restyle-range r select-highlight-d)) rs)))
|
||||
;; apply-selection-styles : syntax -> void
|
||||
;; Styles subterms eq to the selected syntax
|
||||
(define/private (apply-selection-styles selected-syntax)
|
||||
(let ([rs (send range get-ranges selected-syntax)])
|
||||
(for-each (lambda (r) (restyle-range r select-highlight-d)) rs)))
|
||||
|
||||
;; draw-secondary-connection : syntax -> void
|
||||
(define/private (draw-secondary-connection stx2)
|
||||
(let ([rs (send range get-ranges stx2)])
|
||||
(for-each (lambda (r) (restyle-range r select-sub-highlight-d)) rs)))
|
||||
;; draw-secondary-connection : syntax -> void
|
||||
(define/private (draw-secondary-connection stx2)
|
||||
(let ([rs (send range get-ranges stx2)])
|
||||
(for-each (lambda (r) (restyle-range r select-sub-highlight-d)) rs)))
|
||||
|
||||
;; restyle-range : (cons num num) style-delta% -> void
|
||||
(define/private (restyle-range r style)
|
||||
(send text change-style style
|
||||
(relative->text-position (car r))
|
||||
(relative->text-position (cdr r))))
|
||||
;; restyle-range : (cons num num) style-delta% -> void
|
||||
(define/private (restyle-range r style)
|
||||
(send text change-style style
|
||||
(relative->text-position (car r))
|
||||
(relative->text-position (cdr r))))
|
||||
|
||||
;; Primary styles
|
||||
;; Primary styles
|
||||
|
||||
;; apply-primary-partition-styles : -> void
|
||||
;; Changes the foreground color according to the primary partition.
|
||||
;; Only called once, when the syntax is first drawn.
|
||||
(define/private (apply-primary-partition-styles)
|
||||
(define (color-style color)
|
||||
(let ([delta (new style-delta%)])
|
||||
(send delta set-delta-foreground color)
|
||||
delta))
|
||||
(define color-styles (list->vector (map color-style (current-colors))))
|
||||
(define overflow-style (color-style "darkgray"))
|
||||
(define color-partition (send controller get-primary-partition))
|
||||
(define offset (get-start-position))
|
||||
(for-each
|
||||
(lambda (range)
|
||||
(let ([stx (range-obj range)]
|
||||
[start (range-start range)]
|
||||
[end (range-end range)])
|
||||
(send text change-style
|
||||
(primary-style stx color-partition color-styles overflow-style)
|
||||
(+ offset start)
|
||||
(+ offset end))))
|
||||
(send range all-ranges)))
|
||||
;; apply-primary-partition-styles : -> void
|
||||
;; Changes the foreground color according to the primary partition.
|
||||
;; Only called once, when the syntax is first drawn.
|
||||
(define/private (apply-primary-partition-styles)
|
||||
(define (color-style color)
|
||||
(let ([delta (new style-delta%)])
|
||||
(send delta set-delta-foreground color)
|
||||
delta))
|
||||
(define color-styles (list->vector (map color-style (current-colors))))
|
||||
(define overflow-style (color-style "darkgray"))
|
||||
(define color-partition (send controller get-primary-partition))
|
||||
(define offset (get-start-position))
|
||||
(for-each
|
||||
(lambda (range)
|
||||
(let ([stx (range-obj range)]
|
||||
[start (range-start range)]
|
||||
[end (range-end range)])
|
||||
(send text change-style
|
||||
(primary-style stx color-partition color-styles overflow-style)
|
||||
(+ offset start)
|
||||
(+ offset end))))
|
||||
(send range all-ranges)))
|
||||
|
||||
;; primary-style : syntax partition (vector-of style-delta%) style-delta%
|
||||
;; -> style-delta%
|
||||
(define/private (primary-style stx partition color-vector overflow)
|
||||
(let ([n (send partition get-partition stx)])
|
||||
(cond [(< n (vector-length color-vector))
|
||||
(vector-ref color-vector n)]
|
||||
[else
|
||||
overflow])))
|
||||
;; primary-style : syntax partition (vector-of style-delta%) style-delta%
|
||||
;; -> style-delta%
|
||||
(define/private (primary-style stx partition color-vector overflow)
|
||||
(let ([n (send partition get-partition stx)])
|
||||
(cond [(< n (vector-length color-vector))
|
||||
(vector-ref color-vector n)]
|
||||
[else
|
||||
overflow])))
|
||||
|
||||
;; Initialize
|
||||
(super-new)
|
||||
(send text insert start-anchor)
|
||||
(send text insert end-anchor)
|
||||
(render-syntax stx)
|
||||
(send controller add-syntax-display this)))
|
||||
;; Initialize
|
||||
(super-new)
|
||||
(send text insert start-anchor)
|
||||
(send text insert end-anchor)
|
||||
(render-syntax stx)
|
||||
(send controller add-syntax-display this)))
|
||||
|
||||
;; print-syntax : syntax controller (-> number) (-> number)
|
||||
;; -> range%
|
||||
(define (print-syntax stx text controller
|
||||
get-start-position get-end-position)
|
||||
(define primary-partition (send controller get-primary-partition))
|
||||
(define real-output-port (make-text-port text get-end-position))
|
||||
(define output-port (open-output-string))
|
||||
;; print-syntax : syntax controller (-> number) (-> number)
|
||||
;; -> range%
|
||||
(define (print-syntax stx text controller
|
||||
get-start-position get-end-position)
|
||||
(define primary-partition (send controller get-primary-partition))
|
||||
(define real-output-port (make-text-port text get-end-position))
|
||||
(define output-port (open-output-string))
|
||||
|
||||
(port-count-lines! output-port)
|
||||
(let ([range (pretty-print-syntax stx output-port primary-partition)])
|
||||
(write-string (get-output-string output-port) real-output-port)
|
||||
(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
|
||||
(lambda (range)
|
||||
(let* ([stx (range-obj range)]
|
||||
[start (range-start range)]
|
||||
[end (range-end range)])
|
||||
(send text set-clickback (+ offset start) (+ offset end)
|
||||
(lambda (_1 _2 _3)
|
||||
(send controller set-selected-syntax stx)))))
|
||||
(send range all-ranges))
|
||||
range)))
|
||||
(port-count-lines! output-port)
|
||||
(let ([range (pretty-print-syntax stx output-port primary-partition)])
|
||||
(write-string (get-output-string output-port) real-output-port)
|
||||
(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
|
||||
(lambda (range)
|
||||
(let* ([stx (range-obj range)]
|
||||
[start (range-start range)]
|
||||
[end (range-end range)])
|
||||
(send text set-clickback (+ offset start) (+ offset end)
|
||||
(lambda (_1 _2 _3)
|
||||
(send controller set-selected-syntax stx)))))
|
||||
(send range all-ranges))
|
||||
range)))
|
||||
|
||||
;; fixup-parentheses : text range -> void
|
||||
(define (fixup-parentheses text range offset)
|
||||
(define (fixup r)
|
||||
(let ([stx (range-obj r)]
|
||||
[start (+ offset (range-start r))]
|
||||
[end (+ offset (range-end r))])
|
||||
(when (and (syntax? stx) (pair? (syntax-e stx)))
|
||||
(case (syntax-property stx 'paren-shape)
|
||||
((#\[)
|
||||
(replace start #\[)
|
||||
(replace (sub1 end) #\]))
|
||||
((#\{)
|
||||
(replace start #\{)
|
||||
(replace (sub1 end) #\}))))))
|
||||
(define (replace pos char)
|
||||
(send text insert char pos (add1 pos)))
|
||||
(for-each fixup (send range all-ranges)))
|
||||
;; fixup-parentheses : text range -> void
|
||||
(define (fixup-parentheses text range offset)
|
||||
(define (fixup r)
|
||||
(let ([stx (range-obj r)]
|
||||
[start (+ offset (range-start r))]
|
||||
[end (+ offset (range-end r))])
|
||||
(when (and (syntax? stx) (pair? (syntax-e stx)))
|
||||
(case (syntax-property stx 'paren-shape)
|
||||
((#\[)
|
||||
(replace start #\[)
|
||||
(replace (sub1 end) #\]))
|
||||
((#\{)
|
||||
(replace start #\{)
|
||||
(replace (sub1 end) #\}))))))
|
||||
(define (replace pos char)
|
||||
(send text insert char pos (add1 pos)))
|
||||
(for-each fixup (send range all-ranges)))
|
||||
|
||||
;; code-style : text<%> -> style<%>
|
||||
(define (code-style text)
|
||||
(let* ([style-list (send text get-style-list)]
|
||||
[style (send style-list find-named-style "Standard")]
|
||||
[font-size (current-syntax-font-size)])
|
||||
(if font-size
|
||||
(send style-list find-or-create-style
|
||||
style
|
||||
(make-object style-delta% 'change-size font-size))
|
||||
style)))
|
||||
;; code-style : text<%> -> style<%>
|
||||
(define (code-style text)
|
||||
(let* ([style-list (send text get-style-list)]
|
||||
[style (send style-list find-named-style "Standard")]
|
||||
[font-size (current-syntax-font-size)])
|
||||
(if font-size
|
||||
(send style-list find-or-create-style
|
||||
style
|
||||
(make-object style-delta% 'change-size font-size))
|
||||
style)))
|
||||
|
||||
;; anchor-snip%
|
||||
(define anchor-snip%
|
||||
(class snip%
|
||||
(define/override (copy)
|
||||
(make-object string-snip% ""))
|
||||
(super-instantiate ())))
|
||||
;; anchor-snip%
|
||||
(define anchor-snip%
|
||||
(class snip%
|
||||
(define/override (copy)
|
||||
(make-object string-snip% ""))
|
||||
(super-instantiate ())))
|
||||
|
||||
;; Styles
|
||||
;; Styles
|
||||
|
||||
(define (highlight-style-delta color em?)
|
||||
(let ([sd (new style-delta%)])
|
||||
(unless em? (send sd set-delta-background color))
|
||||
(when em? (send sd set-weight-on 'bold))
|
||||
(unless em? (send sd set-underlined-off #t)
|
||||
(send sd set-weight-off 'bold))
|
||||
sd))
|
||||
(define (highlight-style-delta color em?)
|
||||
(let ([sd (new style-delta%)])
|
||||
(unless em? (send sd set-delta-background color))
|
||||
(when em? (send sd set-weight-on 'bold))
|
||||
(unless em? (send sd set-underlined-off #t)
|
||||
(send sd set-weight-off 'bold))
|
||||
sd))
|
||||
|
||||
(define selection-color "yellow")
|
||||
(define subselection-color "yellow")
|
||||
(define selection-color "yellow")
|
||||
(define subselection-color "yellow")
|
||||
|
||||
(define select-highlight-d (highlight-style-delta selection-color #t))
|
||||
(define select-sub-highlight-d (highlight-style-delta subselection-color #f))
|
||||
(define select-highlight-d (highlight-style-delta selection-color #t))
|
||||
(define select-sub-highlight-d (highlight-style-delta subselection-color #f))
|
||||
|
||||
(define unhighlight-d (highlight-style-delta "white" #f))
|
||||
(define unhighlight-d (highlight-style-delta "white" #f))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,13 +1,13 @@
|
|||
|
||||
(module embed mzscheme
|
||||
(require "interfaces.ss"
|
||||
"widget.ss"
|
||||
"keymap.ss"
|
||||
"params.ss"
|
||||
"partition.ss")
|
||||
|
||||
(provide (all-from "interfaces.ss")
|
||||
(all-from "widget.ss")
|
||||
(all-from "keymap.ss")
|
||||
(all-from "params.ss")
|
||||
identifier=-choices))
|
||||
#lang scheme/base
|
||||
(require "interfaces.ss"
|
||||
"widget.ss"
|
||||
"keymap.ss"
|
||||
"params.ss"
|
||||
"partition.ss")
|
||||
|
||||
(provide (all-from-out "interfaces.ss")
|
||||
(all-from-out "widget.ss")
|
||||
(all-from-out "keymap.ss")
|
||||
(all-from-out "params.ss")
|
||||
identifier=-choices)
|
||||
|
|
|
|||
|
|
@ -1,96 +1,94 @@
|
|||
|
||||
(module frame mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "list.ss")
|
||||
"partition.ss"
|
||||
"prefs.ss"
|
||||
"widget.ss")
|
||||
(provide browse-syntax
|
||||
browse-syntaxes
|
||||
make-syntax-browser
|
||||
syntax-browser-frame%
|
||||
syntax-widget/controls%)
|
||||
#lang scheme/base
|
||||
(require scheme/class
|
||||
scheme/gui
|
||||
framework/framework
|
||||
scheme/list
|
||||
"partition.ss"
|
||||
"prefs.ss"
|
||||
"widget.ss")
|
||||
(provide browse-syntax
|
||||
browse-syntaxes
|
||||
make-syntax-browser
|
||||
syntax-browser-frame%
|
||||
syntax-widget/controls%)
|
||||
|
||||
;; browse-syntax : syntax -> void
|
||||
(define (browse-syntax stx)
|
||||
(browse-syntaxes (list stx)))
|
||||
;; browse-syntax : syntax -> void
|
||||
(define (browse-syntax stx)
|
||||
(browse-syntaxes (list stx)))
|
||||
|
||||
;; browse-syntaxes : (list-of syntax) -> void
|
||||
(define (browse-syntaxes stxs)
|
||||
(let ((w (make-syntax-browser)))
|
||||
(for-each (lambda (stx)
|
||||
(send w add-syntax stx)
|
||||
(send w add-separator))
|
||||
stxs)))
|
||||
;; browse-syntaxes : (list-of syntax) -> void
|
||||
(define (browse-syntaxes stxs)
|
||||
(let ((w (make-syntax-browser)))
|
||||
(for-each (lambda (stx)
|
||||
(send w add-syntax stx)
|
||||
(send w add-separator))
|
||||
stxs)))
|
||||
|
||||
;; make-syntax-browser : -> syntax-browser<%>
|
||||
(define (make-syntax-browser)
|
||||
(let* ([view (new syntax-browser-frame%)])
|
||||
(send view show #t)
|
||||
(send view get-widget)))
|
||||
;; make-syntax-browser : -> syntax-browser<%>
|
||||
(define (make-syntax-browser)
|
||||
(let* ([view (new syntax-browser-frame%)])
|
||||
(send view show #t)
|
||||
(send view get-widget)))
|
||||
|
||||
;; syntax-browser-frame%
|
||||
(define syntax-browser-frame%
|
||||
(class* frame% ()
|
||||
(init-field [config (new syntax-prefs%)])
|
||||
(super-new (label "Syntax Browser")
|
||||
(width (send config pref:width))
|
||||
(height (send config pref:height)))
|
||||
(define widget
|
||||
(new syntax-widget/controls%
|
||||
(parent this)
|
||||
(config config)))
|
||||
(define/public (get-widget) widget)
|
||||
(define/augment (on-close)
|
||||
(send config pref:width (send this get-width))
|
||||
(send config pref:height (send this get-height))
|
||||
(send widget shutdown)
|
||||
(inner (void) on-close))
|
||||
))
|
||||
;; syntax-browser-frame%
|
||||
(define syntax-browser-frame%
|
||||
(class* frame% ()
|
||||
(init-field [config (new syntax-prefs%)])
|
||||
(super-new (label "Syntax Browser")
|
||||
(width (send config pref:width))
|
||||
(height (send config pref:height)))
|
||||
(define widget
|
||||
(new syntax-widget/controls%
|
||||
(parent this)
|
||||
(config config)))
|
||||
(define/public (get-widget) widget)
|
||||
(define/augment (on-close)
|
||||
(send config pref:width (send this get-width))
|
||||
(send config pref:height (send this get-height))
|
||||
(send widget shutdown)
|
||||
(inner (void) on-close))
|
||||
))
|
||||
|
||||
;; syntax-widget/controls%
|
||||
(define syntax-widget/controls%
|
||||
(class* widget% ()
|
||||
(inherit get-main-panel
|
||||
get-controller
|
||||
toggle-props)
|
||||
(super-new)
|
||||
(inherit-field config)
|
||||
;; syntax-widget/controls%
|
||||
(define syntax-widget/controls%
|
||||
(class* widget% ()
|
||||
(inherit get-main-panel
|
||||
get-controller
|
||||
toggle-props)
|
||||
(super-new)
|
||||
(inherit-field config)
|
||||
|
||||
(define -control-panel
|
||||
(new horizontal-pane%
|
||||
(parent (get-main-panel))
|
||||
(stretchable-height #f)))
|
||||
(define -control-panel
|
||||
(new horizontal-pane%
|
||||
(parent (get-main-panel))
|
||||
(stretchable-height #f)))
|
||||
|
||||
;; Put the control panel up front
|
||||
(send (get-main-panel) change-children
|
||||
(lambda (children)
|
||||
(cons -control-panel (remq -control-panel children))))
|
||||
;; Put the control panel up front
|
||||
(send (get-main-panel) change-children
|
||||
(lambda (children)
|
||||
(cons -control-panel (remq -control-panel children))))
|
||||
|
||||
(define -identifier=-choices (identifier=-choices))
|
||||
(define -choice
|
||||
(new choice% (label "identifer=?") (parent -control-panel)
|
||||
(choices (map car -identifier=-choices))
|
||||
(callback
|
||||
(lambda (c e)
|
||||
(send (get-controller) set-identifier=?
|
||||
(assoc (send c get-string-selection)
|
||||
-identifier=-choices))))))
|
||||
(new button%
|
||||
(label "Clear")
|
||||
(parent -control-panel)
|
||||
(callback (lambda _ (send (get-controller) select-syntax #f))))
|
||||
(new button%
|
||||
(label "Properties")
|
||||
(parent -control-panel)
|
||||
(callback (lambda _ (toggle-props))))
|
||||
(define -identifier=-choices (identifier=-choices))
|
||||
(define -choice
|
||||
(new choice% (label "identifer=?") (parent -control-panel)
|
||||
(choices (map car -identifier=-choices))
|
||||
(callback
|
||||
(lambda (c e)
|
||||
(send (get-controller) set-identifier=?
|
||||
(assoc (send c get-string-selection)
|
||||
-identifier=-choices))))))
|
||||
(new button%
|
||||
(label "Clear")
|
||||
(parent -control-panel)
|
||||
(callback (lambda _ (send (get-controller) select-syntax #f))))
|
||||
(new button%
|
||||
(label "Properties")
|
||||
(parent -control-panel)
|
||||
(callback (lambda _ (toggle-props))))
|
||||
|
||||
(send (get-controller) listen-identifier=?
|
||||
(lambda (name+func)
|
||||
(send -choice set-selection
|
||||
(or (send -choice find-string (car name+func)) 0))))
|
||||
))
|
||||
|
||||
)
|
||||
(send (get-controller) listen-identifier=?
|
||||
(lambda (name+func)
|
||||
(send -choice set-selection
|
||||
(or (send -choice find-string (car name+func)) 0))))
|
||||
))
|
||||
|
|
|
|||
|
|
@ -1,57 +1,57 @@
|
|||
|
||||
(module hrule-snip mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "mred.ss" "mred"))
|
||||
(provide hrule-snip%)
|
||||
#lang scheme/base
|
||||
|
||||
;; hrule-snip%
|
||||
;; A snip for drawing horizontal separating lines.
|
||||
(define hrule-snip%
|
||||
(class snip%
|
||||
(inherit get-admin)
|
||||
(define/override (get-extent dc x y bw bh bdescent bspace blspace brspace)
|
||||
(let-values [((h) (get-xheight dc))
|
||||
((fw fh) (send dc get-size))]
|
||||
(let ([ad-x (box 0)]
|
||||
[ad-y (box 0)])
|
||||
(send (get-admin) get-view-size ad-x ad-y)
|
||||
#;(set-box?! bw fw)
|
||||
(set-box?! bw (max 0 (- (unbox ad-x) (get-xheight dc))))
|
||||
(set-box?! bh h))))
|
||||
(define/override (draw dc x y left top right bottom dx dy draw-caret)
|
||||
(let* [(xh (get-xheight dc))
|
||||
(ny (+ y (/ xh 2)))]
|
||||
(send dc draw-line x ny right ny)))
|
||||
(define/private (set-box?! b v)
|
||||
(when (box? b) (set-box! b v)))
|
||||
(define/private (get-xheight dc)
|
||||
(or cached-xheight
|
||||
(let-values [((w h descent extra) (send dc get-text-extent "x"))]
|
||||
(set! cached-xheight h)
|
||||
h)))
|
||||
(define cached-xheight #f)
|
||||
(require scheme/class
|
||||
scheme/gui)
|
||||
(provide hrule-snip%)
|
||||
|
||||
;; Snip methods
|
||||
(define/override (copy)
|
||||
(new hrule-snip%))
|
||||
(define/override (write stream)
|
||||
(void))
|
||||
(inherit set-snipclass)
|
||||
(super-new)
|
||||
;; hrule-snip%
|
||||
;; A snip for drawing horizontal separating lines.
|
||||
(define hrule-snip%
|
||||
(class snip%
|
||||
(inherit get-admin)
|
||||
(define/override (get-extent dc x y bw bh bdescent bspace blspace brspace)
|
||||
(let-values [((h) (get-xheight dc))
|
||||
((fw fh) (send dc get-size))]
|
||||
(let ([ad-x (box 0)]
|
||||
[ad-y (box 0)])
|
||||
(send (get-admin) get-view-size ad-x ad-y)
|
||||
#;(set-box?! bw fw)
|
||||
(set-box?! bw (max 0 (- (unbox ad-x) (get-xheight dc))))
|
||||
(set-box?! bh h))))
|
||||
(define/override (draw dc x y left top right bottom dx dy draw-caret)
|
||||
(let* [(xh (get-xheight dc))
|
||||
(ny (+ y (/ xh 2)))]
|
||||
(send dc draw-line x ny right ny)))
|
||||
(define/private (set-box?! b v)
|
||||
(when (box? b) (set-box! b v)))
|
||||
(define/private (get-xheight dc)
|
||||
(or cached-xheight
|
||||
(let-values [((w h descent extra) (send dc get-text-extent "x"))]
|
||||
(set! cached-xheight h)
|
||||
h)))
|
||||
(define cached-xheight #f)
|
||||
|
||||
(set-snipclass snip-class)))
|
||||
;; Snip methods
|
||||
(define/override (copy)
|
||||
(new hrule-snip%))
|
||||
(define/override (write stream)
|
||||
(void))
|
||||
(inherit set-snipclass)
|
||||
(super-new)
|
||||
|
||||
(set-snipclass snip-class)))
|
||||
|
||||
|
||||
(define hrule-snipclass%
|
||||
(class snip-class%
|
||||
(define/override (read stream)
|
||||
(let ([str (send stream get-bytes)])
|
||||
(new hrule-snip%)))
|
||||
(super-new)))
|
||||
|
||||
(define snip-class (new hrule-snipclass%))
|
||||
(send snip-class set-version 1)
|
||||
(send snip-class set-classname
|
||||
(format "~s" '(lib "hrule-snip.ss" "macro-debugger" "syntax-browser")))
|
||||
(send (get-the-snip-class-list) add snip-class)
|
||||
)
|
||||
(define hrule-snipclass%
|
||||
(class snip-class%
|
||||
(define/override (read stream)
|
||||
(let ([str (send stream get-bytes)])
|
||||
(new hrule-snip%)))
|
||||
(super-new)))
|
||||
|
||||
(define snip-class (new hrule-snipclass%))
|
||||
(send snip-class set-version 1)
|
||||
(send snip-class set-classname
|
||||
(format "~s" '(lib "hrule-snip.ss" "macro-debugger" "syntax-browser")))
|
||||
(send (get-the-snip-class-list) add snip-class)
|
||||
|
|
|
|||
|
|
@ -1,167 +1,165 @@
|
|||
|
||||
(module interfaces mzscheme
|
||||
(require (lib "class.ss"))
|
||||
(provide (all-defined))
|
||||
#lang scheme/base
|
||||
(require scheme/class)
|
||||
(provide (all-defined-out))
|
||||
|
||||
;; displays-manager<%>
|
||||
(define displays-manager<%>
|
||||
(interface ()
|
||||
;; add-syntax-display : display<%> -> void
|
||||
add-syntax-display
|
||||
;; displays-manager<%>
|
||||
(define displays-manager<%>
|
||||
(interface ()
|
||||
;; add-syntax-display : display<%> -> void
|
||||
add-syntax-display
|
||||
|
||||
;; remove-all-syntax-displays : -> void
|
||||
remove-all-syntax-displays))
|
||||
;; remove-all-syntax-displays : -> void
|
||||
remove-all-syntax-displays))
|
||||
|
||||
;; selection-manager<%>
|
||||
(define selection-manager<%>
|
||||
(interface ()
|
||||
;; selected-syntax : syntax/#f
|
||||
set-selected-syntax
|
||||
get-selected-syntax
|
||||
listen-selected-syntax
|
||||
))
|
||||
;; selection-manager<%>
|
||||
(define selection-manager<%>
|
||||
(interface ()
|
||||
;; selected-syntax : syntax/#f
|
||||
set-selected-syntax
|
||||
get-selected-syntax
|
||||
listen-selected-syntax
|
||||
))
|
||||
|
||||
;; mark-manager<%>
|
||||
;; Manages marks, mappings from marks to colors
|
||||
(define mark-manager<%>
|
||||
(interface ()
|
||||
;; get-primary-partition : -> partition
|
||||
get-primary-partition))
|
||||
;; mark-manager<%>
|
||||
;; Manages marks, mappings from marks to colors
|
||||
(define mark-manager<%>
|
||||
(interface ()
|
||||
;; get-primary-partition : -> partition
|
||||
get-primary-partition))
|
||||
|
||||
;; secondary-partition<%>
|
||||
(define secondary-partition<%>
|
||||
(interface (displays-manager<%>)
|
||||
;; get-secondary-partition : -> partition<%>
|
||||
get-secondary-partition
|
||||
;; secondary-partition<%>
|
||||
(define secondary-partition<%>
|
||||
(interface (displays-manager<%>)
|
||||
;; get-secondary-partition : -> partition<%>
|
||||
get-secondary-partition
|
||||
|
||||
;; set-secondary-partition : partition<%> -> void
|
||||
set-secondary-partition
|
||||
;; set-secondary-partition : partition<%> -> void
|
||||
set-secondary-partition
|
||||
|
||||
;; listen-secondary-partition : (partition<%> -> void) -> void
|
||||
listen-secondary-partition
|
||||
;; listen-secondary-partition : (partition<%> -> void) -> void
|
||||
listen-secondary-partition
|
||||
|
||||
;; get-identifier=? : -> (cons string procedure)
|
||||
get-identifier=?
|
||||
;; get-identifier=? : -> (cons string procedure)
|
||||
get-identifier=?
|
||||
|
||||
;; set-identifier=? : (cons string procedure) -> void
|
||||
set-identifier=?
|
||||
;; set-identifier=? : (cons string procedure) -> void
|
||||
set-identifier=?
|
||||
|
||||
;; listen-identifier=? : ((cons string procedure) -> void) -> void
|
||||
listen-identifier=?))
|
||||
;; listen-identifier=? : ((cons string procedure) -> void) -> void
|
||||
listen-identifier=?))
|
||||
|
||||
;; controller<%>
|
||||
(define controller<%>
|
||||
(interface (displays-manager<%>
|
||||
selection-manager<%>
|
||||
mark-manager<%>
|
||||
secondary-partition<%>)))
|
||||
;; controller<%>
|
||||
(define controller<%>
|
||||
(interface (displays-manager<%>
|
||||
selection-manager<%>
|
||||
mark-manager<%>
|
||||
secondary-partition<%>)))
|
||||
|
||||
;; host<%>
|
||||
(define host<%>
|
||||
(interface ()
|
||||
;; get-controller : -> controller<%>
|
||||
get-controller
|
||||
;; host<%>
|
||||
(define host<%>
|
||||
(interface ()
|
||||
;; get-controller : -> controller<%>
|
||||
get-controller
|
||||
|
||||
;; add-keymap : text snip
|
||||
add-keymap
|
||||
))
|
||||
;; add-keymap : text snip
|
||||
add-keymap
|
||||
))
|
||||
|
||||
|
||||
;; display<%>
|
||||
(define display<%>
|
||||
(interface ()
|
||||
;; refresh : -> void
|
||||
refresh
|
||||
;; display<%>
|
||||
(define display<%>
|
||||
(interface ()
|
||||
;; refresh : -> void
|
||||
refresh
|
||||
|
||||
;; highlight-syntaxes : (list-of syntax) color -> void
|
||||
highlight-syntaxes
|
||||
;; highlight-syntaxes : (list-of syntax) color -> void
|
||||
highlight-syntaxes
|
||||
|
||||
;; get-start-position : -> number
|
||||
get-start-position
|
||||
;; get-start-position : -> number
|
||||
get-start-position
|
||||
|
||||
;; get-end-position : -> number
|
||||
get-end-position
|
||||
;; get-end-position : -> number
|
||||
get-end-position
|
||||
|
||||
;; get-range : -> range<%>
|
||||
get-range))
|
||||
;; get-range : -> range<%>
|
||||
get-range))
|
||||
|
||||
;; range<%>
|
||||
(define range<%>
|
||||
(interface ()
|
||||
;; get-ranges : datum -> (list-of (cons number number))
|
||||
get-ranges
|
||||
;; range<%>
|
||||
(define range<%>
|
||||
(interface ()
|
||||
;; get-ranges : datum -> (list-of (cons number number))
|
||||
get-ranges
|
||||
|
||||
;; all-ranges : (list-of Range)
|
||||
;; Sorted outermost-first
|
||||
all-ranges
|
||||
;; all-ranges : (list-of Range)
|
||||
;; Sorted outermost-first
|
||||
all-ranges
|
||||
|
||||
;; get-identifier-list : (list-of identifier)
|
||||
get-identifier-list))
|
||||
;; get-identifier-list : (list-of identifier)
|
||||
get-identifier-list))
|
||||
|
||||
;; A Range is (make-range datum number number)
|
||||
(define-struct range (obj start end))
|
||||
;; A Range is (make-range datum number number)
|
||||
(define-struct range (obj start end))
|
||||
|
||||
|
||||
;; syntax-prefs<%>
|
||||
(define syntax-prefs<%>
|
||||
(interface ()
|
||||
pref:width
|
||||
pref:height
|
||||
pref:props-percentage
|
||||
pref:props-shown?))
|
||||
;; syntax-prefs<%>
|
||||
(define syntax-prefs<%>
|
||||
(interface ()
|
||||
pref:width
|
||||
pref:height
|
||||
pref:props-percentage
|
||||
pref:props-shown?))
|
||||
|
||||
;; widget-hooks<%>
|
||||
(define widget-hooks<%>
|
||||
(interface ()
|
||||
;; setup-keymap : -> void
|
||||
setup-keymap
|
||||
;; widget-hooks<%>
|
||||
(define widget-hooks<%>
|
||||
(interface ()
|
||||
;; setup-keymap : -> void
|
||||
setup-keymap
|
||||
|
||||
;; shutdown : -> void
|
||||
shutdown
|
||||
))
|
||||
;; shutdown : -> void
|
||||
shutdown
|
||||
))
|
||||
|
||||
;; keymap-hooks<%>
|
||||
(define keymap-hooks<%>
|
||||
(interface ()
|
||||
;; make-context-menu : -> context-menu<%>
|
||||
make-context-menu
|
||||
;; keymap-hooks<%>
|
||||
(define keymap-hooks<%>
|
||||
(interface ()
|
||||
;; make-context-menu : -> context-menu<%>
|
||||
make-context-menu
|
||||
|
||||
;; get-context-menu% : -> class
|
||||
get-context-menu%))
|
||||
;; get-context-menu% : -> class
|
||||
get-context-menu%))
|
||||
|
||||
;; context-menu-hooks<%>
|
||||
(define context-menu-hooks<%>
|
||||
(interface ()
|
||||
add-edit-items
|
||||
after-edit-items
|
||||
add-selection-items
|
||||
after-selection-items
|
||||
add-partition-items
|
||||
after-partition-items))
|
||||
;; context-menu-hooks<%>
|
||||
(define context-menu-hooks<%>
|
||||
(interface ()
|
||||
add-edit-items
|
||||
after-edit-items
|
||||
add-selection-items
|
||||
after-selection-items
|
||||
add-partition-items
|
||||
after-partition-items))
|
||||
|
||||
|
||||
;;----------
|
||||
;;----------
|
||||
|
||||
;; Convenience widget, specialized for displaying stx and not much else
|
||||
(define syntax-browser<%>
|
||||
(interface ()
|
||||
add-syntax
|
||||
add-text
|
||||
add-separator
|
||||
erase-all
|
||||
select-syntax
|
||||
get-text
|
||||
))
|
||||
;; Convenience widget, specialized for displaying stx and not much else
|
||||
(define syntax-browser<%>
|
||||
(interface ()
|
||||
add-syntax
|
||||
add-text
|
||||
add-separator
|
||||
erase-all
|
||||
select-syntax
|
||||
get-text
|
||||
))
|
||||
|
||||
(define partition<%>
|
||||
(interface ()
|
||||
;; get-partition : any -> number
|
||||
get-partition
|
||||
(define partition<%>
|
||||
(interface ()
|
||||
;; get-partition : any -> number
|
||||
get-partition
|
||||
|
||||
;; same-partition? : any any -> number
|
||||
same-partition?
|
||||
;; same-partition? : any any -> number
|
||||
same-partition?
|
||||
|
||||
;; count : -> number
|
||||
count))
|
||||
|
||||
)
|
||||
;; count : -> number
|
||||
count))
|
||||
|
|
|
|||
|
|
@ -1,152 +1,150 @@
|
|||
|
||||
(module keymap mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
"interfaces.ss"
|
||||
"partition.ss")
|
||||
(provide syntax-keymap%
|
||||
context-menu%)
|
||||
#lang scheme/base
|
||||
(require scheme/class
|
||||
scheme/gui
|
||||
"interfaces.ss"
|
||||
"partition.ss")
|
||||
(provide syntax-keymap%
|
||||
context-menu%)
|
||||
|
||||
(define syntax-keymap%
|
||||
(class keymap%
|
||||
(init editor)
|
||||
(init-field controller)
|
||||
(define syntax-keymap%
|
||||
(class keymap%
|
||||
(init editor)
|
||||
(init-field controller)
|
||||
|
||||
(inherit add-function
|
||||
map-function
|
||||
chain-to-keymap)
|
||||
(super-new)
|
||||
(inherit add-function
|
||||
map-function
|
||||
chain-to-keymap)
|
||||
(super-new)
|
||||
|
||||
(define/public (get-context-menu%)
|
||||
context-menu%)
|
||||
(define/public (get-context-menu%)
|
||||
context-menu%)
|
||||
|
||||
(define/public (make-context-menu)
|
||||
(new (get-context-menu%) (controller controller) (keymap this)))
|
||||
(define/public (make-context-menu)
|
||||
(new (get-context-menu%) (controller controller) (keymap this)))
|
||||
|
||||
;; Key mappings
|
||||
;; Key mappings
|
||||
|
||||
(map-function "rightbutton" "popup-context-window")
|
||||
(map-function "rightbutton" "popup-context-window")
|
||||
|
||||
;; Functionality
|
||||
;; Functionality
|
||||
|
||||
(add-function "popup-context-window"
|
||||
(lambda (editor event)
|
||||
(do-popup-context-window editor event)))
|
||||
(add-function "popup-context-window"
|
||||
(lambda (editor event)
|
||||
(do-popup-context-window editor event)))
|
||||
|
||||
(add-function "copy-text"
|
||||
(lambda (_ event)
|
||||
(define stx (send controller get-selected-syntax))
|
||||
(send the-clipboard set-clipboard-string
|
||||
(if stx
|
||||
(format "~s" (syntax-object->datum stx))
|
||||
"")
|
||||
(send event get-time-stamp))))
|
||||
(add-function "copy-text"
|
||||
(lambda (_ event)
|
||||
(define stx (send controller get-selected-syntax))
|
||||
(send the-clipboard set-clipboard-string
|
||||
(if stx
|
||||
(format "~s" (syntax->datum stx))
|
||||
"")
|
||||
(send event get-time-stamp))))
|
||||
|
||||
(add-function "clear-syntax-selection"
|
||||
(lambda (i e)
|
||||
(send controller set-selected-syntax #f)))
|
||||
(add-function "clear-syntax-selection"
|
||||
(lambda (i e)
|
||||
(send controller set-selected-syntax #f)))
|
||||
|
||||
(add-function "show-syntax-properties"
|
||||
(lambda (i e)
|
||||
(error 'show-syntax-properties "not provided by this keymap")))
|
||||
(add-function "show-syntax-properties"
|
||||
(lambda (i e)
|
||||
(error 'show-syntax-properties "not provided by this keymap")))
|
||||
|
||||
;; Attach to editor
|
||||
;; Attach to editor
|
||||
|
||||
(chain-to-keymap (send editor get-keymap) #t)
|
||||
(send editor set-keymap this)
|
||||
(chain-to-keymap (send editor get-keymap) #t)
|
||||
(send editor set-keymap this)
|
||||
|
||||
(define/public (get-controller) controller)
|
||||
(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/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)
|
||||
(define context-menu%
|
||||
(class popup-menu%
|
||||
(init-field keymap)
|
||||
(init-field controller)
|
||||
(super-new)
|
||||
|
||||
(field [copy-menu #f]
|
||||
[clear-menu #f]
|
||||
[props-menu #f])
|
||||
(field [copy-menu #f]
|
||||
[clear-menu #f]
|
||||
[props-menu #f])
|
||||
|
||||
(define/public (add-edit-items)
|
||||
(set! copy-menu
|
||||
(new menu-item% (label "Copy") (parent this)
|
||||
(callback (lambda (i e)
|
||||
(send keymap call-function "copy-text" i e)))))
|
||||
(void))
|
||||
(define/public (add-edit-items)
|
||||
(set! copy-menu
|
||||
(new menu-item% (label "Copy") (parent this)
|
||||
(callback (lambda (i e)
|
||||
(send keymap call-function "copy-text" i e)))))
|
||||
(void))
|
||||
|
||||
(define/public (after-edit-items)
|
||||
(void))
|
||||
(define/public (after-edit-items)
|
||||
(void))
|
||||
|
||||
(define/public (add-selection-items)
|
||||
(set! clear-menu
|
||||
(new menu-item%
|
||||
(label "Clear selection")
|
||||
(parent this)
|
||||
(callback
|
||||
(lambda (i e)
|
||||
(send keymap call-function "clear-syntax-selection" i e)))))
|
||||
(set! props-menu
|
||||
(new menu-item%
|
||||
(label "Show syntax properties")
|
||||
(parent this)
|
||||
(callback
|
||||
(lambda (i e)
|
||||
(send keymap call-function "show-syntax-properties" i e)))))
|
||||
(void))
|
||||
(define/public (add-selection-items)
|
||||
(set! clear-menu
|
||||
(new menu-item%
|
||||
(label "Clear selection")
|
||||
(parent this)
|
||||
(callback
|
||||
(lambda (i e)
|
||||
(send keymap call-function "clear-syntax-selection" i e)))))
|
||||
(set! props-menu
|
||||
(new menu-item%
|
||||
(label "Show syntax properties")
|
||||
(parent this)
|
||||
(callback
|
||||
(lambda (i e)
|
||||
(send keymap call-function "show-syntax-properties" i e)))))
|
||||
(void))
|
||||
|
||||
(define/public (after-selection-items)
|
||||
(void))
|
||||
(define/public (after-selection-items)
|
||||
(void))
|
||||
|
||||
(define/public (add-partition-items)
|
||||
(let ([secondary (new menu% (label "identifier=?") (parent this))])
|
||||
(for-each
|
||||
(lambda (name func)
|
||||
(let ([this-choice
|
||||
(new checkable-menu-item%
|
||||
(label name)
|
||||
(parent secondary)
|
||||
(callback
|
||||
(lambda (i e)
|
||||
(send controller set-identifier=?
|
||||
(cons name func)))))])
|
||||
(send controller listen-identifier=?
|
||||
(lambda (name+proc)
|
||||
(send this-choice check (eq? name (car name+proc)))))))
|
||||
(map car (identifier=-choices))
|
||||
(map cdr (identifier=-choices))))
|
||||
(void))
|
||||
(define/public (add-partition-items)
|
||||
(let ([secondary (new menu% (label "identifier=?") (parent this))])
|
||||
(for-each
|
||||
(lambda (name func)
|
||||
(let ([this-choice
|
||||
(new checkable-menu-item%
|
||||
(label name)
|
||||
(parent secondary)
|
||||
(callback
|
||||
(lambda (i e)
|
||||
(send controller set-identifier=?
|
||||
(cons name func)))))])
|
||||
(send controller listen-identifier=?
|
||||
(lambda (name+proc)
|
||||
(send this-choice check (eq? name (car name+proc)))))))
|
||||
(map car (identifier=-choices))
|
||||
(map cdr (identifier=-choices))))
|
||||
(void))
|
||||
|
||||
(define/public (after-partition-items)
|
||||
(void))
|
||||
(define/public (after-partition-items)
|
||||
(void))
|
||||
|
||||
(define/public (add-separator)
|
||||
(new separator-menu-item% (parent this)))
|
||||
(define/public (add-separator)
|
||||
(new separator-menu-item% (parent this)))
|
||||
|
||||
(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))
|
||||
(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))
|
||||
|
||||
;; Initialization
|
||||
(add-edit-items)
|
||||
(after-edit-items)
|
||||
;; Initialization
|
||||
(add-edit-items)
|
||||
(after-edit-items)
|
||||
|
||||
(add-separator)
|
||||
(add-selection-items)
|
||||
(after-selection-items)
|
||||
(add-separator)
|
||||
(add-selection-items)
|
||||
(after-selection-items)
|
||||
|
||||
(add-separator)
|
||||
(add-partition-items)
|
||||
(after-partition-items)
|
||||
))
|
||||
|
||||
)
|
||||
(add-separator)
|
||||
(add-partition-items)
|
||||
(after-partition-items)
|
||||
))
|
||||
|
|
|
|||
|
|
@ -1,159 +1,157 @@
|
|||
|
||||
(module partition mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "boundmap.ss" "syntax")
|
||||
(lib "stx.ss" "syntax")
|
||||
"interfaces.ss")
|
||||
(provide new-bound-partition
|
||||
partition%
|
||||
identifier=-choices)
|
||||
|
||||
(define (new-bound-partition)
|
||||
(new bound-partition%))
|
||||
|
||||
;; representative-symbol : symbol
|
||||
;; Must be fresh---otherwise, using it could detect rename wraps
|
||||
;; instead of only marks.
|
||||
;; For example, in (lambda (representative) representative)
|
||||
(define representative-symbol
|
||||
(gensym 'representative))
|
||||
#lang scheme/base
|
||||
(require scheme/class
|
||||
syntax/boundmap
|
||||
syntax/stx
|
||||
"interfaces.ss")
|
||||
(provide new-bound-partition
|
||||
partition%
|
||||
identifier=-choices)
|
||||
|
||||
;; unmarked-syntax : identifier
|
||||
;; Has no marks---used to initialize bound partition so that
|
||||
;; unmarked syntax always gets colored "black"
|
||||
(define unmarked-syntax
|
||||
(datum->syntax-object #f representative-symbol))
|
||||
|
||||
(define partition%
|
||||
(class* object% (partition<%>)
|
||||
(init relation)
|
||||
(define (new-bound-partition)
|
||||
(new bound-partition%))
|
||||
|
||||
(define related? (or relation (lambda (a b) #f)))
|
||||
(field (rep=>num (make-hash-table)))
|
||||
(field (obj=>rep (make-hash-table 'weak)))
|
||||
(field (reps null))
|
||||
(field (next-num 0))
|
||||
|
||||
(define/public (get-partition obj)
|
||||
(rep->partition (obj->rep obj)))
|
||||
;; representative-symbol : symbol
|
||||
;; Must be fresh---otherwise, using it could detect rename wraps
|
||||
;; instead of only marks.
|
||||
;; For example, in (lambda (representative) representative)
|
||||
(define representative-symbol
|
||||
(gensym 'representative))
|
||||
|
||||
(define/public (same-partition? A B)
|
||||
(= (get-partition A) (get-partition B)))
|
||||
|
||||
(define/private (obj->rep obj)
|
||||
(hash-table-get obj=>rep obj (lambda () (obj->rep* obj))))
|
||||
|
||||
(define/public (count)
|
||||
next-num)
|
||||
;; unmarked-syntax : identifier
|
||||
;; Has no marks---used to initialize bound partition so that
|
||||
;; unmarked syntax always gets colored "black"
|
||||
(define unmarked-syntax
|
||||
(datum->syntax #f representative-symbol))
|
||||
|
||||
(define/private (obj->rep* obj)
|
||||
(let loop ([reps reps])
|
||||
(cond [(null? reps)
|
||||
(new-rep obj)]
|
||||
[(related? obj (car reps))
|
||||
(hash-table-put! obj=>rep obj (car reps))
|
||||
(car reps)]
|
||||
[else
|
||||
(loop (cdr reps))])))
|
||||
(define partition%
|
||||
(class* object% (partition<%>)
|
||||
(init relation)
|
||||
|
||||
(define/private (new-rep rep)
|
||||
(hash-table-put! rep=>num rep next-num)
|
||||
(set! next-num (add1 next-num))
|
||||
(set! reps (cons rep reps))
|
||||
rep)
|
||||
|
||||
(define/private (rep->partition rep)
|
||||
(hash-table-get rep=>num rep))
|
||||
(define related? (or relation (lambda (a b) #f)))
|
||||
(field (rep=>num (make-hash-table)))
|
||||
(field (obj=>rep (make-hash-table 'weak)))
|
||||
(field (reps null))
|
||||
(field (next-num 0))
|
||||
|
||||
(define/public (get-partition obj)
|
||||
(rep->partition (obj->rep obj)))
|
||||
|
||||
;; Nearly useless as it stands
|
||||
(define/public (dump)
|
||||
(hash-table-for-each
|
||||
rep=>num
|
||||
(lambda (k v)
|
||||
(printf "~s => ~s~n" k v))))
|
||||
(define/public (same-partition? A B)
|
||||
(= (get-partition A) (get-partition B)))
|
||||
|
||||
(define/private (obj->rep obj)
|
||||
(hash-table-get obj=>rep obj (lambda () (obj->rep* obj))))
|
||||
|
||||
(define/public (count)
|
||||
next-num)
|
||||
|
||||
(get-partition unmarked-syntax)
|
||||
(super-new)
|
||||
))
|
||||
|
||||
;; bound-partition%
|
||||
(define bound-partition%
|
||||
(class* object% (partition<%>)
|
||||
;; numbers : bound-identifier-mapping[identifier => number]
|
||||
(define numbers (make-bound-identifier-mapping))
|
||||
(define next-number 0)
|
||||
|
||||
(define/public (get-partition stx)
|
||||
(let* ([r (representative stx)]
|
||||
[n (bound-identifier-mapping-get numbers r (lambda _ #f))])
|
||||
(or n
|
||||
(begin0 next-number
|
||||
(bound-identifier-mapping-put! numbers r next-number)
|
||||
#;(printf "primary partition new stx:~n~s~n~s~n" stx (syntax-object->datum stx))
|
||||
(set! next-number (add1 next-number))))))
|
||||
|
||||
(define/public (same-partition? a b)
|
||||
(= (get-partition a) (get-partition b)))
|
||||
|
||||
(define/public (count)
|
||||
next-number)
|
||||
|
||||
(define/private (representative stx)
|
||||
(datum->syntax-object stx representative-symbol))
|
||||
(define/private (obj->rep* obj)
|
||||
(let loop ([reps reps])
|
||||
(cond [(null? reps)
|
||||
(new-rep obj)]
|
||||
[(related? obj (car reps))
|
||||
(hash-table-put! obj=>rep obj (car reps))
|
||||
(car reps)]
|
||||
[else
|
||||
(loop (cdr reps))])))
|
||||
|
||||
(get-partition unmarked-syntax)
|
||||
(super-new)))
|
||||
|
||||
;; Different identifier relations for highlighting.
|
||||
(define/private (new-rep rep)
|
||||
(hash-table-put! rep=>num rep next-num)
|
||||
(set! next-num (add1 next-num))
|
||||
(set! reps (cons rep reps))
|
||||
rep)
|
||||
|
||||
(define/private (rep->partition rep)
|
||||
(hash-table-get rep=>num rep))
|
||||
|
||||
(define (lift/rep id=?)
|
||||
(lambda (A B)
|
||||
(let ([ra (datum->syntax-object A representative-symbol)]
|
||||
[rb (datum->syntax-object B representative-symbol)])
|
||||
(id=? ra rb))))
|
||||
|
||||
(define (lift id=?)
|
||||
(lambda (A B)
|
||||
(and (identifier? A) (identifier? B) (id=? A B))))
|
||||
|
||||
;; id:same-marks? : syntax syntax -> boolean
|
||||
(define id:same-marks?
|
||||
(lift/rep bound-identifier=?))
|
||||
;; Nearly useless as it stands
|
||||
(define/public (dump)
|
||||
(hash-table-for-each
|
||||
rep=>num
|
||||
(lambda (k v)
|
||||
(printf "~s => ~s~n" k v))))
|
||||
|
||||
;; id:X-module=? : identifier identifier -> boolean
|
||||
;; If both module-imported, do they come from the same module?
|
||||
;; If both top-bound, then same source.
|
||||
(define (id:source-module=? a b)
|
||||
(let ([ba (identifier-binding a)]
|
||||
[bb (identifier-binding b)])
|
||||
(cond [(or (eq? 'lexical ba) (eq? 'lexical bb))
|
||||
(module-identifier=? a b)]
|
||||
[(and (not ba) (not bb))
|
||||
#t]
|
||||
[(or (not ba) (not bb))
|
||||
#f]
|
||||
[else
|
||||
(eq? (car ba) (car bb))])))
|
||||
(define (id:nominal-module=? A B)
|
||||
(let ([ba (identifier-binding A)]
|
||||
[bb (identifier-binding B)])
|
||||
(cond [(or (eq? 'lexical ba) (eq? 'lexical bb))
|
||||
(module-identifier=? A B)]
|
||||
[(or (not ba) (not bb))
|
||||
(and (not ba) (not bb))]
|
||||
[else (eq? (caddr ba) (caddr bb))])))
|
||||
|
||||
(define (symbolic-identifier=? A B)
|
||||
(eq? (syntax-e A) (syntax-e B)))
|
||||
(get-partition unmarked-syntax)
|
||||
(super-new)
|
||||
))
|
||||
|
||||
(define identifier=-choices
|
||||
(make-parameter
|
||||
`(("<nothing>" . #f)
|
||||
("bound-identifier=?" . ,bound-identifier=?)
|
||||
("module-identifier=?" . ,module-identifier=?)
|
||||
("module-or-top-identifier=?" . ,module-or-top-identifier=?)
|
||||
("symbolic-identifier=?" . ,symbolic-identifier=?)
|
||||
("same source module" . ,id:source-module=?)
|
||||
("same nominal module" . ,id:nominal-module=?))))
|
||||
|
||||
)
|
||||
;; bound-partition%
|
||||
(define bound-partition%
|
||||
(class* object% (partition<%>)
|
||||
;; numbers : bound-identifier-mapping[identifier => number]
|
||||
(define numbers (make-bound-identifier-mapping))
|
||||
(define next-number 0)
|
||||
|
||||
(define/public (get-partition stx)
|
||||
(let* ([r (representative stx)]
|
||||
[n (bound-identifier-mapping-get numbers r (lambda _ #f))])
|
||||
(or n
|
||||
(begin0 next-number
|
||||
(bound-identifier-mapping-put! numbers r next-number)
|
||||
#;(printf "primary partition new stx:~n~s~n~s~n" stx (syntax->datum stx))
|
||||
(set! next-number (add1 next-number))))))
|
||||
|
||||
(define/public (same-partition? a b)
|
||||
(= (get-partition a) (get-partition b)))
|
||||
|
||||
(define/public (count)
|
||||
next-number)
|
||||
|
||||
(define/private (representative stx)
|
||||
(datum->syntax stx representative-symbol))
|
||||
|
||||
(get-partition unmarked-syntax)
|
||||
(super-new)))
|
||||
|
||||
;; Different identifier relations for highlighting.
|
||||
|
||||
(define (lift/rep id=?)
|
||||
(lambda (A B)
|
||||
(let ([ra (datum->syntax A representative-symbol)]
|
||||
[rb (datum->syntax B representative-symbol)])
|
||||
(id=? ra rb))))
|
||||
|
||||
(define (lift id=?)
|
||||
(lambda (A B)
|
||||
(and (identifier? A) (identifier? B) (id=? A B))))
|
||||
|
||||
;; id:same-marks? : syntax syntax -> boolean
|
||||
(define id:same-marks?
|
||||
(lift/rep bound-identifier=?))
|
||||
|
||||
;; id:X-module=? : identifier identifier -> boolean
|
||||
;; If both module-imported, do they come from the same module?
|
||||
;; If both top-bound, then same source.
|
||||
(define (id:source-module=? a b)
|
||||
(let ([ba (identifier-binding a)]
|
||||
[bb (identifier-binding b)])
|
||||
(cond [(or (eq? 'lexical ba) (eq? 'lexical bb))
|
||||
(free-identifier=? a b)]
|
||||
[(and (not ba) (not bb))
|
||||
#t]
|
||||
[(or (not ba) (not bb))
|
||||
#f]
|
||||
[else
|
||||
(eq? (car ba) (car bb))])))
|
||||
(define (id:nominal-module=? A B)
|
||||
(let ([ba (identifier-binding A)]
|
||||
[bb (identifier-binding B)])
|
||||
(cond [(or (eq? 'lexical ba) (eq? 'lexical bb))
|
||||
(free-identifier=? A B)]
|
||||
[(or (not ba) (not bb))
|
||||
(and (not ba) (not bb))]
|
||||
[else (eq? (caddr ba) (caddr bb))])))
|
||||
|
||||
(define (symbolic-identifier=? A B)
|
||||
(eq? (syntax-e A) (syntax-e B)))
|
||||
|
||||
(define identifier=-choices
|
||||
(make-parameter
|
||||
`(("<nothing>" . #f)
|
||||
("bound-identifier=?" . ,bound-identifier=?)
|
||||
("free-identifier=?" . ,free-identifier=?)
|
||||
("module-or-top-identifier=?" . ,module-or-top-identifier=?)
|
||||
("symbolic-identifier=?" . ,symbolic-identifier=?)
|
||||
("same source module" . ,id:source-module=?)
|
||||
("same nominal module" . ,id:nominal-module=?))))
|
||||
|
|
|
|||
|
|
@ -1,32 +1,31 @@
|
|||
|
||||
(module prefs mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "framework.ss" "framework")
|
||||
"interfaces.ss"
|
||||
"../util/misc.ss")
|
||||
(provide syntax-prefs%
|
||||
syntax-prefs-mixin
|
||||
#lang scheme/base
|
||||
(require scheme/class
|
||||
framework/framework
|
||||
"interfaces.ss"
|
||||
"../util/misc.ss")
|
||||
(provide syntax-prefs%
|
||||
syntax-prefs-mixin
|
||||
|
||||
pref:tabify)
|
||||
pref:tabify)
|
||||
|
||||
(preferences:set-default 'SyntaxBrowser:Width 700 number?)
|
||||
(preferences:set-default 'SyntaxBrowser:Height 600 number?)
|
||||
(preferences:set-default 'SyntaxBrowser:PropertiesPanelPercentage 1/3 number?)
|
||||
(preferences:set-default 'SyntaxBrowser:PropertiesPanelShown #t boolean?)
|
||||
(preferences:set-default 'SyntaxBrowser:Width 700 number?)
|
||||
(preferences:set-default 'SyntaxBrowser:Height 600 number?)
|
||||
(preferences:set-default 'SyntaxBrowser:PropertiesPanelPercentage 1/3 number?)
|
||||
(preferences:set-default 'SyntaxBrowser:PropertiesPanelShown #t boolean?)
|
||||
|
||||
(pref:get/set pref:width SyntaxBrowser:Width)
|
||||
(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:width SyntaxBrowser:Width)
|
||||
(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)
|
||||
(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-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% (syntax-prefs-mixin object%))
|
||||
)
|
||||
(define syntax-prefs% (syntax-prefs-mixin object%))
|
||||
|
|
|
|||
|
|
@ -1,150 +1,148 @@
|
|||
|
||||
(module pretty-helper mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "stx.ss" "syntax")
|
||||
"partition.ss")
|
||||
(provide (all-defined))
|
||||
#lang scheme/base
|
||||
(require scheme/class
|
||||
syntax/stx
|
||||
"partition.ss")
|
||||
(provide (all-defined-out))
|
||||
|
||||
;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it
|
||||
;; still may be the case that (syntax-e stx1) and (syntax-e stx2) are
|
||||
;; indistinguishable.
|
||||
;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it
|
||||
;; still may be the case that (syntax-e stx1) and (syntax-e stx2) are
|
||||
;; indistinguishable.
|
||||
|
||||
;; Solution: Rather than map stx to (syntax-e stx), in the cases where
|
||||
;; (syntax-e stx) is confusable, map it to a different, unique, value.
|
||||
;; - stx is identifier : map it to an uninterned symbol w/ same rep
|
||||
;; (Symbols are useful: see pretty-print's style table)
|
||||
;; - else : map it to a syntax-dummy object
|
||||
;; Solution: Rather than map stx to (syntax-e stx), in the cases where
|
||||
;; (syntax-e stx) is confusable, map it to a different, unique, value.
|
||||
;; - stx is identifier : map it to an uninterned symbol w/ same rep
|
||||
;; (Symbols are useful: see pretty-print's style table)
|
||||
;; - else : map it to a syntax-dummy object
|
||||
|
||||
;; NOTE: Nulls are only wrapped when *not* list-terminators.
|
||||
;; If they were always wrapped, the pretty-printer would screw up
|
||||
;; list printing (I think).
|
||||
;; NOTE: Nulls are only wrapped when *not* list-terminators.
|
||||
;; If they were always wrapped, the pretty-printer would screw up
|
||||
;; list printing (I think).
|
||||
|
||||
(define-struct syntax-dummy (val))
|
||||
(define-struct syntax-dummy (val))
|
||||
|
||||
;; A SuffixOption is one of
|
||||
;; - 'never -- never
|
||||
;; - 'always -- suffix > 0
|
||||
;; - 'over-limit -- suffix > limit
|
||||
;; - 'all-if-over-limit -- suffix > 0 if any over limit
|
||||
;; A SuffixOption is one of
|
||||
;; - 'never -- never
|
||||
;; - 'always -- suffix > 0
|
||||
;; - 'over-limit -- suffix > limit
|
||||
;; - 'all-if-over-limit -- suffix > 0 if any over limit
|
||||
|
||||
;; syntax->datum/tables : stx [partition% num SuffixOption]
|
||||
;; -> (values s-expr hashtable hashtable)
|
||||
;; When partition is not false, tracks the partititions that subterms belong to
|
||||
;; When limit is a number, restarts processing with numbering? set to true
|
||||
;;
|
||||
;; Returns three values:
|
||||
;; - an S-expression
|
||||
;; - a hashtable mapping S-expressions to syntax objects
|
||||
;; - a hashtable mapping syntax objects to S-expressions
|
||||
;; Syntax objects which are eq? will map to same flat values
|
||||
(define syntax->datum/tables
|
||||
(case-lambda
|
||||
[(stx) (table stx #f #f 'never)]
|
||||
[(stx partition limit suffixopt) (table stx partition limit suffixopt)]))
|
||||
;; syntax->datum/tables : stx [partition% num SuffixOption]
|
||||
;; -> (values s-expr hashtable hashtable)
|
||||
;; When partition is not false, tracks the partititions that subterms belong to
|
||||
;; When limit is a number, restarts processing with numbering? set to true
|
||||
;;
|
||||
;; Returns three values:
|
||||
;; - an S-expression
|
||||
;; - a hashtable mapping S-expressions to syntax objects
|
||||
;; - a hashtable mapping syntax objects to S-expressions
|
||||
;; Syntax objects which are eq? will map to same flat values
|
||||
(define syntax->datum/tables
|
||||
(case-lambda
|
||||
[(stx) (table stx #f #f 'never)]
|
||||
[(stx partition limit suffixopt) (table stx partition limit suffixopt)]))
|
||||
|
||||
;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable)
|
||||
(define (table stx partition limit suffixopt)
|
||||
(define (make-identifier-proxy id)
|
||||
(case suffixopt
|
||||
((never) (unintern (syntax-e id)))
|
||||
((always)
|
||||
(let ([n (send partition get-partition id)])
|
||||
(if (zero? n) (unintern (syntax-e id)) (suffix (syntax-e id) n))))
|
||||
((over-limit)
|
||||
(let ([n (send partition get-partition id)])
|
||||
(if (<= n limit)
|
||||
(unintern (syntax-e id))
|
||||
(suffix (syntax-e id) n))))))
|
||||
;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable)
|
||||
(define (table stx partition limit suffixopt)
|
||||
(define (make-identifier-proxy id)
|
||||
(case suffixopt
|
||||
((never) (unintern (syntax-e id)))
|
||||
((always)
|
||||
(let ([n (send partition get-partition id)])
|
||||
(if (zero? n) (unintern (syntax-e id)) (suffix (syntax-e id) n))))
|
||||
((over-limit)
|
||||
(let ([n (send partition get-partition id)])
|
||||
(if (<= n limit)
|
||||
(unintern (syntax-e id))
|
||||
(suffix (syntax-e id) n))))))
|
||||
|
||||
(let/ec escape
|
||||
(let ([flat=>stx (make-hash-table)]
|
||||
[stx=>flat (make-hash-table)])
|
||||
(define (loop obj)
|
||||
(cond [(hash-table-get stx=>flat obj (lambda _ #f))
|
||||
=> (lambda (datum) datum)]
|
||||
[(and partition (identifier? obj))
|
||||
(when (and (eq? suffixopt 'all-if-over-limit)
|
||||
(> (send partition count) limit))
|
||||
(call-with-values (lambda () (table stx partition #f 'always))
|
||||
escape))
|
||||
(let ([lp-datum (make-identifier-proxy obj)])
|
||||
(hash-table-put! flat=>stx lp-datum obj)
|
||||
(hash-table-put! stx=>flat obj lp-datum)
|
||||
lp-datum)]
|
||||
[(and (syntax? obj) (check+convert-special-expression obj))
|
||||
=> (lambda (newobj)
|
||||
(when partition (send partition get-partition obj))
|
||||
(let* ([inner (cadr newobj)]
|
||||
[lp-inner-datum (loop inner)]
|
||||
[lp-datum (list (car newobj) lp-inner-datum)])
|
||||
(hash-table-put! flat=>stx lp-inner-datum inner)
|
||||
(hash-table-put! stx=>flat inner lp-inner-datum)
|
||||
(hash-table-put! flat=>stx lp-datum obj)
|
||||
(hash-table-put! stx=>flat obj lp-datum)
|
||||
lp-datum))]
|
||||
[(syntax? obj)
|
||||
(when partition (send partition get-partition obj))
|
||||
(let ([lp-datum (loop (syntax-e obj))])
|
||||
(hash-table-put! flat=>stx lp-datum obj)
|
||||
(hash-table-put! stx=>flat obj lp-datum)
|
||||
lp-datum)]
|
||||
[(pair? obj)
|
||||
(pairloop obj)]
|
||||
[(symbol? obj)
|
||||
(unintern obj)]
|
||||
[(null? obj)
|
||||
(make-syntax-dummy obj)]
|
||||
[(boolean? obj)
|
||||
(make-syntax-dummy obj)]
|
||||
[(number? obj)
|
||||
(make-syntax-dummy obj)]
|
||||
[(keyword? obj)
|
||||
(make-syntax-dummy obj)]
|
||||
[(vector? obj)
|
||||
(list->vector (map loop (vector->list obj)))]
|
||||
[(box? obj)
|
||||
(box (loop (unbox obj)))]
|
||||
[else obj]))
|
||||
(define (pairloop obj)
|
||||
(cond [(pair? obj)
|
||||
(cons (loop (car obj))
|
||||
(pairloop (cdr obj)))]
|
||||
[(null? obj)
|
||||
null]
|
||||
[(and (syntax? obj) (null? (syntax-e obj)))
|
||||
null]
|
||||
[else (loop obj)]))
|
||||
(values (loop stx)
|
||||
flat=>stx
|
||||
stx=>flat))))
|
||||
(let/ec escape
|
||||
(let ([flat=>stx (make-hash-table)]
|
||||
[stx=>flat (make-hash-table)])
|
||||
(define (loop obj)
|
||||
(cond [(hash-table-get stx=>flat obj (lambda _ #f))
|
||||
=> (lambda (datum) datum)]
|
||||
[(and partition (identifier? obj))
|
||||
(when (and (eq? suffixopt 'all-if-over-limit)
|
||||
(> (send partition count) limit))
|
||||
(call-with-values (lambda () (table stx partition #f 'always))
|
||||
escape))
|
||||
(let ([lp-datum (make-identifier-proxy obj)])
|
||||
(hash-table-put! flat=>stx lp-datum obj)
|
||||
(hash-table-put! stx=>flat obj lp-datum)
|
||||
lp-datum)]
|
||||
[(and (syntax? obj) (check+convert-special-expression obj))
|
||||
=> (lambda (newobj)
|
||||
(when partition (send partition get-partition obj))
|
||||
(let* ([inner (cadr newobj)]
|
||||
[lp-inner-datum (loop inner)]
|
||||
[lp-datum (list (car newobj) lp-inner-datum)])
|
||||
(hash-table-put! flat=>stx lp-inner-datum inner)
|
||||
(hash-table-put! stx=>flat inner lp-inner-datum)
|
||||
(hash-table-put! flat=>stx lp-datum obj)
|
||||
(hash-table-put! stx=>flat obj lp-datum)
|
||||
lp-datum))]
|
||||
[(syntax? obj)
|
||||
(when partition (send partition get-partition obj))
|
||||
(let ([lp-datum (loop (syntax-e obj))])
|
||||
(hash-table-put! flat=>stx lp-datum obj)
|
||||
(hash-table-put! stx=>flat obj lp-datum)
|
||||
lp-datum)]
|
||||
[(pair? obj)
|
||||
(pairloop obj)]
|
||||
[(symbol? obj)
|
||||
(unintern obj)]
|
||||
[(null? obj)
|
||||
(make-syntax-dummy obj)]
|
||||
[(boolean? obj)
|
||||
(make-syntax-dummy obj)]
|
||||
[(number? obj)
|
||||
(make-syntax-dummy obj)]
|
||||
[(keyword? obj)
|
||||
(make-syntax-dummy obj)]
|
||||
[(vector? obj)
|
||||
(list->vector (map loop (vector->list obj)))]
|
||||
[(box? obj)
|
||||
(box (loop (unbox obj)))]
|
||||
[else obj]))
|
||||
(define (pairloop obj)
|
||||
(cond [(pair? obj)
|
||||
(cons (loop (car obj))
|
||||
(pairloop (cdr obj)))]
|
||||
[(null? obj)
|
||||
null]
|
||||
[(and (syntax? obj) (null? (syntax-e obj)))
|
||||
null]
|
||||
[else (loop obj)]))
|
||||
(values (loop stx)
|
||||
flat=>stx
|
||||
stx=>flat))))
|
||||
|
||||
;; check+convert-special-expression : syntax -> #f/syntaxish
|
||||
(define (check+convert-special-expression stx)
|
||||
(define stx-list (stx->list stx))
|
||||
(and stx-list (= 2 (length stx-list))
|
||||
(let ([kw (car stx-list)]
|
||||
[expr (cadr stx-list)])
|
||||
(and (identifier? kw)
|
||||
(memq (syntax-e kw) special-expression-keywords)
|
||||
(bound-identifier=? kw (datum->syntax-object stx (syntax-e kw)))
|
||||
(andmap (lambda (f) (equal? (f stx) (f kw)))
|
||||
(list syntax-source
|
||||
syntax-line
|
||||
syntax-column
|
||||
syntax-position
|
||||
syntax-original?
|
||||
syntax-source-module))
|
||||
(cons (syntax-e kw)
|
||||
(list expr))))))
|
||||
;; check+convert-special-expression : syntax -> #f/syntaxish
|
||||
(define (check+convert-special-expression stx)
|
||||
(define stx-list (stx->list stx))
|
||||
(and stx-list (= 2 (length stx-list))
|
||||
(let ([kw (car stx-list)]
|
||||
[expr (cadr stx-list)])
|
||||
(and (identifier? kw)
|
||||
(memq (syntax-e kw) special-expression-keywords)
|
||||
(bound-identifier=? kw (datum->syntax stx (syntax-e kw)))
|
||||
(andmap (lambda (f) (equal? (f stx) (f kw)))
|
||||
(list syntax-source
|
||||
syntax-line
|
||||
syntax-column
|
||||
syntax-position
|
||||
syntax-original?
|
||||
syntax-source-module))
|
||||
(cons (syntax-e kw)
|
||||
(list expr))))))
|
||||
|
||||
(define special-expression-keywords
|
||||
'(quote quasiquote unquote unquote-splicing syntax))
|
||||
;; FIXME: quasisyntax unsyntax unsyntax-splicing
|
||||
(define special-expression-keywords
|
||||
'(quote quasiquote unquote unquote-splicing syntax))
|
||||
;; FIXME: quasisyntax unsyntax unsyntax-splicing
|
||||
|
||||
(define (unintern sym)
|
||||
(string->uninterned-symbol (symbol->string sym)))
|
||||
(define (unintern sym)
|
||||
(string->uninterned-symbol (symbol->string sym)))
|
||||
|
||||
(define (suffix sym n)
|
||||
(string->uninterned-symbol (format "~a:~a" sym n)))
|
||||
|
||||
)
|
||||
(define (suffix sym n)
|
||||
(string->uninterned-symbol (format "~a:~a" sym n)))
|
||||
|
|
|
|||
|
|
@ -1,161 +1,160 @@
|
|||
|
||||
;; FIXME: Need to disable printing of structs with custom-write property
|
||||
|
||||
(module pretty-printer mzscheme
|
||||
(require (lib "list.ss")
|
||||
(lib "class.ss")
|
||||
(lib "pretty.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
"pretty-helper.ss"
|
||||
"interfaces.ss"
|
||||
"params.ss"
|
||||
"prefs.ss")
|
||||
#lang scheme/base
|
||||
(require scheme/list
|
||||
scheme/class
|
||||
scheme/pretty
|
||||
scheme/gui
|
||||
"pretty-helper.ss"
|
||||
"interfaces.ss"
|
||||
"params.ss"
|
||||
"prefs.ss")
|
||||
|
||||
(provide pretty-print-syntax)
|
||||
(provide pretty-print-syntax)
|
||||
|
||||
;; pretty-print-syntax : syntax port partition -> range%
|
||||
(define (pretty-print-syntax stx port primary-partition)
|
||||
(define range-builder (new range-builder%))
|
||||
(define-values (datum ht:flat=>stx ht:stx=>flat)
|
||||
(syntax->datum/tables stx primary-partition
|
||||
(length (current-colors))
|
||||
(current-suffix-option)))
|
||||
(define identifier-list
|
||||
(filter identifier? (hash-table-map ht:stx=>flat (lambda (k v) k))))
|
||||
(define (flat=>stx obj)
|
||||
(hash-table-get ht:flat=>stx obj #f))
|
||||
(define (stx=>flat stx)
|
||||
(hash-table-get ht:stx=>flat stx))
|
||||
(define (current-position)
|
||||
(let-values ([(line column position) (port-next-location port)])
|
||||
(sub1 position)))
|
||||
(define (pp-pre-hook obj port)
|
||||
(send range-builder set-start obj (current-position)))
|
||||
(define (pp-post-hook obj port)
|
||||
(let ([start (send range-builder get-start obj)]
|
||||
[end (current-position)]
|
||||
[stx (flat=>stx obj)])
|
||||
(when (and start stx)
|
||||
(send range-builder add-range stx (cons start end)))))
|
||||
(define (pp-extend-style-table identifier-list)
|
||||
(let* ([syms (map (lambda (x) (stx=>flat x)) identifier-list)]
|
||||
[like-syms (map syntax-e identifier-list)])
|
||||
(pretty-print-extend-style-table (pp-better-style-table)
|
||||
syms
|
||||
like-syms)))
|
||||
;; pretty-print-syntax : syntax port partition -> range%
|
||||
(define (pretty-print-syntax stx port primary-partition)
|
||||
(define range-builder (new range-builder%))
|
||||
(define-values (datum ht:flat=>stx ht:stx=>flat)
|
||||
(syntax->datum/tables stx primary-partition
|
||||
(length (current-colors))
|
||||
(current-suffix-option)))
|
||||
(define identifier-list
|
||||
(filter identifier? (hash-table-map ht:stx=>flat (lambda (k v) k))))
|
||||
(define (flat=>stx obj)
|
||||
(hash-table-get ht:flat=>stx obj #f))
|
||||
(define (stx=>flat stx)
|
||||
(hash-table-get ht:stx=>flat stx))
|
||||
(define (current-position)
|
||||
(let-values ([(line column position) (port-next-location port)])
|
||||
(sub1 position)))
|
||||
(define (pp-pre-hook obj port)
|
||||
(send range-builder set-start obj (current-position)))
|
||||
(define (pp-post-hook obj port)
|
||||
(let ([start (send range-builder get-start obj)]
|
||||
[end (current-position)]
|
||||
[stx (flat=>stx obj)])
|
||||
(when (and start stx)
|
||||
(send range-builder add-range stx (cons start end)))))
|
||||
(define (pp-extend-style-table identifier-list)
|
||||
(let* ([syms (map (lambda (x) (stx=>flat x)) identifier-list)]
|
||||
[like-syms (map syntax-e identifier-list)])
|
||||
(pretty-print-extend-style-table (pp-better-style-table)
|
||||
syms
|
||||
like-syms)))
|
||||
|
||||
|
||||
(unless (syntax? stx)
|
||||
(raise-type-error 'pretty-print-syntax "syntax" stx))
|
||||
(parameterize
|
||||
([pretty-print-pre-print-hook pp-pre-hook]
|
||||
[pretty-print-post-print-hook pp-post-hook]
|
||||
[pretty-print-size-hook pp-size-hook]
|
||||
[pretty-print-print-hook pp-print-hook]
|
||||
[pretty-print-current-style-table (pp-extend-style-table identifier-list)]
|
||||
[pretty-print-columns (current-default-columns)]
|
||||
;; Printing parameters (mzscheme manual 7.9.1.4)
|
||||
[print-unreadable #t]
|
||||
[print-graph #f]
|
||||
[print-struct #f]
|
||||
[print-box #t]
|
||||
[print-vector-length #t]
|
||||
[print-hash-table #f]
|
||||
[print-honu #f])
|
||||
(pretty-print datum port)
|
||||
(new range%
|
||||
(range-builder range-builder)
|
||||
(identifier-list identifier-list))))
|
||||
(unless (syntax? stx)
|
||||
(raise-type-error 'pretty-print-syntax "syntax" stx))
|
||||
(parameterize
|
||||
([pretty-print-pre-print-hook pp-pre-hook]
|
||||
[pretty-print-post-print-hook pp-post-hook]
|
||||
[pretty-print-size-hook pp-size-hook]
|
||||
[pretty-print-print-hook pp-print-hook]
|
||||
[pretty-print-current-style-table (pp-extend-style-table identifier-list)]
|
||||
[pretty-print-columns (current-default-columns)]
|
||||
;; Printing parameters (mzscheme manual 7.9.1.4)
|
||||
[print-unreadable #t]
|
||||
[print-graph #f]
|
||||
[print-struct #f]
|
||||
[print-box #t]
|
||||
[print-vector-length #t]
|
||||
[print-hash-table #f]
|
||||
[print-honu #f])
|
||||
(pretty-print datum port)
|
||||
(new range%
|
||||
(range-builder range-builder)
|
||||
(identifier-list identifier-list))))
|
||||
|
||||
(define (pp-print-hook obj display-like? port)
|
||||
(cond [(syntax-dummy? obj)
|
||||
((if display-like? display write) (syntax-dummy-val obj) port)]
|
||||
[(is-a? obj editor-snip%)
|
||||
(write-special obj port)]
|
||||
[else
|
||||
(error 'pretty-print-hook "unexpected special value: ~e" obj)]))
|
||||
(define (pp-print-hook obj display-like? port)
|
||||
(cond [(syntax-dummy? obj)
|
||||
((if display-like? display write) (syntax-dummy-val obj) port)]
|
||||
[(is-a? obj editor-snip%)
|
||||
(write-special obj port)]
|
||||
[else
|
||||
(error 'pretty-print-hook "unexpected special value: ~e" obj)]))
|
||||
|
||||
(define (pp-size-hook obj display-like? port)
|
||||
(cond [(is-a? obj editor-snip%)
|
||||
(pretty-print-columns)]
|
||||
[(syntax-dummy? obj)
|
||||
(let ((ostring (open-output-string)))
|
||||
((if display-like? display write) (syntax-dummy-val obj) ostring)
|
||||
(string-length (get-output-string ostring)))]
|
||||
[else #f]))
|
||||
(define (pp-size-hook obj display-like? port)
|
||||
(cond [(is-a? obj editor-snip%)
|
||||
(pretty-print-columns)]
|
||||
[(syntax-dummy? obj)
|
||||
(let ((ostring (open-output-string)))
|
||||
((if display-like? display write) (syntax-dummy-val obj) ostring)
|
||||
(string-length (get-output-string ostring)))]
|
||||
[else #f]))
|
||||
|
||||
(define (pp-better-style-table)
|
||||
(let* ([pref (pref:tabify)]
|
||||
[table (car pref)]
|
||||
[begin-rx (cadr pref)]
|
||||
[define-rx (caddr pref)]
|
||||
[lambda-rx (cadddr pref)])
|
||||
(let ([style-list (hash-table-map table cons)])
|
||||
(pretty-print-extend-style-table
|
||||
(basic-style-list)
|
||||
(map car style-list)
|
||||
(map cdr style-list)))))
|
||||
(define (pp-better-style-table)
|
||||
(let* ([pref (pref:tabify)]
|
||||
[table (car pref)]
|
||||
[begin-rx (cadr pref)]
|
||||
[define-rx (caddr pref)]
|
||||
[lambda-rx (cadddr pref)])
|
||||
(let ([style-list (hash-table-map table cons)])
|
||||
(pretty-print-extend-style-table
|
||||
(basic-style-list)
|
||||
(map car style-list)
|
||||
(map cdr style-list)))))
|
||||
|
||||
(define (basic-style-list)
|
||||
(pretty-print-extend-style-table
|
||||
(pretty-print-current-style-table)
|
||||
(map car basic-styles)
|
||||
(map cdr basic-styles)))
|
||||
(define basic-styles
|
||||
'((define-values . define)
|
||||
(define-syntaxes . define-syntax)))
|
||||
(define (basic-style-list)
|
||||
(pretty-print-extend-style-table
|
||||
(pretty-print-current-style-table)
|
||||
(map car basic-styles)
|
||||
(map cdr basic-styles)))
|
||||
(define basic-styles
|
||||
'((define-values . define)
|
||||
(define-syntaxes . define-syntax)))
|
||||
|
||||
(define-local-member-name range:get-ranges)
|
||||
(define-local-member-name range:get-ranges)
|
||||
|
||||
;; range-builder%
|
||||
(define range-builder%
|
||||
(class object%
|
||||
(define starts (make-hash-table))
|
||||
(define ranges (make-hash-table))
|
||||
;; range-builder%
|
||||
(define range-builder%
|
||||
(class object%
|
||||
(define starts (make-hash-table))
|
||||
(define ranges (make-hash-table))
|
||||
|
||||
(define/public (set-start obj n)
|
||||
(hash-table-put! starts obj n))
|
||||
(define/public (set-start obj n)
|
||||
(hash-table-put! starts obj n))
|
||||
|
||||
(define/public (get-start obj)
|
||||
(hash-table-get starts obj (lambda _ #f)))
|
||||
(define/public (get-start obj)
|
||||
(hash-table-get starts obj (lambda _ #f)))
|
||||
|
||||
(define/public (add-range obj range)
|
||||
(hash-table-put! ranges obj (cons range (get-ranges obj))))
|
||||
(define/public (add-range obj range)
|
||||
(hash-table-put! ranges obj (cons range (get-ranges obj))))
|
||||
|
||||
(define (get-ranges obj)
|
||||
(hash-table-get ranges obj (lambda () null)))
|
||||
(define (get-ranges obj)
|
||||
(hash-table-get ranges obj (lambda () null)))
|
||||
|
||||
(define/public (range:get-ranges) ranges)
|
||||
(define/public (range:get-ranges) ranges)
|
||||
|
||||
(super-new)))
|
||||
(super-new)))
|
||||
|
||||
;; range%
|
||||
(define range%
|
||||
(class* object% (range<%>)
|
||||
(init range-builder)
|
||||
(init-field identifier-list)
|
||||
(super-new)
|
||||
;; range%
|
||||
(define range%
|
||||
(class* object% (range<%>)
|
||||
(init range-builder)
|
||||
(init-field identifier-list)
|
||||
(super-new)
|
||||
|
||||
(define ranges (hash-table-copy (send range-builder range:get-ranges)))
|
||||
(define ranges (hash-table-copy (send range-builder range:get-ranges)))
|
||||
|
||||
(define/public (get-ranges obj)
|
||||
(hash-table-get ranges obj (lambda _ null)))
|
||||
(define/public (get-ranges obj)
|
||||
(hash-table-get ranges obj (lambda _ null)))
|
||||
|
||||
(define/public (all-ranges)
|
||||
sorted-ranges)
|
||||
(define/public (all-ranges)
|
||||
sorted-ranges)
|
||||
|
||||
(define/public (get-identifier-list)
|
||||
identifier-list)
|
||||
(define/public (get-identifier-list)
|
||||
identifier-list)
|
||||
|
||||
(define sorted-ranges
|
||||
(sort
|
||||
(apply append
|
||||
(hash-table-map
|
||||
ranges
|
||||
(lambda (k vs)
|
||||
(map (lambda (v) (make-range k (car v) (cdr v))) vs))))
|
||||
(lambda (x y)
|
||||
(>= (- (range-end x) (range-start x))
|
||||
(- (range-end y) (range-start y))))))))
|
||||
(define sorted-ranges
|
||||
(sort
|
||||
(apply append
|
||||
(hash-table-map
|
||||
ranges
|
||||
(lambda (k vs)
|
||||
(map (lambda (v) (make-range k (car v) (cdr v))) vs))))
|
||||
(lambda (x y)
|
||||
(>= (- (range-end x) (range-start x))
|
||||
(- (range-end y) (range-start y))))))))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,314 +1,311 @@
|
|||
|
||||
(module properties mzscheme
|
||||
(require "interfaces.ss"
|
||||
"util.ss"
|
||||
(lib "class.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
#;(lib "framework.ss" "framework")
|
||||
#;(lib "interactive-value-port.ss" "mrlib"))
|
||||
(provide properties-view%
|
||||
properties-snip%)
|
||||
#lang scheme/base
|
||||
(require scheme/class
|
||||
scheme/gui
|
||||
"interfaces.ss"
|
||||
"util.ss")
|
||||
(provide properties-view%
|
||||
properties-snip%)
|
||||
|
||||
;; properties-view-base-mixin
|
||||
(define properties-view-base-mixin
|
||||
(mixin () ()
|
||||
;; controller : controller<%>
|
||||
(init-field controller)
|
||||
;; properties-view-base-mixin
|
||||
(define properties-view-base-mixin
|
||||
(mixin () ()
|
||||
;; controller : controller<%>
|
||||
(init-field controller)
|
||||
|
||||
;; selected-syntax : syntax
|
||||
(field (selected-syntax #f))
|
||||
;; selected-syntax : syntax
|
||||
(field (selected-syntax #f))
|
||||
|
||||
;; mode : maybe symbol in '(term stxobj)
|
||||
(define mode 'term)
|
||||
;; mode : maybe symbol in '(term stxobj)
|
||||
(define mode 'term)
|
||||
|
||||
;; text : text%
|
||||
(field (text (new text%)))
|
||||
(field (pdisplayer (new properties-displayer% (text text))))
|
||||
;; text : text%
|
||||
(field (text (new text%)))
|
||||
(field (pdisplayer (new properties-displayer% (text text))))
|
||||
|
||||
(send controller listen-selected-syntax
|
||||
(lambda (stx)
|
||||
(set! selected-syntax stx)
|
||||
(refresh)))
|
||||
(super-new)
|
||||
(send controller listen-selected-syntax
|
||||
(lambda (stx)
|
||||
(set! selected-syntax stx)
|
||||
(refresh)))
|
||||
(super-new)
|
||||
|
||||
;; get-mode : -> symbol
|
||||
(define/public (get-mode) mode)
|
||||
;; get-mode : -> symbol
|
||||
(define/public (get-mode) mode)
|
||||
|
||||
;; set-mode : symbol -> void
|
||||
(define/public (set-mode m)
|
||||
(set! mode m)
|
||||
(refresh))
|
||||
;; set-mode : symbol -> void
|
||||
(define/public (set-mode m)
|
||||
(set! mode m)
|
||||
(refresh))
|
||||
|
||||
;; refresh : -> void
|
||||
(define/public (refresh)
|
||||
(send* text
|
||||
(lock #f)
|
||||
(begin-edit-sequence)
|
||||
(erase))
|
||||
(if (syntax? selected-syntax)
|
||||
(refresh/mode mode)
|
||||
(refresh/mode #f))
|
||||
(send* text
|
||||
(end-edit-sequence)
|
||||
(lock #t)
|
||||
(scroll-to-position 0)))
|
||||
;; refresh : -> void
|
||||
(define/public (refresh)
|
||||
(send* text
|
||||
(lock #f)
|
||||
(begin-edit-sequence)
|
||||
(erase))
|
||||
(if (syntax? selected-syntax)
|
||||
(refresh/mode mode)
|
||||
(refresh/mode #f))
|
||||
(send* text
|
||||
(end-edit-sequence)
|
||||
(lock #t)
|
||||
(scroll-to-position 0)))
|
||||
|
||||
;; refresh/mode : symbol -> void
|
||||
(define/public (refresh/mode mode)
|
||||
(case mode
|
||||
((term) (send pdisplayer display-meaning-info selected-syntax))
|
||||
((stxobj) (send pdisplayer display-stxobj-info selected-syntax))
|
||||
((#f) (send pdisplayer display-null-info))
|
||||
(else (error 'properties-view-base:refresh
|
||||
"internal error: no such mode: ~s" mode))))
|
||||
;; refresh/mode : symbol -> void
|
||||
(define/public (refresh/mode mode)
|
||||
(case mode
|
||||
((term) (send pdisplayer display-meaning-info selected-syntax))
|
||||
((stxobj) (send pdisplayer display-stxobj-info selected-syntax))
|
||||
((#f) (send pdisplayer display-null-info))
|
||||
(else (error 'properties-view-base:refresh
|
||||
"internal error: no such mode: ~s" mode))))
|
||||
|
||||
(send text set-styles-sticky #f)
|
||||
#;(send text hide-caret #t)
|
||||
(send text lock #t)
|
||||
(refresh)))
|
||||
(send text set-styles-sticky #f)
|
||||
#;(send text hide-caret #t)
|
||||
(send text lock #t)
|
||||
(refresh)))
|
||||
|
||||
|
||||
;; properties-snip%
|
||||
(define properties-snip%
|
||||
(class (properties-view-base-mixin editor-snip%)
|
||||
(inherit-field text)
|
||||
(inherit-field pdisplayer)
|
||||
(inherit set-mode)
|
||||
;; properties-snip%
|
||||
(define properties-snip%
|
||||
(class (properties-view-base-mixin editor-snip%)
|
||||
(inherit-field text)
|
||||
(inherit-field pdisplayer)
|
||||
(inherit set-mode)
|
||||
|
||||
(define/private outer:insert
|
||||
(case-lambda
|
||||
[(obj)
|
||||
(outer:insert obj style:normal)]
|
||||
[(text style)
|
||||
(outer:insert text style #f)]
|
||||
[(text style clickback)
|
||||
(let ([start (send outer-text last-position)])
|
||||
(send outer-text insert text)
|
||||
(let ([end (send outer-text last-position)])
|
||||
(send outer-text change-style style start end #f)
|
||||
(when clickback
|
||||
(send outer-text set-clickback start end clickback))))]))
|
||||
(define/private outer:insert
|
||||
(case-lambda
|
||||
[(obj)
|
||||
(outer:insert obj style:normal)]
|
||||
[(text style)
|
||||
(outer:insert text style #f)]
|
||||
[(text style clickback)
|
||||
(let ([start (send outer-text last-position)])
|
||||
(send outer-text insert text)
|
||||
(let ([end (send outer-text last-position)])
|
||||
(send outer-text change-style style start end #f)
|
||||
(when clickback
|
||||
(send outer-text set-clickback start end clickback))))]))
|
||||
|
||||
(define outer-text (new text%))
|
||||
(super-new (editor outer-text))
|
||||
(outer:insert "Term" style:hyper (lambda _ (set-mode 'term)))
|
||||
(outer:insert " ")
|
||||
(outer:insert "Syntax Object" style:hyper (lambda _ (set-mode 'stxobj)))
|
||||
(outer:insert "\n")
|
||||
(outer:insert (new editor-snip% (editor text)))
|
||||
(send outer-text hide-caret #t)
|
||||
(send outer-text lock #t)))
|
||||
(define outer-text (new text%))
|
||||
(super-new (editor outer-text))
|
||||
(outer:insert "Term" style:hyper (lambda _ (set-mode 'term)))
|
||||
(outer:insert " ")
|
||||
(outer:insert "Syntax Object" style:hyper (lambda _ (set-mode 'stxobj)))
|
||||
(outer:insert "\n")
|
||||
(outer:insert (new editor-snip% (editor text)))
|
||||
(send outer-text hide-caret #t)
|
||||
(send outer-text lock #t)))
|
||||
|
||||
;; properties-view%
|
||||
(define properties-view%
|
||||
(class* (properties-view-base-mixin object%) ()
|
||||
(init parent)
|
||||
(inherit-field text)
|
||||
(inherit-field pdisplayer)
|
||||
(inherit set-mode)
|
||||
;; properties-view%
|
||||
(define properties-view%
|
||||
(class* (properties-view-base-mixin object%) ()
|
||||
(init parent)
|
||||
(inherit-field text)
|
||||
(inherit-field pdisplayer)
|
||||
(inherit set-mode)
|
||||
|
||||
;; get-tab-choices : (listof (cons string thunk))
|
||||
;; Override to add or remove panels
|
||||
(define/public (get-tab-choices)
|
||||
(list (cons "Term" 'term)
|
||||
(cons "Syntax Object" 'stxobj)))
|
||||
;; get-tab-choices : (listof (cons string thunk))
|
||||
;; Override to add or remove panels
|
||||
(define/public (get-tab-choices)
|
||||
(list (cons "Term" 'term)
|
||||
(cons "Syntax Object" 'stxobj)))
|
||||
|
||||
(super-new)
|
||||
(define tab-choices (get-tab-choices))
|
||||
(define tab-panel
|
||||
(new tab-panel%
|
||||
(choices (map car tab-choices))
|
||||
(parent parent)
|
||||
(callback
|
||||
(lambda (tp e)
|
||||
(set-mode (cdr (list-ref tab-choices (send tp get-selection))))))))
|
||||
(define ecanvas (new editor-canvas% (editor text) (parent tab-panel)))))
|
||||
(super-new)
|
||||
(define tab-choices (get-tab-choices))
|
||||
(define tab-panel
|
||||
(new tab-panel%
|
||||
(choices (map car tab-choices))
|
||||
(parent parent)
|
||||
(callback
|
||||
(lambda (tp e)
|
||||
(set-mode (cdr (list-ref tab-choices (send tp get-selection))))))))
|
||||
(define ecanvas (new editor-canvas% (editor text) (parent tab-panel)))))
|
||||
|
||||
;; properties-displayer%
|
||||
(define properties-displayer%
|
||||
(class* object% ()
|
||||
(init-field text)
|
||||
;; properties-displayer%
|
||||
(define properties-displayer%
|
||||
(class* object% ()
|
||||
(init-field text)
|
||||
|
||||
;; display-null-info : -> void
|
||||
(define/public (display-null-info)
|
||||
(display "No syntax selected\n" n/a-sd))
|
||||
;; display-null-info : -> void
|
||||
(define/public (display-null-info)
|
||||
(display "No syntax selected\n" n/a-sd))
|
||||
|
||||
;; display-meaning-info : syntax -> void
|
||||
(define/public (display-meaning-info stx)
|
||||
(when (and (identifier? stx)
|
||||
(uninterned? (syntax-e stx)))
|
||||
(display "Uninterned symbol!\n\n" key-sd))
|
||||
(display-binding-info stx)
|
||||
(display-indirect-binding-info stx))
|
||||
;; display-meaning-info : syntax -> void
|
||||
(define/public (display-meaning-info stx)
|
||||
(when (and (identifier? stx)
|
||||
(uninterned? (syntax-e stx)))
|
||||
(display "Uninterned symbol!\n\n" key-sd))
|
||||
(display-binding-info stx)
|
||||
(display-indirect-binding-info stx))
|
||||
|
||||
;; display-binding-info : syntax -> void
|
||||
(define/private (display-binding-info stx)
|
||||
(display "Apparent identifier binding\n" key-sd)
|
||||
(display-bindings stx))
|
||||
;; display-binding-info : syntax -> void
|
||||
(define/private (display-binding-info stx)
|
||||
(display "Apparent identifier binding\n" key-sd)
|
||||
(display-bindings stx))
|
||||
|
||||
;; display-indirect-binding-info : syntax -> void
|
||||
(define/private (display-indirect-binding-info stx)
|
||||
(cond
|
||||
[(identifier? stx)
|
||||
(display "Binding if used for #%top\n" key-sd)
|
||||
(display-bindings (datum->syntax-object stx '#%top))]
|
||||
[(and (syntax? stx) (pair? (syntax-e stx)))
|
||||
(display "Binding if used for #%app\n" key-sd)
|
||||
(display-bindings (datum->syntax-object stx '#%app))]
|
||||
[else
|
||||
(display "Binding if used for #%datum\n" key-sd)
|
||||
(display-bindings (datum->syntax-object stx '#%datum))]))
|
||||
;; display-indirect-binding-info : syntax -> void
|
||||
(define/private (display-indirect-binding-info stx)
|
||||
(cond
|
||||
[(identifier? stx)
|
||||
(display "Binding if used for #%top\n" key-sd)
|
||||
(display-bindings (datum->syntax stx '#%top))]
|
||||
[(and (syntax? stx) (pair? (syntax-e stx)))
|
||||
(display "Binding if used for #%app\n" key-sd)
|
||||
(display-bindings (datum->syntax stx '#%app))]
|
||||
[else
|
||||
(display "Binding if used for #%datum\n" key-sd)
|
||||
(display-bindings (datum->syntax stx '#%datum))]))
|
||||
|
||||
;; display-bindings : syntax -> void
|
||||
(define/private (display-bindings stx)
|
||||
(unless (identifier? stx)
|
||||
(display "Not applicable\n\n" n/a-sd))
|
||||
(when (identifier? stx)
|
||||
(if (eq? (identifier-binding stx) 'lexical)
|
||||
(display "lexical (all phases)\n" #f)
|
||||
(for-each (lambda (p) (display-binding-kvs (car p) ((cdr p) stx)))
|
||||
binding-properties))
|
||||
(display "\n" #f)))
|
||||
;; display-bindings : syntax -> void
|
||||
(define/private (display-bindings stx)
|
||||
(unless (identifier? stx)
|
||||
(display "Not applicable\n\n" n/a-sd))
|
||||
(when (identifier? stx)
|
||||
(if (eq? (identifier-binding stx) 'lexical)
|
||||
(display "lexical (all phases)\n" #f)
|
||||
(for-each (lambda (p) (display-binding-kvs (car p) ((cdr p) stx)))
|
||||
binding-properties))
|
||||
(display "\n" #f)))
|
||||
|
||||
;; display-binding-kvs : string bindinginfo -> void
|
||||
(define/private (display-binding-kvs k v)
|
||||
(display k sub-key-sd)
|
||||
(display "\n" #f)
|
||||
(cond [(eq? v #f)
|
||||
(display " top-level or unbound\n" #f)]
|
||||
[(list? v)
|
||||
(display-subkv " defined in" (mpi->string (list-ref v 0)))
|
||||
(display-subkv " as" (list-ref v 1))
|
||||
(display-subkv " imported from" (mpi->string (list-ref v 2)))
|
||||
(display-subkv " as" (list-ref v 3))
|
||||
(if (list-ref v 4)
|
||||
(display " via define-for-syntax" sub-key-sd))]))
|
||||
;; display-binding-kvs : string bindinginfo -> void
|
||||
(define/private (display-binding-kvs k v)
|
||||
(display k sub-key-sd)
|
||||
(display "\n" #f)
|
||||
(cond [(eq? v #f)
|
||||
(display " top-level or unbound\n" #f)]
|
||||
[(list? v)
|
||||
(display-subkv " defined in" (mpi->string (list-ref v 0)))
|
||||
(display-subkv " as" (list-ref v 1))
|
||||
(display-subkv " imported from" (mpi->string (list-ref v 2)))
|
||||
(display-subkv " as" (list-ref v 3))
|
||||
(when (list-ref v 4)
|
||||
(display " via define-for-syntax" sub-key-sd))]))
|
||||
|
||||
;; display-stxobj-info : syntax -> void
|
||||
(define/public (display-stxobj-info stx)
|
||||
(display-source-info stx)
|
||||
(display-extra-source-info stx)
|
||||
(display-symbol-property-info stx))
|
||||
;; display-stxobj-info : syntax -> void
|
||||
(define/public (display-stxobj-info stx)
|
||||
(display-source-info stx)
|
||||
(display-extra-source-info stx)
|
||||
(display-symbol-property-info stx))
|
||||
|
||||
;; display-source-info : syntax -> void
|
||||
(define/private (display-source-info stx)
|
||||
(define s-source (syntax-source stx))
|
||||
(define s-line (syntax-line stx))
|
||||
(define s-column (syntax-column stx))
|
||||
(define s-position (syntax-position stx))
|
||||
(define s-span0 (syntax-span stx))
|
||||
(define s-span (if (zero? s-span0) #f s-span0))
|
||||
(display "Source location\n" key-sd)
|
||||
(if (or s-source s-line s-column s-position s-span)
|
||||
(begin
|
||||
(display-subkv "source" (prettify-source s-source))
|
||||
(display-subkv "line" s-line)
|
||||
(display-subkv "column" s-column)
|
||||
(display-subkv "position" s-position)
|
||||
(display-subkv "span" s-span0))
|
||||
(display "No source location available\n" n/a-sd))
|
||||
(display "\n" #f))
|
||||
;; display-source-info : syntax -> void
|
||||
(define/private (display-source-info stx)
|
||||
(define s-source (syntax-source stx))
|
||||
(define s-line (syntax-line stx))
|
||||
(define s-column (syntax-column stx))
|
||||
(define s-position (syntax-position stx))
|
||||
(define s-span0 (syntax-span stx))
|
||||
(define s-span (if (zero? s-span0) #f s-span0))
|
||||
(display "Source location\n" key-sd)
|
||||
(if (or s-source s-line s-column s-position s-span)
|
||||
(begin
|
||||
(display-subkv "source" (prettify-source s-source))
|
||||
(display-subkv "line" s-line)
|
||||
(display-subkv "column" s-column)
|
||||
(display-subkv "position" s-position)
|
||||
(display-subkv "span" s-span0))
|
||||
(display "No source location available\n" n/a-sd))
|
||||
(display "\n" #f))
|
||||
|
||||
;; display-extra-source-info : syntax -> void
|
||||
(define/private (display-extra-source-info stx)
|
||||
(display "Built-in properties\n" key-sd)
|
||||
(display-subkv "source module"
|
||||
(let ([mod (syntax-source-module stx)])
|
||||
(and mod (mpi->string mod))))
|
||||
(display-subkv "original?" (syntax-original? stx))
|
||||
(display "\n" #f))
|
||||
;; display-extra-source-info : syntax -> void
|
||||
(define/private (display-extra-source-info stx)
|
||||
(display "Built-in properties\n" key-sd)
|
||||
(display-subkv "source module"
|
||||
(let ([mod (syntax-source-module stx)])
|
||||
(and mod (mpi->string mod))))
|
||||
(display-subkv "original?" (syntax-original? stx))
|
||||
(display "\n" #f))
|
||||
|
||||
;; display-symbol-property-info : syntax -> void
|
||||
(define/private (display-symbol-property-info stx)
|
||||
(let ([keys (syntax-property-symbol-keys stx)])
|
||||
(display "Additional properties\n" key-sd)
|
||||
(when (null? keys)
|
||||
(display "No additional properties available.\n" n/a-sd))
|
||||
(when (pair? keys)
|
||||
(for-each (lambda (k) (display-subkv/value k (syntax-property stx k)))
|
||||
keys))))
|
||||
;; display-symbol-property-info : syntax -> void
|
||||
(define/private (display-symbol-property-info stx)
|
||||
(let ([keys (syntax-property-symbol-keys stx)])
|
||||
(display "Additional properties\n" key-sd)
|
||||
(when (null? keys)
|
||||
(display "No additional properties available.\n" n/a-sd))
|
||||
(when (pair? keys)
|
||||
(for-each (lambda (k) (display-subkv/value k (syntax-property stx k)))
|
||||
keys))))
|
||||
|
||||
;; display-kv : any any -> void
|
||||
(define/private (display-kv key value)
|
||||
(display (format "~a~n" key) key-sd)
|
||||
(display (format "~s~n~n" value) #f))
|
||||
;; display-kv : any any -> void
|
||||
(define/private (display-kv key value)
|
||||
(display (format "~a~n" key) key-sd)
|
||||
(display (format "~s~n~n" value) #f))
|
||||
|
||||
;; display-subkv : any any -> void
|
||||
(define/public (display-subkv k v)
|
||||
(display (format "~a: " k) sub-key-sd)
|
||||
(display (format "~a~n" v) #f))
|
||||
;; display-subkv : any any -> void
|
||||
(define/public (display-subkv k v)
|
||||
(display (format "~a: " k) sub-key-sd)
|
||||
(display (format "~a~n" v) #f))
|
||||
|
||||
(define/public (display-subkv/value k v)
|
||||
(display-subkv k v)
|
||||
#;
|
||||
(begin
|
||||
(display (format "~a:~n" k) sub-key-sd)
|
||||
(let* ([value-text (new text:standard-style-list% (auto-wrap #t))]
|
||||
[value-snip (new editor-snip% (editor value-text))]
|
||||
[value-port (make-text-port value-text)])
|
||||
(set-interactive-write-handler value-port)
|
||||
(set-interactive-print-handler value-port)
|
||||
(set-interactive-display-handler value-port)
|
||||
(write v value-port)
|
||||
(send value-text lock #t)
|
||||
(send text insert value-snip)
|
||||
(send text insert "\n")
|
||||
#;(send ecanvas add-wide-snip value-snip))))
|
||||
(define/public (display-subkv/value k v)
|
||||
(display-subkv k v)
|
||||
#;
|
||||
(begin
|
||||
(display (format "~a:~n" k) sub-key-sd)
|
||||
(let* ([value-text (new text:standard-style-list% (auto-wrap #t))]
|
||||
[value-snip (new editor-snip% (editor value-text))]
|
||||
[value-port (make-text-port value-text)])
|
||||
(set-interactive-write-handler value-port)
|
||||
(set-interactive-print-handler value-port)
|
||||
(set-interactive-display-handler value-port)
|
||||
(write v value-port)
|
||||
(send value-text lock #t)
|
||||
(send text insert value-snip)
|
||||
(send text insert "\n")
|
||||
#;(send ecanvas add-wide-snip value-snip))))
|
||||
|
||||
;; display : string style-delta -> void
|
||||
(define/private (display item sd)
|
||||
(let ([p0 (send text last-position)])
|
||||
(send text insert item)
|
||||
(let ([p1 (send text last-position)])
|
||||
(send text change-style sd p0 p1))))
|
||||
;; display : string style-delta -> void
|
||||
(define/private (display item sd)
|
||||
(let ([p0 (send text last-position)])
|
||||
(send text insert item)
|
||||
(let ([p1 (send text last-position)])
|
||||
(send text change-style sd p0 p1))))
|
||||
|
||||
(super-new)))
|
||||
(super-new)))
|
||||
|
||||
|
||||
;; lift/id : (identifier -> void) 'a -> void
|
||||
(define (lift/id f)
|
||||
(lambda (stx) (when (identifier? stx) (f stx))))
|
||||
;; lift/id : (identifier -> void) 'a -> void
|
||||
(define (lift/id f)
|
||||
(lambda (stx) (when (identifier? stx) (f stx))))
|
||||
|
||||
;; binding-properties : (listof (cons string (syntax -> any)))
|
||||
(define binding-properties
|
||||
(list (cons "in the standard phase"
|
||||
(lift/id identifier-binding))
|
||||
(cons "in the transformer phase (\"for-syntax\")"
|
||||
(lift/id identifier-transformer-binding))
|
||||
(cons "in the template phase (\"for-template\")"
|
||||
(lift/id identifier-template-binding))))
|
||||
;; binding-properties : (listof (cons string (syntax -> any)))
|
||||
(define binding-properties
|
||||
(list (cons "in the standard phase"
|
||||
(lift/id identifier-binding))
|
||||
(cons "in the transformer phase (\"for-syntax\")"
|
||||
(lift/id identifier-transformer-binding))
|
||||
(cons "in the template phase (\"for-template\")"
|
||||
(lift/id identifier-template-binding))))
|
||||
|
||||
(define (uninterned? s)
|
||||
(not (eq? s (string->symbol (symbol->string s)))))
|
||||
(define (uninterned? s)
|
||||
(not (eq? s (string->symbol (symbol->string s)))))
|
||||
|
||||
(define (prettify-source s)
|
||||
(cond [(is-a? s editor<%>)
|
||||
'editor]
|
||||
[else s]))
|
||||
(define (prettify-source s)
|
||||
(cond [(is-a? s editor<%>)
|
||||
'editor]
|
||||
[else s]))
|
||||
|
||||
;; Styles
|
||||
|
||||
;; Styles
|
||||
|
||||
(define key-sd
|
||||
(let ([sd (new style-delta%)])
|
||||
(send sd set-delta-foreground "blue")
|
||||
(send sd set-weight-on 'bold)
|
||||
sd))
|
||||
(define key-sd
|
||||
(let ([sd (new style-delta%)])
|
||||
(send sd set-delta-foreground "blue")
|
||||
(send sd set-weight-on 'bold)
|
||||
sd))
|
||||
|
||||
(define sub-key-sd
|
||||
(let ([sd (new style-delta%)])
|
||||
(send sd set-delta-foreground "blue")
|
||||
sd))
|
||||
|
||||
(define n/a-sd
|
||||
(let ([sd (new style-delta%)])
|
||||
(send sd set-delta-foreground "gray")
|
||||
sd))
|
||||
(define sub-key-sd
|
||||
(let ([sd (new style-delta%)])
|
||||
(send sd set-delta-foreground "blue")
|
||||
sd))
|
||||
|
||||
(define style:normal (make-object style-delta% 'change-normal))
|
||||
(define n/a-sd
|
||||
(let ([sd (new style-delta%)])
|
||||
(send sd set-delta-foreground "gray")
|
||||
sd))
|
||||
|
||||
(define style:hyper
|
||||
(let ([s (make-object style-delta% 'change-normal)])
|
||||
(send s set-delta 'change-toggle-underline)
|
||||
(send s set-delta-foreground "blue")
|
||||
s))
|
||||
)
|
||||
(define style:normal (make-object style-delta% 'change-normal))
|
||||
|
||||
(define style:hyper
|
||||
(let ([s (make-object style-delta% 'change-normal)])
|
||||
(send s set-delta 'change-toggle-underline)
|
||||
(send s set-delta-foreground "blue")
|
||||
s))
|
||||
|
|
|
|||
|
|
@ -1,324 +1,323 @@
|
|||
|
||||
(module text mzscheme
|
||||
(require (lib "list.ss")
|
||||
(lib "class.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "arrow.ss" "drscheme")
|
||||
(lib "framework.ss" "framework")
|
||||
"../util/notify.ss")
|
||||
#lang scheme/base
|
||||
(require scheme/list
|
||||
scheme/class
|
||||
scheme/gui
|
||||
drscheme/arrow
|
||||
framework/framework
|
||||
"../util/notify.ss")
|
||||
|
||||
(provide text:hover<%>
|
||||
text:hover-identifier<%>
|
||||
text:mouse-drawings<%>
|
||||
text:arrows<%>
|
||||
(provide text:hover<%>
|
||||
text:hover-identifier<%>
|
||||
text:mouse-drawings<%>
|
||||
text:arrows<%>
|
||||
|
||||
text:hover-mixin
|
||||
text:hover-identifier-mixin
|
||||
text:mouse-drawings-mixin
|
||||
text:tacking-mixin
|
||||
text:arrows-mixin)
|
||||
text:hover-mixin
|
||||
text:hover-identifier-mixin
|
||||
text:mouse-drawings-mixin
|
||||
text:tacking-mixin
|
||||
text:arrows-mixin)
|
||||
|
||||
(define arrow-brush
|
||||
(send the-brush-list find-or-create-brush "white" 'solid))
|
||||
(define (tacked-arrow-brush color)
|
||||
(send the-brush-list find-or-create-brush color 'solid))
|
||||
(define arrow-brush
|
||||
(send the-brush-list find-or-create-brush "white" 'solid))
|
||||
(define (tacked-arrow-brush color)
|
||||
(send the-brush-list find-or-create-brush color 'solid))
|
||||
|
||||
(define billboard-brush
|
||||
(send the-brush-list find-or-create-brush "white" 'solid))
|
||||
(define billboard-brush
|
||||
(send the-brush-list find-or-create-brush "white" 'solid))
|
||||
|
||||
(define white (send the-color-database find-color "white"))
|
||||
(define white (send the-color-database find-color "white"))
|
||||
|
||||
;; A Drawing is (make-drawing number number (??? -> void) boolean boolean)
|
||||
(define-struct drawing (start end draw visible? tacked?) #f)
|
||||
;; A Drawing is (make-drawing number number (??? -> void) boolean boolean)
|
||||
(define-struct drawing (start end draw visible? tacked?) #:mutable)
|
||||
|
||||
(define-struct idloc (start end id) #f)
|
||||
(define-struct idloc (start end id))
|
||||
|
||||
(define (mean x y)
|
||||
(/ (+ x y) 2))
|
||||
(define (mean x y)
|
||||
(/ (+ x y) 2))
|
||||
|
||||
(define-syntax with-saved-pen&brush
|
||||
(syntax-rules ()
|
||||
[(with-saved-pen&brush dc . body)
|
||||
(save-pen&brush dc (lambda () . body))]))
|
||||
(define-syntax with-saved-pen&brush
|
||||
(syntax-rules ()
|
||||
[(with-saved-pen&brush dc . body)
|
||||
(save-pen&brush dc (lambda () . body))]))
|
||||
|
||||
(define (save-pen&brush dc thunk)
|
||||
(let ([old-pen (send dc get-pen)]
|
||||
[old-brush (send dc get-brush)])
|
||||
(begin0 (thunk)
|
||||
(send dc set-pen old-pen)
|
||||
(send dc set-brush old-brush))))
|
||||
(define (save-pen&brush dc thunk)
|
||||
(let ([old-pen (send dc get-pen)]
|
||||
[old-brush (send dc get-brush)])
|
||||
(begin0 (thunk)
|
||||
(send dc set-pen old-pen)
|
||||
(send dc set-brush old-brush))))
|
||||
|
||||
(define-syntax with-saved-text-config
|
||||
(syntax-rules ()
|
||||
[(with-saved-text-config dc . body)
|
||||
(save-text-config dc (lambda () . body))]))
|
||||
(define-syntax with-saved-text-config
|
||||
(syntax-rules ()
|
||||
[(with-saved-text-config dc . body)
|
||||
(save-text-config dc (lambda () . body))]))
|
||||
|
||||
(define (save-text-config dc thunk)
|
||||
(let ([old-font (send dc get-font)]
|
||||
[old-color (send dc get-text-foreground)]
|
||||
[old-background (send dc get-text-background)]
|
||||
[old-mode (send dc get-text-mode)])
|
||||
(begin0 (thunk)
|
||||
(send dc set-font old-font)
|
||||
(send dc set-text-foreground old-color)
|
||||
(send dc set-text-background old-background)
|
||||
(send dc set-text-mode old-mode))))
|
||||
(define (save-text-config dc thunk)
|
||||
(let ([old-font (send dc get-font)]
|
||||
[old-color (send dc get-text-foreground)]
|
||||
[old-background (send dc get-text-background)]
|
||||
[old-mode (send dc get-text-mode)])
|
||||
(begin0 (thunk)
|
||||
(send dc set-font old-font)
|
||||
(send dc set-text-foreground old-color)
|
||||
(send dc set-text-background old-background)
|
||||
(send dc set-text-mode old-mode))))
|
||||
|
||||
(define text:hover<%>
|
||||
(interface (text:basic<%>)
|
||||
update-hover-position))
|
||||
(define text:hover<%>
|
||||
(interface (text:basic<%>)
|
||||
update-hover-position))
|
||||
|
||||
(define text:hover-identifier<%>
|
||||
(interface ()
|
||||
get-hovered-identifier
|
||||
set-hovered-identifier
|
||||
listen-hovered-identifier))
|
||||
(define text:hover-identifier<%>
|
||||
(interface ()
|
||||
get-hovered-identifier
|
||||
set-hovered-identifier
|
||||
listen-hovered-identifier))
|
||||
|
||||
(define text:mouse-drawings<%>
|
||||
(interface (text:basic<%>)
|
||||
add-mouse-drawing
|
||||
for-each-drawing
|
||||
delete-all-drawings))
|
||||
(define text:mouse-drawings<%>
|
||||
(interface (text:basic<%>)
|
||||
add-mouse-drawing
|
||||
for-each-drawing
|
||||
delete-all-drawings))
|
||||
|
||||
(define text:arrows<%>
|
||||
(interface (text:mouse-drawings<%>)
|
||||
add-arrow
|
||||
add-question-arrow
|
||||
add-billboard))
|
||||
(define text:arrows<%>
|
||||
(interface (text:mouse-drawings<%>)
|
||||
add-arrow
|
||||
add-question-arrow
|
||||
add-billboard))
|
||||
|
||||
(define text:hover-mixin
|
||||
(mixin (text:basic<%>) (text:hover<%>)
|
||||
(inherit dc-location-to-editor-location
|
||||
find-position)
|
||||
(define text:hover-mixin
|
||||
(mixin (text:basic<%>) (text:hover<%>)
|
||||
(inherit dc-location-to-editor-location
|
||||
find-position)
|
||||
|
||||
(define/override (on-default-event ev)
|
||||
(define gx (send ev get-x))
|
||||
(define gy (send ev get-y))
|
||||
(define-values (x y) (dc-location-to-editor-location gx gy))
|
||||
(define pos (find-position x y))
|
||||
(super on-default-event ev)
|
||||
(case (send ev get-event-type)
|
||||
((enter motion leave)
|
||||
(update-hover-position pos))))
|
||||
(define/override (on-default-event ev)
|
||||
(define gx (send ev get-x))
|
||||
(define gy (send ev get-y))
|
||||
(define-values (x y) (dc-location-to-editor-location gx gy))
|
||||
(define pos (find-position x y))
|
||||
(super on-default-event ev)
|
||||
(case (send ev get-event-type)
|
||||
((enter motion leave)
|
||||
(update-hover-position pos))))
|
||||
|
||||
(define/public (update-hover-position pos)
|
||||
(void))
|
||||
(define/public (update-hover-position pos)
|
||||
(void))
|
||||
|
||||
(super-new)))
|
||||
(super-new)))
|
||||
|
||||
(define text:hover-identifier-mixin
|
||||
(mixin (text:hover<%>) (text:hover-identifier<%>)
|
||||
(field/notify hovered-identifier (new notify-box% (value #f)))
|
||||
(define text:hover-identifier-mixin
|
||||
(mixin (text:hover<%>) (text:hover-identifier<%>)
|
||||
(field/notify hovered-identifier (new notify-box% (value #f)))
|
||||
|
||||
(define idlocs null)
|
||||
(define idlocs null)
|
||||
|
||||
(define/public (add-identifier-location start end id)
|
||||
(set! idlocs (cons (make-idloc start end id) idlocs)))
|
||||
(define/public (add-identifier-location start end id)
|
||||
(set! idlocs (cons (make-idloc start end id) idlocs)))
|
||||
|
||||
(define/public (delete-all-identifier-locations)
|
||||
(set! idlocs null)
|
||||
(set-hovered-identifier #f))
|
||||
(define/public (delete-all-identifier-locations)
|
||||
(set! idlocs null)
|
||||
(set-hovered-identifier #f))
|
||||
|
||||
(define/override (update-hover-position pos)
|
||||
(super update-hover-position pos)
|
||||
(let search ([idlocs idlocs])
|
||||
(cond [(null? idlocs) (set-hovered-identifier #f)]
|
||||
[(and (<= (idloc-start (car idlocs)) pos)
|
||||
(< pos (idloc-end (car idlocs))))
|
||||
(set-hovered-identifier (idloc-id (car idlocs)))]
|
||||
[else (search (cdr idlocs))])))
|
||||
(super-new)))
|
||||
(define/override (update-hover-position pos)
|
||||
(super update-hover-position pos)
|
||||
(let search ([idlocs idlocs])
|
||||
(cond [(null? idlocs) (set-hovered-identifier #f)]
|
||||
[(and (<= (idloc-start (car idlocs)) pos)
|
||||
(< pos (idloc-end (car idlocs))))
|
||||
(set-hovered-identifier (idloc-id (car idlocs)))]
|
||||
[else (search (cdr idlocs))])))
|
||||
(super-new)))
|
||||
|
||||
(define text:mouse-drawings-mixin
|
||||
(mixin (text:hover<%>) (text:mouse-drawings<%>)
|
||||
(inherit dc-location-to-editor-location
|
||||
find-position
|
||||
invalidate-bitmap-cache)
|
||||
(define text:mouse-drawings-mixin
|
||||
(mixin (text:hover<%>) (text:mouse-drawings<%>)
|
||||
(inherit dc-location-to-editor-location
|
||||
find-position
|
||||
invalidate-bitmap-cache)
|
||||
|
||||
;; list of Drawings
|
||||
(field [drawings-list null])
|
||||
;; list of Drawings
|
||||
(field [drawings-list null])
|
||||
|
||||
(define/public add-mouse-drawing
|
||||
(case-lambda
|
||||
[(start end draw)
|
||||
(add-mouse-drawing start end draw (box #f))]
|
||||
[(start end draw tack-box)
|
||||
(set! drawings-list
|
||||
(cons (make-drawing start end draw #f tack-box)
|
||||
drawings-list))]))
|
||||
(define/public add-mouse-drawing
|
||||
(case-lambda
|
||||
[(start end draw)
|
||||
(add-mouse-drawing start end draw (box #f))]
|
||||
[(start end draw tack-box)
|
||||
(set! drawings-list
|
||||
(cons (make-drawing start end draw #f tack-box)
|
||||
drawings-list))]))
|
||||
|
||||
(define/public (delete-all-drawings)
|
||||
(set! drawings-list null))
|
||||
(define/public (delete-all-drawings)
|
||||
(set! drawings-list null))
|
||||
|
||||
(define/public-final (for-each-drawing f)
|
||||
(for-each f drawings-list))
|
||||
(define/public-final (for-each-drawing f)
|
||||
(for-each f drawings-list))
|
||||
|
||||
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
|
||||
(super on-paint before? dc left top right bottom dx dy draw-caret)
|
||||
(unless before?
|
||||
(for-each-drawing
|
||||
(lambda (d)
|
||||
(when (or (drawing-visible? d) (unbox (drawing-tacked? d)))
|
||||
((drawing-draw d) this dc left top right bottom dx dy))))))
|
||||
|
||||
(define/override (update-hover-position pos)
|
||||
(super update-hover-position pos)
|
||||
(let ([changed? (update-visible-drawings pos)])
|
||||
(when changed? (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0))))
|
||||
|
||||
(define/private (update-visible-drawings pos)
|
||||
(let ([changed? #f])
|
||||
(for-each-drawing
|
||||
(lambda (d)
|
||||
(let ([vis? (<= (drawing-start d) pos (drawing-end d))])
|
||||
(unless (eqv? vis? (drawing-visible? d))
|
||||
(set-drawing-visible?! d vis?)
|
||||
(set! changed? #t)))))
|
||||
changed?))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define text:tacking-mixin
|
||||
(mixin (text:basic<%> text:mouse-drawings<%>) ()
|
||||
(inherit get-canvas
|
||||
for-each-drawing)
|
||||
(inherit-field drawings-list)
|
||||
(super-new)
|
||||
|
||||
(define/override (on-event ev)
|
||||
(case (send ev get-event-type)
|
||||
((right-down)
|
||||
(if (ormap (lambda (d) (drawing-visible? d)) drawings-list)
|
||||
(send (get-canvas) popup-menu
|
||||
(make-tack/untack-menu)
|
||||
(send ev get-x)
|
||||
(send ev get-y))
|
||||
(super on-event ev)))
|
||||
(else
|
||||
(super on-event ev))))
|
||||
|
||||
(define/private (make-tack/untack-menu)
|
||||
(define menu (new popup-menu%))
|
||||
(new menu-item% (label "Tack")
|
||||
(parent menu)
|
||||
(callback
|
||||
(lambda _ (tack))))
|
||||
(new menu-item% (label "Untack")
|
||||
(parent menu)
|
||||
(callback
|
||||
(lambda _ (untack))))
|
||||
menu)
|
||||
|
||||
(define/private (tack)
|
||||
(define/override (on-paint before? dc left top right bottom dx dy draw-caret)
|
||||
(super on-paint before? dc left top right bottom dx dy draw-caret)
|
||||
(unless before?
|
||||
(for-each-drawing
|
||||
(lambda (d)
|
||||
(when (drawing-visible? d)
|
||||
(set-box! (drawing-tacked? d) #t)))))
|
||||
(define/private (untack)
|
||||
(when (or (drawing-visible? d) (unbox (drawing-tacked? d)))
|
||||
((drawing-draw d) this dc left top right bottom dx dy))))))
|
||||
|
||||
(define/override (update-hover-position pos)
|
||||
(super update-hover-position pos)
|
||||
(let ([changed? (update-visible-drawings pos)])
|
||||
(when changed? (invalidate-bitmap-cache 0.0 0.0 +inf.0 +inf.0))))
|
||||
|
||||
(define/private (update-visible-drawings pos)
|
||||
(let ([changed? #f])
|
||||
(for-each-drawing
|
||||
(lambda (d)
|
||||
(when (drawing-visible? d)
|
||||
(set-box! (drawing-tacked? d) #f)))))))
|
||||
(let ([vis? (<= (drawing-start d) pos (drawing-end d))])
|
||||
(unless (eqv? vis? (drawing-visible? d))
|
||||
(set-drawing-visible?! d vis?)
|
||||
(set! changed? #t)))))
|
||||
changed?))
|
||||
|
||||
(define text:arrows-mixin
|
||||
(mixin (text:mouse-drawings<%>) (text:arrows<%>)
|
||||
(inherit position-location
|
||||
add-mouse-drawing
|
||||
find-wordbreak)
|
||||
(super-new)))
|
||||
|
||||
(define/public (add-arrow from1 from2 to1 to2 color)
|
||||
(internal-add-arrow from1 from2 to1 to2 color #f))
|
||||
(define text:tacking-mixin
|
||||
(mixin (text:basic<%> text:mouse-drawings<%>) ()
|
||||
(inherit get-canvas
|
||||
for-each-drawing)
|
||||
(inherit-field drawings-list)
|
||||
(super-new)
|
||||
|
||||
(define/public (add-question-arrow from1 from2 to1 to2 color)
|
||||
(internal-add-arrow from1 from2 to1 to2 color #t))
|
||||
(define/override (on-event ev)
|
||||
(case (send ev get-event-type)
|
||||
((right-down)
|
||||
(if (ormap (lambda (d) (drawing-visible? d)) drawings-list)
|
||||
(send (get-canvas) popup-menu
|
||||
(make-tack/untack-menu)
|
||||
(send ev get-x)
|
||||
(send ev get-y))
|
||||
(super on-event ev)))
|
||||
(else
|
||||
(super on-event ev))))
|
||||
|
||||
(define/public (add-billboard pos1 pos2 str color-name)
|
||||
(define color (send the-color-database find-color color-name))
|
||||
(define/private (make-tack/untack-menu)
|
||||
(define menu (new popup-menu%))
|
||||
(new menu-item% (label "Tack")
|
||||
(parent menu)
|
||||
(callback
|
||||
(lambda _ (tack))))
|
||||
(new menu-item% (label "Untack")
|
||||
(parent menu)
|
||||
(callback
|
||||
(lambda _ (untack))))
|
||||
menu)
|
||||
|
||||
(define/private (tack)
|
||||
(for-each-drawing
|
||||
(lambda (d)
|
||||
(when (drawing-visible? d)
|
||||
(set-box! (drawing-tacked? d) #t)))))
|
||||
(define/private (untack)
|
||||
(for-each-drawing
|
||||
(lambda (d)
|
||||
(when (drawing-visible? d)
|
||||
(set-box! (drawing-tacked? d) #f)))))))
|
||||
|
||||
(define text:arrows-mixin
|
||||
(mixin (text:mouse-drawings<%>) (text:arrows<%>)
|
||||
(inherit position-location
|
||||
add-mouse-drawing
|
||||
find-wordbreak)
|
||||
|
||||
(define/public (add-arrow from1 from2 to1 to2 color)
|
||||
(internal-add-arrow from1 from2 to1 to2 color #f))
|
||||
|
||||
(define/public (add-question-arrow from1 from2 to1 to2 color)
|
||||
(internal-add-arrow from1 from2 to1 to2 color #t))
|
||||
|
||||
(define/public (add-billboard pos1 pos2 str color-name)
|
||||
(define color (send the-color-database find-color color-name))
|
||||
(let ([draw
|
||||
(lambda (text dc left top right bottom dx dy)
|
||||
(let-values ([(x y) (range->mean-loc pos1 pos1)]
|
||||
[(fw fh _d _v) (send dc get-text-extent "y")])
|
||||
(with-saved-pen&brush dc
|
||||
(with-saved-text-config dc
|
||||
(send* dc
|
||||
(set-pen color 1 'solid)
|
||||
(set-brush billboard-brush)
|
||||
(set-text-mode 'solid)
|
||||
(set-font (billboard-font dc))
|
||||
(set-text-foreground color))
|
||||
(let-values ([(w h d v) (send dc get-text-extent str)]
|
||||
[(adj-y) fh]
|
||||
[(mini) _d])
|
||||
(send* dc
|
||||
(draw-rounded-rectangle
|
||||
(+ x dx)
|
||||
(+ y dy adj-y)
|
||||
(+ w mini mini)
|
||||
(+ h mini mini))
|
||||
(draw-text str (+ x dx mini) (+ y dy mini adj-y))))))))])
|
||||
(add-mouse-drawing pos1 pos2 draw)))
|
||||
|
||||
(define/private (internal-add-arrow from1 from2 to1 to2 color-name question?)
|
||||
(define color (send the-color-database find-color color-name))
|
||||
(define tack-box (box #f))
|
||||
(unless (and (= from1 to1) (= from2 to2))
|
||||
(let ([draw
|
||||
(lambda (text dc left top right bottom dx dy)
|
||||
(let-values ([(x y) (range->mean-loc pos1 pos1)]
|
||||
[(fw fh _d _v) (send dc get-text-extent "y")])
|
||||
(let-values ([(startx starty) (range->mean-loc from1 from2)]
|
||||
[(endx endy) (range->mean-loc to1 to2)]
|
||||
[(fw fh _d _v) (send dc get-text-extent "x")])
|
||||
(with-saved-pen&brush dc
|
||||
(with-saved-text-config dc
|
||||
(send* dc
|
||||
(set-pen color 1 'solid)
|
||||
(set-brush billboard-brush)
|
||||
(set-text-mode 'solid)
|
||||
(set-font (billboard-font dc))
|
||||
(set-text-foreground color))
|
||||
(let-values ([(w h d v) (send dc get-text-extent str)]
|
||||
[(adj-y) fh]
|
||||
[(mini) _d])
|
||||
(send* dc
|
||||
(draw-rounded-rectangle
|
||||
(+ x dx)
|
||||
(+ y dy adj-y)
|
||||
(+ w mini mini)
|
||||
(+ h mini mini))
|
||||
(draw-text str (+ x dx mini) (+ y dy mini adj-y))))))))])
|
||||
(add-mouse-drawing pos1 pos2 draw)))
|
||||
(send dc set-pen color 1 'solid)
|
||||
(send dc set-brush
|
||||
(if (unbox tack-box)
|
||||
(tacked-arrow-brush color)
|
||||
arrow-brush))
|
||||
(draw-arrow dc startx
|
||||
(+ starty (/ fh 2))
|
||||
endx
|
||||
(+ endy (/ fh 2))
|
||||
dx dy)
|
||||
(send dc set-text-mode 'transparent)
|
||||
(when question?
|
||||
(send dc set-font (?-font dc))
|
||||
(send dc set-text-foreground color)
|
||||
(send dc draw-text "?"
|
||||
(+ endx dx fw)
|
||||
(- endy dy fh)))))))])
|
||||
(add-mouse-drawing from1 from2 draw tack-box)
|
||||
(add-mouse-drawing to1 to2 draw tack-box))))
|
||||
|
||||
(define/private (internal-add-arrow from1 from2 to1 to2 color-name question?)
|
||||
(define color (send the-color-database find-color color-name))
|
||||
(define tack-box (box #f))
|
||||
(unless (and (= from1 to1) (= from2 to2))
|
||||
(let ([draw
|
||||
(lambda (text dc left top right bottom dx dy)
|
||||
(let-values ([(startx starty) (range->mean-loc from1 from2)]
|
||||
[(endx endy) (range->mean-loc to1 to2)]
|
||||
[(fw fh _d _v) (send dc get-text-extent "x")])
|
||||
(with-saved-pen&brush dc
|
||||
(with-saved-text-config dc
|
||||
(send dc set-pen color 1 'solid)
|
||||
(send dc set-brush
|
||||
(if (unbox tack-box)
|
||||
(tacked-arrow-brush color)
|
||||
arrow-brush))
|
||||
(draw-arrow dc startx
|
||||
(+ starty (/ fh 2))
|
||||
endx
|
||||
(+ endy (/ fh 2))
|
||||
dx dy)
|
||||
(send dc set-text-mode 'transparent)
|
||||
(when question?
|
||||
(send dc set-font (?-font dc))
|
||||
(send dc set-text-foreground color)
|
||||
(send dc draw-text "?"
|
||||
(+ endx dx fw)
|
||||
(- endy dy fh)))))))])
|
||||
(add-mouse-drawing from1 from2 draw tack-box)
|
||||
(add-mouse-drawing to1 to2 draw tack-box))))
|
||||
(define/private (position->location p)
|
||||
(define xbox (box 0.0))
|
||||
(define ybox (box 0.0))
|
||||
(position-location p xbox ybox)
|
||||
(values (unbox xbox) (unbox ybox)))
|
||||
|
||||
(define/private (position->location p)
|
||||
(define xbox (box 0.0))
|
||||
(define ybox (box 0.0))
|
||||
(position-location p xbox ybox)
|
||||
(values (unbox xbox) (unbox ybox)))
|
||||
(define/private (?-font dc)
|
||||
(let ([size (send (send dc get-font) get-point-size)])
|
||||
(send the-font-list find-or-create-font size 'default 'normal 'bold)))
|
||||
|
||||
(define/private (?-font dc)
|
||||
(let ([size (send (send dc get-font) get-point-size)])
|
||||
(send the-font-list find-or-create-font size 'default 'normal 'bold)))
|
||||
(define/private (billboard-font dc)
|
||||
(let ([size (send (send dc get-font) get-point-size)])
|
||||
(send the-font-list find-or-create-font size 'default 'normal)))
|
||||
|
||||
(define/private (billboard-font dc)
|
||||
(let ([size (send (send dc get-font) get-point-size)])
|
||||
(send the-font-list find-or-create-font size 'default 'normal)))
|
||||
(define/private (range->mean-loc pos1 pos2)
|
||||
(let*-values ([(loc1x loc1y) (position->location pos1)]
|
||||
[(loc2x loc2y) (position->location pos2)]
|
||||
[(locx) (mean loc1x loc2x)]
|
||||
[(locy) (mean loc1y loc2y)])
|
||||
(values locx locy)))
|
||||
|
||||
(define/private (range->mean-loc pos1 pos2)
|
||||
(let*-values ([(loc1x loc1y) (position->location pos1)]
|
||||
[(loc2x loc2y) (position->location pos2)]
|
||||
[(locx) (mean loc1x loc2x)]
|
||||
[(locy) (mean loc1y loc2y)])
|
||||
(values locx locy)))
|
||||
(super-new)))
|
||||
|
||||
(super-new)))
|
||||
(define text:mouse-drawings%
|
||||
(text:mouse-drawings-mixin
|
||||
(text:hover-mixin
|
||||
text:standard-style-list%)))
|
||||
|
||||
(define text:mouse-drawings%
|
||||
(text:mouse-drawings-mixin
|
||||
(text:hover-mixin
|
||||
text:standard-style-list%)))
|
||||
|
||||
(define text:arrows%
|
||||
(text:arrows-mixin
|
||||
(text:tacking-mixin
|
||||
text:mouse-drawings%)))
|
||||
)
|
||||
(define text:arrows%
|
||||
(text:arrows-mixin
|
||||
(text:tacking-mixin
|
||||
text:mouse-drawings%)))
|
||||
|
|
|
|||
|
|
@ -1,60 +1,59 @@
|
|||
|
||||
(module util mzscheme
|
||||
(require (lib "class.ss"))
|
||||
(provide with-unlock
|
||||
make-text-port
|
||||
mpi->string
|
||||
mpi->list)
|
||||
#lang scheme/base
|
||||
(require scheme/class)
|
||||
(provide with-unlock
|
||||
make-text-port
|
||||
mpi->string
|
||||
mpi->list)
|
||||
|
||||
;; with-unlock SYNTAX (expression)
|
||||
;; (with-unlock text-expression . body)
|
||||
(define-syntax with-unlock
|
||||
(syntax-rules ()
|
||||
[(with-unlock text . body)
|
||||
(let* ([t text]
|
||||
[locked? (send t is-locked?)])
|
||||
(send t lock #f)
|
||||
(begin0 (let () . body)
|
||||
(send t lock locked?)))]))
|
||||
;; with-unlock SYNTAX (expression)
|
||||
;; (with-unlock text-expression . body)
|
||||
(define-syntax with-unlock
|
||||
(syntax-rules ()
|
||||
[(with-unlock text . body)
|
||||
(let* ([t text]
|
||||
[locked? (send t is-locked?)])
|
||||
(send t lock #f)
|
||||
(begin0 (let () . body)
|
||||
(send t lock locked?)))]))
|
||||
|
||||
;; make-text-port : text (-> number) -> port
|
||||
;; builds a port from a text object.
|
||||
(define (make-text-port text end-position)
|
||||
(make-output-port #f
|
||||
always-evt
|
||||
(lambda (s start end flush? enable-break?)
|
||||
(send text insert
|
||||
(bytes->string/utf-8 s #f start end)
|
||||
(end-position))
|
||||
(- end start))
|
||||
void
|
||||
(lambda (special buffer? enable-break?)
|
||||
(send text insert special (end-position))
|
||||
#t)))
|
||||
;; make-text-port : text (-> number) -> port
|
||||
;; builds a port from a text object.
|
||||
(define (make-text-port text end-position)
|
||||
(make-output-port #f
|
||||
always-evt
|
||||
(lambda (s start end flush? enable-break?)
|
||||
(send text insert
|
||||
(bytes->string/utf-8 s #f start end)
|
||||
(end-position))
|
||||
(- end start))
|
||||
void
|
||||
(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->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)]))
|
||||
)
|
||||
;; 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)]))
|
||||
|
|
|
|||
|
|
@ -1,258 +1,257 @@
|
|||
|
||||
(module widget mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "list.ss")
|
||||
(lib "plt-match.ss")
|
||||
(lib "kw.ss")
|
||||
(lib "boundmap.ss" "syntax")
|
||||
"interfaces.ss"
|
||||
"params.ss"
|
||||
"controller.ss"
|
||||
"display.ss"
|
||||
"keymap.ss"
|
||||
"hrule-snip.ss"
|
||||
"properties.ss"
|
||||
"text.ss"
|
||||
"util.ss")
|
||||
(provide widget%
|
||||
widget-keymap%
|
||||
widget-context-menu%)
|
||||
#lang mzscheme
|
||||
(require scheme/class
|
||||
mred/mred
|
||||
framework/framework
|
||||
scheme/list
|
||||
scheme/match
|
||||
mzlib/kw
|
||||
syntax/boundmap
|
||||
"interfaces.ss"
|
||||
"params.ss"
|
||||
"controller.ss"
|
||||
"display.ss"
|
||||
"keymap.ss"
|
||||
"hrule-snip.ss"
|
||||
"properties.ss"
|
||||
"text.ss"
|
||||
"util.ss")
|
||||
(provide widget%
|
||||
widget-keymap%
|
||||
widget-context-menu%)
|
||||
|
||||
;; widget%
|
||||
;; A syntax widget creates its own syntax-controller.
|
||||
(define widget%
|
||||
(class* object% (widget-hooks<%>)
|
||||
(init parent)
|
||||
(init-field config)
|
||||
;; widget%
|
||||
;; A syntax widget creates its own syntax-controller.
|
||||
(define widget%
|
||||
(class* object% (widget-hooks<%>)
|
||||
(init parent)
|
||||
(init-field config)
|
||||
|
||||
(define controller (new controller%))
|
||||
(define controller (new controller%))
|
||||
|
||||
(define -main-panel
|
||||
(new vertical-panel% (parent parent)))
|
||||
(define -split-panel
|
||||
(new panel:horizontal-dragable% (parent -main-panel)))
|
||||
(define -text (new browser-text%))
|
||||
(define -ecanvas
|
||||
(new editor-canvas% (parent -split-panel) (editor -text)))
|
||||
(define -props-panel (new horizontal-panel% (parent -split-panel)))
|
||||
(define props
|
||||
(new properties-view%
|
||||
(parent -props-panel)
|
||||
(controller controller)))
|
||||
(define props-percentage (send config pref:props-percentage))
|
||||
(define -main-panel
|
||||
(new vertical-panel% (parent parent)))
|
||||
(define -split-panel
|
||||
(new panel:horizontal-dragable% (parent -main-panel)))
|
||||
(define -text (new browser-text%))
|
||||
(define -ecanvas
|
||||
(new editor-canvas% (parent -split-panel) (editor -text)))
|
||||
(define -props-panel (new horizontal-panel% (parent -split-panel)))
|
||||
(define props
|
||||
(new properties-view%
|
||||
(parent -props-panel)
|
||||
(controller controller)))
|
||||
(define props-percentage (send config pref:props-percentage))
|
||||
|
||||
(define/public (setup-keymap)
|
||||
(new widget-keymap%
|
||||
(editor -text)
|
||||
(widget this)))
|
||||
(define/public (setup-keymap)
|
||||
(new widget-keymap%
|
||||
(editor -text)
|
||||
(widget this)))
|
||||
|
||||
(send -text set-styles-sticky #f)
|
||||
(send -text lock #t)
|
||||
(send -text set-styles-sticky #f)
|
||||
(send -text lock #t)
|
||||
|
||||
(send -split-panel set-percentages
|
||||
(list (- 1 props-percentage) props-percentage))
|
||||
(send -split-panel set-percentages
|
||||
(list (- 1 props-percentage) props-percentage))
|
||||
|
||||
;; syntax-properties-controller<%> methods
|
||||
;; syntax-properties-controller<%> methods
|
||||
|
||||
(define/public (props-shown?)
|
||||
(send -props-panel is-shown?))
|
||||
(define/public (props-shown?)
|
||||
(send -props-panel is-shown?))
|
||||
|
||||
(define/public (toggle-props)
|
||||
(show-props (not (send -props-panel is-shown?))))
|
||||
(define/public (toggle-props)
|
||||
(show-props (not (send -props-panel is-shown?))))
|
||||
|
||||
(define/public (show-props show?)
|
||||
(if show?
|
||||
(unless (send -props-panel is-shown?)
|
||||
(send -split-panel add-child -props-panel)
|
||||
(send -split-panel set-percentages
|
||||
(list (- 1 props-percentage) props-percentage))
|
||||
(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))))
|
||||
(define/public (show-props show?)
|
||||
(if show?
|
||||
(unless (send -props-panel is-shown?)
|
||||
(send -split-panel add-child -props-panel)
|
||||
(send -split-panel set-percentages
|
||||
(list (- 1 props-percentage) props-percentage))
|
||||
(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))))
|
||||
|
||||
;;
|
||||
;;
|
||||
|
||||
(define/public (get-controller) controller)
|
||||
(define/public (get-controller) controller)
|
||||
|
||||
;;
|
||||
;;
|
||||
|
||||
(define/public (get-main-panel) -main-panel)
|
||||
(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)))
|
||||
(define/public (shutdown)
|
||||
(unless (= props-percentage (send config pref:props-percentage))
|
||||
(send config pref:props-percentage props-percentage)))
|
||||
|
||||
;; syntax-browser<%> Methods
|
||||
;; syntax-browser<%> Methods
|
||||
|
||||
(define/public (add-text text)
|
||||
(with-unlock -text
|
||||
(send -text insert text)))
|
||||
(define/public (add-text text)
|
||||
(with-unlock -text
|
||||
(send -text insert text)))
|
||||
|
||||
(define/public (add-error-text text)
|
||||
(with-unlock -text
|
||||
(let ([a (send -text last-position)])
|
||||
(send -text insert text)
|
||||
(let ([b (send -text last-position)])
|
||||
(send -text change-style error-text-style a b)))))
|
||||
|
||||
(define/public (add-clickback text handler)
|
||||
(with-unlock -text
|
||||
(let ([a (send -text last-position)])
|
||||
(send -text insert text)
|
||||
(let ([b (send -text last-position)])
|
||||
(send -text set-clickback a b handler)
|
||||
(send -text change-style clickback-style a b)))))
|
||||
(define/public (add-error-text text)
|
||||
(with-unlock -text
|
||||
(let ([a (send -text last-position)])
|
||||
(send -text insert text)
|
||||
(let ([b (send -text last-position)])
|
||||
(send -text change-style error-text-style a b)))))
|
||||
|
||||
(define/public (add-clickback text handler)
|
||||
(with-unlock -text
|
||||
(let ([a (send -text last-position)])
|
||||
(send -text insert text)
|
||||
(let ([b (send -text last-position)])
|
||||
(send -text set-clickback a b handler)
|
||||
(send -text change-style clickback-style a b)))))
|
||||
|
||||
(define/public add-syntax
|
||||
(lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table [definites null]
|
||||
hi2-color [hi2-stxs null])
|
||||
(define (get-binder id)
|
||||
(module-identifier-mapping-get alpha-table id (lambda () #f)))
|
||||
(when (and (pair? hi-stxs) (not hi-color))
|
||||
(error 'syntax-widget%::add-syntax "no highlight color specified"))
|
||||
(let ([display (internal-add-syntax stx)]
|
||||
[definite-table (make-hash-table)])
|
||||
(when (and hi2-color (pair? hi2-stxs))
|
||||
(send display highlight-syntaxes hi2-stxs hi2-color))
|
||||
(when (and hi-color (pair? hi-stxs))
|
||||
(send display highlight-syntaxes hi-stxs hi-color))
|
||||
(for-each (lambda (x) (hash-table-put! definite-table x #t)) definites)
|
||||
(when alpha-table
|
||||
(let ([range (send display get-range)]
|
||||
[start (send display get-start-position)])
|
||||
(define (adjust n) (+ start n))
|
||||
(for-each
|
||||
(lambda (id)
|
||||
#; ;; DISABLED
|
||||
(match (identifier-binding id)
|
||||
[(list src-mod src-name nom-mod nom-name _)
|
||||
(for-each (lambda (id-r)
|
||||
(send -text add-billboard
|
||||
(adjust (car id-r))
|
||||
(adjust (cdr id-r))
|
||||
(string-append "from "
|
||||
(mpi->string src-mod))
|
||||
(if (hash-table-get definite-table id #f)
|
||||
"blue"
|
||||
"purple")))
|
||||
(send range get-ranges id))]
|
||||
[_ (void)])
|
||||
|
||||
(let ([binder (get-binder id)])
|
||||
(when binder
|
||||
(for-each
|
||||
(lambda (binder-r)
|
||||
(for-each (lambda (id-r)
|
||||
(define/public add-syntax
|
||||
(lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table [definites null]
|
||||
hi2-color [hi2-stxs null])
|
||||
(define (get-binder id)
|
||||
(module-identifier-mapping-get alpha-table id (lambda () #f)))
|
||||
(when (and (pair? hi-stxs) (not hi-color))
|
||||
(error 'syntax-widget%::add-syntax "no highlight color specified"))
|
||||
(let ([display (internal-add-syntax stx)]
|
||||
[definite-table (make-hash-table)])
|
||||
(when (and hi2-color (pair? hi2-stxs))
|
||||
(send display highlight-syntaxes hi2-stxs hi2-color))
|
||||
(when (and hi-color (pair? hi-stxs))
|
||||
(send display highlight-syntaxes hi-stxs hi-color))
|
||||
(for-each (lambda (x) (hash-table-put! definite-table x #t)) definites)
|
||||
(when alpha-table
|
||||
(let ([range (send display get-range)]
|
||||
[start (send display get-start-position)])
|
||||
(define (adjust n) (+ start n))
|
||||
(for-each
|
||||
(lambda (id)
|
||||
#; ;; DISABLED
|
||||
(match (identifier-binding id)
|
||||
[(list src-mod src-name nom-mod nom-name _)
|
||||
(for-each (lambda (id-r)
|
||||
(send -text add-billboard
|
||||
(adjust (car id-r))
|
||||
(adjust (cdr id-r))
|
||||
(string-append "from "
|
||||
(mpi->string src-mod))
|
||||
(if (hash-table-get definite-table id #f)
|
||||
(send -text add-arrow
|
||||
(adjust (car binder-r))
|
||||
(adjust (cdr binder-r))
|
||||
(adjust (car id-r))
|
||||
(adjust (cdr id-r))
|
||||
"blue")
|
||||
(send -text add-question-arrow
|
||||
(adjust (car binder-r))
|
||||
(adjust (cdr binder-r))
|
||||
(adjust (car id-r))
|
||||
(adjust (cdr id-r))
|
||||
"purple")))
|
||||
(send range get-ranges id)))
|
||||
(send range get-ranges binder)))))
|
||||
(send range get-identifier-list))))
|
||||
display)))
|
||||
"blue"
|
||||
"purple")))
|
||||
(send range get-ranges id))]
|
||||
[_ (void)])
|
||||
|
||||
(define/public (add-separator)
|
||||
(with-unlock -text
|
||||
(send* -text
|
||||
(insert (new hrule-snip%))
|
||||
(insert "\n"))))
|
||||
(let ([binder (get-binder id)])
|
||||
(when binder
|
||||
(for-each
|
||||
(lambda (binder-r)
|
||||
(for-each (lambda (id-r)
|
||||
(if (hash-table-get definite-table id #f)
|
||||
(send -text add-arrow
|
||||
(adjust (car binder-r))
|
||||
(adjust (cdr binder-r))
|
||||
(adjust (car id-r))
|
||||
(adjust (cdr id-r))
|
||||
"blue")
|
||||
(send -text add-question-arrow
|
||||
(adjust (car binder-r))
|
||||
(adjust (cdr binder-r))
|
||||
(adjust (car id-r))
|
||||
(adjust (cdr id-r))
|
||||
"purple")))
|
||||
(send range get-ranges id)))
|
||||
(send range get-ranges binder)))))
|
||||
(send range get-identifier-list))))
|
||||
display)))
|
||||
|
||||
(define/public (erase-all)
|
||||
(with-unlock -text
|
||||
(send -text erase)
|
||||
(send -text delete-all-drawings))
|
||||
(send controller remove-all-syntax-displays))
|
||||
(define/public (add-separator)
|
||||
(with-unlock -text
|
||||
(send* -text
|
||||
(insert (new hrule-snip%))
|
||||
(insert "\n"))))
|
||||
|
||||
(define/public (get-text) -text)
|
||||
(define/public (erase-all)
|
||||
(with-unlock -text
|
||||
(send -text erase)
|
||||
(send -text delete-all-drawings))
|
||||
(send controller remove-all-syntax-displays))
|
||||
|
||||
;; internal-add-syntax : syntax -> display
|
||||
(define/private (internal-add-syntax stx)
|
||||
(with-unlock -text
|
||||
(parameterize ((current-default-columns (calculate-columns)))
|
||||
(let ([display (print-syntax-to-editor stx -text controller)])
|
||||
(send* -text
|
||||
(insert "\n")
|
||||
;(scroll-to-position current-position)
|
||||
)
|
||||
display))))
|
||||
(define/public (get-text) -text)
|
||||
|
||||
(define/private (calculate-columns)
|
||||
(define style (code-style -text))
|
||||
(define char-width (send style get-text-width (send -ecanvas get-dc)))
|
||||
(define-values (canvas-w canvas-h) (send -ecanvas get-client-size))
|
||||
(sub1 (inexact->exact (floor (/ canvas-w char-width)))))
|
||||
;; internal-add-syntax : syntax -> display
|
||||
(define/private (internal-add-syntax stx)
|
||||
(with-unlock -text
|
||||
(parameterize ((current-default-columns (calculate-columns)))
|
||||
(let ([display (print-syntax-to-editor stx -text controller)])
|
||||
(send* -text
|
||||
(insert "\n")
|
||||
;(scroll-to-position current-position)
|
||||
)
|
||||
display))))
|
||||
|
||||
;; Initialize
|
||||
(super-new)
|
||||
(setup-keymap)))
|
||||
(define/private (calculate-columns)
|
||||
(define style (code-style -text))
|
||||
(define char-width (send style get-text-width (send -ecanvas get-dc)))
|
||||
(define-values (canvas-w canvas-h) (send -ecanvas get-client-size))
|
||||
(sub1 (inexact->exact (floor (/ canvas-w char-width)))))
|
||||
|
||||
(define clickback-style
|
||||
(let ([sd (new style-delta%)])
|
||||
(send sd set-delta 'change-toggle-underline)
|
||||
(send sd set-delta-foreground "blue")
|
||||
sd))
|
||||
;; Initialize
|
||||
(super-new)
|
||||
(setup-keymap)))
|
||||
|
||||
(define error-text-style
|
||||
(let ([sd (new style-delta%)])
|
||||
(send sd set-delta 'change-italic)
|
||||
(send sd set-delta-foreground "red")
|
||||
sd))
|
||||
(define clickback-style
|
||||
(let ([sd (new style-delta%)])
|
||||
(send sd set-delta 'change-toggle-underline)
|
||||
(send sd set-delta-foreground "blue")
|
||||
sd))
|
||||
|
||||
;; Specialized classes for widget
|
||||
(define error-text-style
|
||||
(let ([sd (new style-delta%)])
|
||||
(send sd set-delta 'change-italic)
|
||||
(send sd set-delta-foreground "red")
|
||||
sd))
|
||||
|
||||
(define widget-keymap%
|
||||
(class syntax-keymap%
|
||||
(init-field widget)
|
||||
(super-new (controller (send widget get-controller)))
|
||||
(inherit add-function)
|
||||
(inherit-field controller)
|
||||
;; Specialized classes for widget
|
||||
|
||||
(define/override (get-context-menu%)
|
||||
widget-context-menu%)
|
||||
(define widget-keymap%
|
||||
(class syntax-keymap%
|
||||
(init-field widget)
|
||||
(super-new (controller (send widget get-controller)))
|
||||
(inherit add-function)
|
||||
(inherit-field controller)
|
||||
|
||||
(add-function "show-syntax-properties"
|
||||
(lambda (i e)
|
||||
(send widget toggle-props)))
|
||||
(define/override (get-context-menu%)
|
||||
widget-context-menu%)
|
||||
|
||||
(define/public (get-widget) widget)))
|
||||
(add-function "show-syntax-properties"
|
||||
(lambda (i e)
|
||||
(send widget toggle-props)))
|
||||
|
||||
(define widget-context-menu%
|
||||
(class context-menu%
|
||||
(inherit-field keymap)
|
||||
(inherit-field props-menu)
|
||||
(define/public (get-widget) widget)))
|
||||
|
||||
(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 widget-context-menu%
|
||||
(class context-menu%
|
||||
(inherit-field keymap)
|
||||
(inherit-field props-menu)
|
||||
|
||||
(define browser-text%
|
||||
(class (text:arrows-mixin
|
||||
(text:tacking-mixin
|
||||
(text:mouse-drawings-mixin
|
||||
(text:hover-mixin
|
||||
(text:hide-caret/selection-mixin
|
||||
(editor:standard-style-list-mixin text:basic%))))))
|
||||
(inherit set-autowrap-bitmap)
|
||||
(define/override (default-style-name) "Basic")
|
||||
(super-new (auto-wrap #t))
|
||||
(set-autowrap-bitmap #f)))
|
||||
)
|
||||
(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
|
||||
(text:mouse-drawings-mixin
|
||||
(text:hover-mixin
|
||||
(text:hide-caret/selection-mixin
|
||||
(editor:standard-style-list-mixin text:basic%))))))
|
||||
(inherit set-autowrap-bitmap)
|
||||
(define/override (default-style-name) "Basic")
|
||||
(super-new (auto-wrap #t))
|
||||
(set-autowrap-bitmap #f)))
|
||||
|
|
|
|||
|
|
@ -1,132 +1,131 @@
|
|||
|
||||
(module cursor mzscheme
|
||||
(provide cursor?
|
||||
cursor:new
|
||||
cursor:add-to-end!
|
||||
cursor:remove-current!
|
||||
#lang scheme/base
|
||||
(require scheme/promise)
|
||||
(provide cursor?
|
||||
cursor:new
|
||||
cursor:add-to-end!
|
||||
cursor:remove-current!
|
||||
|
||||
cursor:next
|
||||
cursor:prev
|
||||
cursor:next
|
||||
cursor:prev
|
||||
|
||||
cursor:at-start?
|
||||
cursor:at-end?
|
||||
cursor:at-start?
|
||||
cursor:at-end?
|
||||
|
||||
cursor:has-next?
|
||||
cursor:has-prev?
|
||||
cursor:has-next?
|
||||
cursor:has-prev?
|
||||
|
||||
cursor:move-next
|
||||
cursor:move-prev
|
||||
cursor:move-to-start
|
||||
cursor:move-to-end
|
||||
cursor:skip-to
|
||||
cursor:move-next
|
||||
cursor:move-prev
|
||||
cursor:move-to-start
|
||||
cursor:move-to-end
|
||||
cursor:skip-to
|
||||
|
||||
cursor->list
|
||||
cursor:prefix->list
|
||||
cursor:suffix->list)
|
||||
cursor->list
|
||||
cursor:prefix->list
|
||||
cursor:suffix->list)
|
||||
|
||||
(define-syntax stream-cons
|
||||
(syntax-rules ()
|
||||
[(stream-cons x y)
|
||||
(delay (cons x y))]))
|
||||
(define-syntax stream-cons
|
||||
(syntax-rules ()
|
||||
[(stream-cons x y)
|
||||
(delay (cons x y))]))
|
||||
|
||||
(define (stream-car x)
|
||||
(if (promise? x)
|
||||
(car (force x))
|
||||
(car x)))
|
||||
(define (stream-car x)
|
||||
(if (promise? x)
|
||||
(car (force x))
|
||||
(car x)))
|
||||
|
||||
(define (stream-cdr x)
|
||||
(if (promise? x)
|
||||
(cdr (force x))
|
||||
(cdr x)))
|
||||
|
||||
(define (stream-null? x)
|
||||
(or (null? x)
|
||||
(and (promise? x) (null? (force x)))))
|
||||
(define (stream-cdr x)
|
||||
(if (promise? x)
|
||||
(cdr (force x))
|
||||
(cdr x)))
|
||||
|
||||
(define (stream-append x y)
|
||||
(if (stream-null? x)
|
||||
y
|
||||
(stream-cons (stream-car x)
|
||||
(stream-append (stream-cdr x) y))))
|
||||
(define (stream-null? x)
|
||||
(or (null? x)
|
||||
(and (promise? x) (null? (force x)))))
|
||||
|
||||
(define (stream->list s)
|
||||
(if (stream-null? s)
|
||||
null
|
||||
(cons (stream-car s) (stream->list (stream-cdr s)))))
|
||||
(define (stream-append x y)
|
||||
(if (stream-null? x)
|
||||
y
|
||||
(stream-cons (stream-car x)
|
||||
(stream-append (stream-cdr x) y))))
|
||||
|
||||
;; Cursors
|
||||
|
||||
;; A (Cursor-of 'a) is (make-cursor (list-of 'a) (Stream-of 'a))
|
||||
(define-struct cursor (prefix suffixp))
|
||||
|
||||
(define (cursor:new items)
|
||||
(make-cursor null items))
|
||||
(define (stream->list s)
|
||||
(if (stream-null? s)
|
||||
null
|
||||
(cons (stream-car s) (stream->list (stream-cdr s)))))
|
||||
|
||||
(define (cursor:add-to-end! c items)
|
||||
(let ([suffix (cursor-suffixp c)])
|
||||
(set-cursor-suffixp! c (stream-append suffix items))))
|
||||
;; Cursors
|
||||
|
||||
(define (cursor:remove-current! c)
|
||||
(when (cursor:has-next? c)
|
||||
(set-cursor-suffixp! c (stream-cdr (cursor-suffixp c)))))
|
||||
;; A (Cursor-of 'a) is (make-cursor (list-of 'a) (Stream-of 'a))
|
||||
(define-struct cursor (prefix suffixp) #:mutable)
|
||||
|
||||
(define (cursor:next c)
|
||||
(let ([suffix (cursor-suffixp c)])
|
||||
(if (stream-null? suffix)
|
||||
#f
|
||||
(stream-car suffix))))
|
||||
(define (cursor:new items)
|
||||
(make-cursor null items))
|
||||
|
||||
(define (cursor:prev c)
|
||||
(let ([prefix (cursor-prefix c)])
|
||||
(if (pair? prefix)
|
||||
(car prefix)
|
||||
#f)))
|
||||
(define (cursor:add-to-end! c items)
|
||||
(let ([suffix (cursor-suffixp c)])
|
||||
(set-cursor-suffixp! c (stream-append suffix items))))
|
||||
|
||||
(define (cursor:move-prev c)
|
||||
(when (pair? (cursor-prefix c))
|
||||
(let ([old-prefix (cursor-prefix c)])
|
||||
(set-cursor-prefix! c (cdr old-prefix))
|
||||
(set-cursor-suffixp! c (cons (car old-prefix) (cursor-suffixp c))))))
|
||||
(define (cursor:remove-current! c)
|
||||
(when (cursor:has-next? c)
|
||||
(set-cursor-suffixp! c (stream-cdr (cursor-suffixp c)))))
|
||||
|
||||
(define (cursor:move-next c)
|
||||
(when (cursor:has-next? c)
|
||||
(let* ([old-suffixp (cursor-suffixp c)])
|
||||
(set-cursor-prefix! c (cons (stream-car old-suffixp)
|
||||
(cursor-prefix c)))
|
||||
(set-cursor-suffixp! c (stream-cdr old-suffixp)))))
|
||||
(define (cursor:next c)
|
||||
(let ([suffix (cursor-suffixp c)])
|
||||
(if (stream-null? suffix)
|
||||
#f
|
||||
(stream-car suffix))))
|
||||
|
||||
(define (cursor:at-start? c)
|
||||
(null? (cursor-prefix c)))
|
||||
(define (cursor:at-end? c)
|
||||
(stream-null? (cursor-suffixp c)))
|
||||
(define (cursor:has-next? c)
|
||||
(not (cursor:at-end? c)))
|
||||
(define (cursor:has-prev? c)
|
||||
(not (cursor:at-start? c)))
|
||||
|
||||
(define (cursor:move-to-start c)
|
||||
(when (cursor:has-prev? c)
|
||||
(cursor:move-prev c)
|
||||
(cursor:move-to-start c)))
|
||||
|
||||
(define (cursor:move-to-end c)
|
||||
(when (cursor:has-next? c)
|
||||
(cursor:move-next c)
|
||||
(cursor:move-to-end c)))
|
||||
(define (cursor:prev c)
|
||||
(let ([prefix (cursor-prefix c)])
|
||||
(if (pair? prefix)
|
||||
(car prefix)
|
||||
#f)))
|
||||
|
||||
(define (cursor:skip-to c i)
|
||||
(unless (or (eq? (cursor:next c) i) (cursor:at-end? c))
|
||||
(cursor:move-next c)
|
||||
(cursor:skip-to c i)))
|
||||
|
||||
(define (cursor->list c)
|
||||
(append (cursor:prefix->list c)
|
||||
(cursor:suffix->list c)))
|
||||
(define (cursor:move-prev c)
|
||||
(when (pair? (cursor-prefix c))
|
||||
(let ([old-prefix (cursor-prefix c)])
|
||||
(set-cursor-prefix! c (cdr old-prefix))
|
||||
(set-cursor-suffixp! c (cons (car old-prefix) (cursor-suffixp c))))))
|
||||
|
||||
(define (cursor:prefix->list c)
|
||||
(reverse (cursor-prefix c)))
|
||||
(define (cursor:move-next c)
|
||||
(when (cursor:has-next? c)
|
||||
(let* ([old-suffixp (cursor-suffixp c)])
|
||||
(set-cursor-prefix! c (cons (stream-car old-suffixp)
|
||||
(cursor-prefix c)))
|
||||
(set-cursor-suffixp! c (stream-cdr old-suffixp)))))
|
||||
|
||||
(define (cursor:suffix->list c)
|
||||
(stream->list (cursor-suffixp c)))
|
||||
|
||||
)
|
||||
(define (cursor:at-start? c)
|
||||
(null? (cursor-prefix c)))
|
||||
(define (cursor:at-end? c)
|
||||
(stream-null? (cursor-suffixp c)))
|
||||
(define (cursor:has-next? c)
|
||||
(not (cursor:at-end? c)))
|
||||
(define (cursor:has-prev? c)
|
||||
(not (cursor:at-start? c)))
|
||||
|
||||
(define (cursor:move-to-start c)
|
||||
(when (cursor:has-prev? c)
|
||||
(cursor:move-prev c)
|
||||
(cursor:move-to-start c)))
|
||||
|
||||
(define (cursor:move-to-end c)
|
||||
(when (cursor:has-next? c)
|
||||
(cursor:move-next c)
|
||||
(cursor:move-to-end c)))
|
||||
|
||||
(define (cursor:skip-to c i)
|
||||
(unless (or (eq? (cursor:next c) i) (cursor:at-end? c))
|
||||
(cursor:move-next c)
|
||||
(cursor:skip-to c i)))
|
||||
|
||||
(define (cursor->list c)
|
||||
(append (cursor:prefix->list c)
|
||||
(cursor:suffix->list c)))
|
||||
|
||||
(define (cursor:prefix->list c)
|
||||
(reverse (cursor-prefix c)))
|
||||
|
||||
(define (cursor:suffix->list c)
|
||||
(stream->list (cursor-suffixp c)))
|
||||
|
|
|
|||
|
|
@ -1,55 +1,53 @@
|
|||
|
||||
(module debug-format mzscheme
|
||||
(require (lib "pretty.ss"))
|
||||
(provide write-debug-file
|
||||
load-debug-file)
|
||||
#lang scheme/base
|
||||
(require scheme/pretty)
|
||||
(provide write-debug-file
|
||||
load-debug-file)
|
||||
|
||||
(define (write-debug-file file exn events)
|
||||
(with-output-to-file file
|
||||
(lambda ()
|
||||
(write `(list ,@(map (lambda (e) (serialize-datum e)) events)))
|
||||
(newline)
|
||||
(write (exn-message exn))
|
||||
(newline)
|
||||
(write (map serialize-context-frame
|
||||
(continuation-mark-set->context
|
||||
(exn-continuation-marks exn)))))
|
||||
'replace))
|
||||
|
||||
(define (write-debug-file file exn events)
|
||||
(with-output-to-file file
|
||||
(define (serialize-datum d)
|
||||
(cond [(number? d) `(quote ,d)]
|
||||
[(boolean? d) `(quote ,d)]
|
||||
[(symbol? d) `(quote ,d)]
|
||||
[(string? d) `(quote ,d)]
|
||||
[(pair? d) `(cons ,(serialize-datum (car d)) ,(serialize-datum (cdr d)))]
|
||||
[(null? d) '()]
|
||||
[(exn? d) `(make-exn ,(exn-message d) (current-continuation-marks))]
|
||||
[(syntax? d) `(datum->syntax #f ',(syntax->datum d))]
|
||||
#;[(syntax? d) `(eval (quote ,(compile `(,#'quote-syntax ,d))))]
|
||||
[else (error 'serialize-datum "got ~s" d)]))
|
||||
|
||||
(define (serialize-context-frame frame)
|
||||
(cons (car frame)
|
||||
(if (cdr frame)
|
||||
(serialize-srcloc (cdr frame))
|
||||
null)))
|
||||
|
||||
(define (serialize-srcloc s)
|
||||
(list (let ([src (srcloc-source s)])
|
||||
(cond [(path? src) (path->string src)]
|
||||
[(string? src) src]
|
||||
[else '?]))
|
||||
(srcloc-line s)
|
||||
(srcloc-column s)))
|
||||
|
||||
(define (load-debug-file file)
|
||||
(parameterize ((read-accept-compiled #t))
|
||||
(with-input-from-file file
|
||||
(lambda ()
|
||||
(write `(list ,@(map (lambda (e) (serialize-datum e)) events)))
|
||||
(newline)
|
||||
(write (exn-message exn))
|
||||
(newline)
|
||||
(write (map serialize-context-frame
|
||||
(continuation-mark-set->context
|
||||
(exn-continuation-marks exn)))))
|
||||
'replace))
|
||||
|
||||
(define (serialize-datum d)
|
||||
(cond [(number? d) `(quote ,d)]
|
||||
[(boolean? d) `(quote ,d)]
|
||||
[(symbol? d) `(quote ,d)]
|
||||
[(string? d) `(quote ,d)]
|
||||
[(pair? d) `(cons ,(serialize-datum (car d)) ,(serialize-datum (cdr d)))]
|
||||
[(null? d) '()]
|
||||
[(exn? d) `(make-exn ,(exn-message d) (current-continuation-marks))]
|
||||
[(syntax? d) `(datum->syntax-object #f ',(syntax-object->datum d))]
|
||||
#;[(syntax? d) `(eval (quote ,(compile `(,#'quote-syntax ,d))))]
|
||||
[else (error 'serialize-datum "got ~s" d)]))
|
||||
|
||||
(define (serialize-context-frame frame)
|
||||
(cons (car frame)
|
||||
(if (cdr frame)
|
||||
(serialize-srcloc (cdr frame))
|
||||
null)))
|
||||
|
||||
(define (serialize-srcloc s)
|
||||
(list (let ([src (srcloc-source s)])
|
||||
(cond [(path? src) (path->string src)]
|
||||
[(string? src) src]
|
||||
[else '?]))
|
||||
(srcloc-line s)
|
||||
(srcloc-column s)))
|
||||
|
||||
(define (load-debug-file file)
|
||||
(parameterize ((read-accept-compiled #t))
|
||||
(with-input-from-file file
|
||||
(lambda ()
|
||||
(let* ([events-expr (read)]
|
||||
[exnmsg (read)]
|
||||
[ctx (read)])
|
||||
(let ([events (eval events-expr)])
|
||||
(values events exnmsg ctx)))))))
|
||||
)
|
||||
(let* ([events-expr (read)]
|
||||
[exnmsg (read)]
|
||||
[ctx (read)])
|
||||
(let ([events (eval events-expr)])
|
||||
(values events exnmsg ctx)))))))
|
||||
|
|
|
|||
|
|
@ -1,35 +1,34 @@
|
|||
|
||||
(module debug mzscheme
|
||||
(require (lib "pretty.ss")
|
||||
(lib "class.ss")
|
||||
"debug-format.ss"
|
||||
"prefs.ss"
|
||||
"view.ss")
|
||||
(provide debug-file)
|
||||
#lang scheme/base
|
||||
(require scheme/pretty
|
||||
scheme/class
|
||||
"debug-format.ss"
|
||||
"prefs.ss"
|
||||
"view.ss")
|
||||
(provide debug-file)
|
||||
|
||||
(define (widget-mixin %)
|
||||
(class %
|
||||
(define/override (top-interaction-kw? x)
|
||||
(eq? (syntax-e x) '#%top-interaction))
|
||||
(super-new)))
|
||||
(define (widget-mixin %)
|
||||
(class %
|
||||
(define/override (top-interaction-kw? x)
|
||||
(eq? (syntax-e x) '#%top-interaction))
|
||||
(super-new)))
|
||||
|
||||
(define stepper-frame%
|
||||
(class macro-stepper-frame%
|
||||
(define/override (get-macro-stepper-widget%)
|
||||
(widget-mixin (super get-macro-stepper-widget%)))
|
||||
(super-new)))
|
||||
(define stepper-frame%
|
||||
(class macro-stepper-frame%
|
||||
(define/override (get-macro-stepper-widget%)
|
||||
(widget-mixin (super get-macro-stepper-widget%)))
|
||||
(super-new)))
|
||||
|
||||
(define (make-stepper)
|
||||
(let ([f (new macro-stepper-frame%
|
||||
(config (new macro-stepper-config/prefs%)))])
|
||||
(send f show #t)
|
||||
(send f get-widget)))
|
||||
(define (make-stepper)
|
||||
(let ([f (new macro-stepper-frame%
|
||||
(config (new macro-stepper-config/prefs%)))])
|
||||
(send f show #t)
|
||||
(send f get-widget)))
|
||||
|
||||
(define (debug-file file)
|
||||
(let-values ([(events msg ctx) (load-debug-file file)])
|
||||
(pretty-print msg)
|
||||
(pretty-print ctx)
|
||||
(let* ([w (make-stepper)])
|
||||
(send w add-trace events)
|
||||
w)))
|
||||
)
|
||||
(define (debug-file file)
|
||||
(let-values ([(events msg ctx) (load-debug-file file)])
|
||||
(pretty-print msg)
|
||||
(pretty-print ctx)
|
||||
(let* ([w (make-stepper)])
|
||||
(send w add-trace events)
|
||||
w)))
|
||||
|
|
|
|||
|
|
@ -1,112 +1,111 @@
|
|||
|
||||
(module extensions mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "unit.ss")
|
||||
(lib "list.ss")
|
||||
(lib "plt-match.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "boundmap.ss" "syntax")
|
||||
"interfaces.ss"
|
||||
"prefs.ss"
|
||||
"warning.ss"
|
||||
"hiding-panel.ss"
|
||||
(prefix s: "../syntax-browser/widget.ss")
|
||||
"../model/deriv.ss"
|
||||
"../model/deriv-util.ss"
|
||||
"../model/trace.ss"
|
||||
"../model/hide.ss"
|
||||
"../model/steps.ss"
|
||||
"cursor.ss"
|
||||
"util.ss")
|
||||
(provide stepper-keymap%
|
||||
stepper-context-menu%
|
||||
stepper-syntax-widget%)
|
||||
#lang scheme/base
|
||||
(require scheme/class
|
||||
scheme/unit
|
||||
scheme/list
|
||||
scheme/match
|
||||
scheme/gui
|
||||
framework/framework
|
||||
syntax/boundmap
|
||||
"interfaces.ss"
|
||||
"prefs.ss"
|
||||
"warning.ss"
|
||||
"hiding-panel.ss"
|
||||
(prefix-in s: "../syntax-browser/widget.ss")
|
||||
"../model/deriv.ss"
|
||||
"../model/deriv-util.ss"
|
||||
"../model/trace.ss"
|
||||
"../model/hide.ss"
|
||||
"../model/steps.ss"
|
||||
"cursor.ss"
|
||||
"../util/notify.ss")
|
||||
(provide stepper-keymap%
|
||||
stepper-context-menu%
|
||||
stepper-syntax-widget%)
|
||||
|
||||
;; Extensions
|
||||
;; Extensions
|
||||
|
||||
(define stepper-keymap%
|
||||
(class s:widget-keymap%
|
||||
(init-field macro-stepper)
|
||||
(inherit-field controller)
|
||||
(inherit add-function)
|
||||
(define stepper-keymap%
|
||||
(class s:widget-keymap%
|
||||
(init-field macro-stepper)
|
||||
(inherit-field controller)
|
||||
(inherit add-function)
|
||||
|
||||
(super-new)
|
||||
(super-new)
|
||||
|
||||
(define/override (get-context-menu%)
|
||||
stepper-context-menu%)
|
||||
(define/override (get-context-menu%)
|
||||
stepper-context-menu%)
|
||||
|
||||
(define/public (get-hiding-panel)
|
||||
(send macro-stepper get-macro-hiding-prefs))
|
||||
(define/public (get-hiding-panel)
|
||||
(send macro-stepper get-macro-hiding-prefs))
|
||||
|
||||
(add-function "hiding:show-macro"
|
||||
(lambda (i e)
|
||||
(send* (get-hiding-panel)
|
||||
(add-show-identifier)
|
||||
(refresh))))
|
||||
|
||||
(add-function "hiding:hide-macro"
|
||||
(lambda (i e)
|
||||
(send* (get-hiding-panel)
|
||||
(add-hide-identifier)
|
||||
(refresh))))))
|
||||
(add-function "hiding:show-macro"
|
||||
(lambda (i e)
|
||||
(send* (get-hiding-panel)
|
||||
(add-show-identifier)
|
||||
(refresh))))
|
||||
|
||||
(add-function "hiding:hide-macro"
|
||||
(lambda (i e)
|
||||
(send* (get-hiding-panel)
|
||||
(add-hide-identifier)
|
||||
(refresh))))))
|
||||
|
||||
(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)
|
||||
(callback (lambda (i e)
|
||||
(send keymap call-function "hiding:show-macro" i e)))))
|
||||
(set! hide-macro
|
||||
(new menu-item% (label "Hide this macro") (parent this)
|
||||
(callback (lambda (i e)
|
||||
(send keymap call-function "hiding:hide-macro" i e)))))
|
||||
(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 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)
|
||||
(callback (lambda (i e)
|
||||
(send keymap call-function "hiding:show-macro" i e)))))
|
||||
(set! hide-macro
|
||||
(new menu-item% (label "Hide this macro") (parent this)
|
||||
(callback (lambda (i e)
|
||||
(send keymap call-function "hiding:hide-macro" i e)))))
|
||||
(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))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define stepper-syntax-widget%
|
||||
(class s:widget%
|
||||
(init-field macro-stepper)
|
||||
(inherit get-text)
|
||||
(super-new)))
|
||||
|
||||
(define/override (setup-keymap)
|
||||
(new stepper-keymap%
|
||||
(editor (get-text))
|
||||
(widget this)
|
||||
(macro-stepper macro-stepper)))
|
||||
(define stepper-syntax-widget%
|
||||
(class s:widget%
|
||||
(init-field macro-stepper)
|
||||
(inherit get-text)
|
||||
|
||||
(define/override (show-props show?)
|
||||
(super show-props show?)
|
||||
(send macro-stepper update/preserve-view))
|
||||
(define/override (setup-keymap)
|
||||
(new stepper-keymap%
|
||||
(editor (get-text))
|
||||
(widget this)
|
||||
(macro-stepper macro-stepper)))
|
||||
|
||||
(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)))
|
||||
)
|
||||
(define/override (show-props show?)
|
||||
(super show-props show?)
|
||||
(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)))
|
||||
|
|
|
|||
|
|
@ -1,236 +1,234 @@
|
|||
|
||||
(module frame mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "unit.ss")
|
||||
(lib "list.ss")
|
||||
(lib "file.ss")
|
||||
(lib "plt-match.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "boundmap.ss" "syntax")
|
||||
"interfaces.ss"
|
||||
"stepper.ss"
|
||||
"prefs.ss"
|
||||
"warning.ss"
|
||||
"hiding-panel.ss"
|
||||
(prefix sb: "../syntax-browser/embed.ss")
|
||||
(prefix sb: "../syntax-browser/params.ss")
|
||||
"../model/deriv.ss"
|
||||
"../model/deriv-util.ss"
|
||||
"../model/trace.ss"
|
||||
"../model/hide.ss"
|
||||
"../model/steps.ss"
|
||||
"cursor.ss"
|
||||
"util.ss")
|
||||
(provide macro-stepper-frame-mixin)
|
||||
#lang scheme/base
|
||||
(require scheme/class
|
||||
scheme/unit
|
||||
scheme/list
|
||||
scheme/file
|
||||
scheme/match
|
||||
scheme/gui
|
||||
framework/framework
|
||||
syntax/boundmap
|
||||
"interfaces.ss"
|
||||
"stepper.ss"
|
||||
"prefs.ss"
|
||||
"warning.ss"
|
||||
"hiding-panel.ss"
|
||||
(prefix-in sb: "../syntax-browser/embed.ss")
|
||||
(prefix-in sb: "../syntax-browser/params.ss")
|
||||
"../model/deriv.ss"
|
||||
"../model/deriv-util.ss"
|
||||
"../model/trace.ss"
|
||||
"../model/hide.ss"
|
||||
"../model/steps.ss"
|
||||
"cursor.ss"
|
||||
"../util/notify.ss")
|
||||
(provide macro-stepper-frame-mixin)
|
||||
|
||||
(define (macro-stepper-frame-mixin base-frame%)
|
||||
(class base-frame%
|
||||
(init-field config)
|
||||
(init-field (filename #f))
|
||||
(define (macro-stepper-frame-mixin base-frame%)
|
||||
(class base-frame%
|
||||
(init-field config)
|
||||
(init-field (filename #f))
|
||||
|
||||
(define obsoleted? #f)
|
||||
(define obsoleted? #f)
|
||||
|
||||
(inherit get-area-container
|
||||
set-label
|
||||
get-menu%
|
||||
get-menu-item%
|
||||
get-menu-bar
|
||||
get-file-menu
|
||||
get-edit-menu
|
||||
get-help-menu)
|
||||
(inherit get-area-container
|
||||
set-label
|
||||
get-menu%
|
||||
get-menu-item%
|
||||
get-menu-bar
|
||||
get-file-menu
|
||||
get-edit-menu
|
||||
get-help-menu)
|
||||
|
||||
(super-new (label (make-label))
|
||||
(width (send config get-width))
|
||||
(height (send config get-height)))
|
||||
(super-new (label (make-label))
|
||||
(width (send config get-width))
|
||||
(height (send config get-height)))
|
||||
|
||||
(define/private (make-label)
|
||||
(if filename
|
||||
(string-append (path->string
|
||||
(file-name-from-path filename))
|
||||
(if obsoleted? " (old)" "")
|
||||
" - Macro stepper")
|
||||
"Macro stepper"))
|
||||
(define/private (make-label)
|
||||
(if filename
|
||||
(string-append (path->string
|
||||
(file-name-from-path filename))
|
||||
(if obsoleted? " (old)" "")
|
||||
" - Macro stepper")
|
||||
"Macro stepper"))
|
||||
|
||||
(define/override (on-size w h)
|
||||
(send config set-width w)
|
||||
(send config set-height h)
|
||||
(send widget update/preserve-view))
|
||||
(define/override (on-size w h)
|
||||
(send config set-width w)
|
||||
(send config set-height h)
|
||||
(send widget update/preserve-view))
|
||||
|
||||
(override/return-false file-menu:create-new?
|
||||
file-menu:create-open?
|
||||
file-menu:create-open-recent?
|
||||
file-menu:create-revert?
|
||||
file-menu:create-save?
|
||||
file-menu:create-save-as?
|
||||
;file-menu:create-print?
|
||||
edit-menu:create-undo?
|
||||
edit-menu:create-redo?
|
||||
;edit-menu:create-cut?
|
||||
;edit-menu:create-paste?
|
||||
edit-menu:create-clear?
|
||||
;edit-menu:create-find?
|
||||
;edit-menu:create-find-again?
|
||||
edit-menu:create-replace-and-find-again?)
|
||||
(override/return-false file-menu:create-new?
|
||||
file-menu:create-open?
|
||||
file-menu:create-open-recent?
|
||||
file-menu:create-revert?
|
||||
file-menu:create-save?
|
||||
file-menu:create-save-as?
|
||||
;file-menu:create-print?
|
||||
edit-menu:create-undo?
|
||||
edit-menu:create-redo?
|
||||
;edit-menu:create-cut?
|
||||
;edit-menu:create-paste?
|
||||
edit-menu:create-clear?
|
||||
;edit-menu:create-find?
|
||||
;edit-menu:create-find-again?
|
||||
edit-menu:create-replace-and-find-again?)
|
||||
|
||||
(define file-menu (get-file-menu))
|
||||
(define edit-menu (get-edit-menu))
|
||||
(define stepper-menu
|
||||
(new (get-menu%) (parent (get-menu-bar)) (label "Stepper")))
|
||||
(define help-menu (get-help-menu))
|
||||
(define file-menu (get-file-menu))
|
||||
(define edit-menu (get-edit-menu))
|
||||
(define stepper-menu
|
||||
(new (get-menu%) (parent (get-menu-bar)) (label "Stepper")))
|
||||
(define help-menu (get-help-menu))
|
||||
|
||||
(define warning-panel
|
||||
(new horizontal-panel%
|
||||
(parent (get-area-container))
|
||||
(stretchable-height #f)
|
||||
(style '(deleted))))
|
||||
(define warning-panel
|
||||
(new horizontal-panel%
|
||||
(parent (get-area-container))
|
||||
(stretchable-height #f)
|
||||
(style '(deleted))))
|
||||
|
||||
(define/public (get-macro-stepper-widget%)
|
||||
macro-stepper-widget%)
|
||||
(define/public (get-macro-stepper-widget%)
|
||||
macro-stepper-widget%)
|
||||
|
||||
(define widget
|
||||
(new (get-macro-stepper-widget%)
|
||||
(parent (get-area-container))
|
||||
(config config)))
|
||||
(define widget
|
||||
(new (get-macro-stepper-widget%)
|
||||
(parent (get-area-container))
|
||||
(config config)))
|
||||
|
||||
(define/public (get-widget) widget)
|
||||
(define/public (get-widget) widget)
|
||||
|
||||
(define/public (add-obsoleted-warning)
|
||||
(unless obsoleted?
|
||||
(set! obsoleted? #t)
|
||||
(new warning-canvas%
|
||||
(warning
|
||||
(string-append
|
||||
"Warning: This macro stepper session is obsolete. "
|
||||
"The program may have changed."))
|
||||
(parent warning-panel))
|
||||
(set-label (make-label))
|
||||
(send (get-area-container) change-children
|
||||
(lambda (children)
|
||||
(cons warning-panel
|
||||
(remq warning-panel children))))))
|
||||
(define/public (add-obsoleted-warning)
|
||||
(unless obsoleted?
|
||||
(set! obsoleted? #t)
|
||||
(new warning-canvas%
|
||||
(warning
|
||||
(string-append
|
||||
"Warning: This macro stepper session is obsolete. "
|
||||
"The program may have changed."))
|
||||
(parent warning-panel))
|
||||
(set-label (make-label))
|
||||
(send (get-area-container) change-children
|
||||
(lambda (children)
|
||||
(cons warning-panel
|
||||
(remq warning-panel children))))))
|
||||
|
||||
;; Set up menus
|
||||
;; Set up menus
|
||||
|
||||
(menu-option/notify-box stepper-menu
|
||||
"Show syntax properties"
|
||||
(get-field show-syntax-properties? config))
|
||||
(menu-option/notify-box stepper-menu
|
||||
"Show syntax properties"
|
||||
(get-field show-syntax-properties? config))
|
||||
|
||||
;; FIXME: rewrite with notify-box
|
||||
(let ([id-menu
|
||||
(new (get-menu%)
|
||||
(label "Identifier=?")
|
||||
(parent stepper-menu))])
|
||||
(for-each (lambda (p)
|
||||
(let ([this-choice
|
||||
(new checkable-menu-item%
|
||||
(label (car p))
|
||||
(parent id-menu)
|
||||
(callback
|
||||
(lambda _
|
||||
(send (send widget get-controller)
|
||||
set-identifier=? p))))])
|
||||
(send (send widget get-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))))
|
||||
;; FIXME: rewrite with notify-box
|
||||
(let ([id-menu
|
||||
(new (get-menu%)
|
||||
(label "Identifier=?")
|
||||
(parent stepper-menu))])
|
||||
(for-each (lambda (p)
|
||||
(let ([this-choice
|
||||
(new checkable-menu-item%
|
||||
(label (car p))
|
||||
(parent id-menu)
|
||||
(callback
|
||||
(lambda _
|
||||
(send (send widget get-controller)
|
||||
set-identifier=? p))))])
|
||||
(send (send widget get-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))))
|
||||
|
||||
(new (get-menu-item%)
|
||||
(label "Clear selection")
|
||||
(parent stepper-menu)
|
||||
(new (get-menu-item%)
|
||||
(label "Clear selection")
|
||||
(parent stepper-menu)
|
||||
(callback
|
||||
(lambda _ (send (send widget get-controller) select-syntax #f))))
|
||||
(new separator-menu-item% (parent stepper-menu))
|
||||
|
||||
(menu-option/notify-box stepper-menu
|
||||
"Show macro hiding panel"
|
||||
(get-field show-hiding-panel? config))
|
||||
#;
|
||||
(new (get-menu-item%)
|
||||
(label "Show in new frame")
|
||||
(parent stepper-menu)
|
||||
(callback (lambda _ (send widget show-in-new-frame))))
|
||||
(new (get-menu-item%)
|
||||
(label "Remove selected term")
|
||||
(parent stepper-menu)
|
||||
(callback (lambda _ (send widget remove-current-term))))
|
||||
(new (get-menu-item%)
|
||||
(label "Reset mark numbering")
|
||||
(parent stepper-menu)
|
||||
(callback (lambda _ (send widget reset-primary-partition))))
|
||||
(let ([extras-menu
|
||||
(new (get-menu%)
|
||||
(label "Extra options")
|
||||
(parent stepper-menu))])
|
||||
(new checkable-menu-item%
|
||||
(label "Always suffix marked identifiers")
|
||||
(parent extras-menu)
|
||||
(callback
|
||||
(lambda _ (send (send widget get-controller) select-syntax #f))))
|
||||
(new separator-menu-item% (parent stepper-menu))
|
||||
(lambda (i e)
|
||||
(sb:current-suffix-option
|
||||
(if (send i is-checked?)
|
||||
'always
|
||||
'over-limit))
|
||||
(send widget update/preserve-view))))
|
||||
(menu-option/notify-box extras-menu
|
||||
"Highlight redex/contractum"
|
||||
(get-field highlight-foci? config))
|
||||
(menu-option/notify-box extras-menu
|
||||
"Highlight frontier"
|
||||
(get-field highlight-frontier? config))
|
||||
(menu-option/notify-box extras-menu
|
||||
"Include renaming steps"
|
||||
(get-field show-rename-steps? config))
|
||||
(menu-option/notify-box extras-menu
|
||||
"One term at a time"
|
||||
(get-field one-by-one? config))
|
||||
(menu-option/notify-box extras-menu
|
||||
"Suppress warnings"
|
||||
(get-field suppress-warnings? config))
|
||||
(menu-option/notify-box extras-menu
|
||||
"Extra navigation"
|
||||
(get-field extra-navigation? config))
|
||||
(menu-option/notify-box extras-menu
|
||||
"Force block->letrec transformation"
|
||||
(get-field force-letrec-transformation? config))
|
||||
(menu-option/notify-box extras-menu
|
||||
"(Debug) Catch internal errors?"
|
||||
(get-field debug-catch-errors? config)))
|
||||
|
||||
(menu-option/notify-box stepper-menu
|
||||
"Show macro hiding panel"
|
||||
(get-field show-hiding-panel? config))
|
||||
#;
|
||||
(new (get-menu-item%)
|
||||
(label "Show in new frame")
|
||||
(parent stepper-menu)
|
||||
(callback (lambda _ (send widget show-in-new-frame))))
|
||||
(new (get-menu-item%)
|
||||
(label "Remove selected term")
|
||||
(parent stepper-menu)
|
||||
(callback (lambda _ (send widget remove-current-term))))
|
||||
(new (get-menu-item%)
|
||||
(label "Reset mark numbering")
|
||||
(parent stepper-menu)
|
||||
(callback (lambda _ (send widget reset-primary-partition))))
|
||||
(let ([extras-menu
|
||||
(new (get-menu%)
|
||||
(label "Extra options")
|
||||
(parent stepper-menu))])
|
||||
(new checkable-menu-item%
|
||||
(label "Always suffix marked identifiers")
|
||||
(parent extras-menu)
|
||||
(callback
|
||||
(lambda (i e)
|
||||
(sb:current-suffix-option
|
||||
(if (send i is-checked?)
|
||||
'always
|
||||
'over-limit))
|
||||
(send widget update/preserve-view))))
|
||||
(menu-option/notify-box extras-menu
|
||||
"Highlight redex/contractum"
|
||||
(get-field highlight-foci? config))
|
||||
(menu-option/notify-box extras-menu
|
||||
"Highlight frontier"
|
||||
(get-field highlight-frontier? config))
|
||||
(menu-option/notify-box extras-menu
|
||||
"Include renaming steps"
|
||||
(get-field show-rename-steps? config))
|
||||
(menu-option/notify-box extras-menu
|
||||
"One term at a time"
|
||||
(get-field one-by-one? config))
|
||||
(menu-option/notify-box extras-menu
|
||||
"Suppress warnings"
|
||||
(get-field suppress-warnings? config))
|
||||
(menu-option/notify-box extras-menu
|
||||
"Extra navigation"
|
||||
(get-field extra-navigation? config))
|
||||
(menu-option/notify-box extras-menu
|
||||
"Force block->letrec transformation"
|
||||
(get-field force-letrec-transformation? config))
|
||||
(menu-option/notify-box extras-menu
|
||||
"(Debug) Catch internal errors?"
|
||||
(get-field debug-catch-errors? config)))
|
||||
(frame:reorder-menus this)))
|
||||
|
||||
(frame:reorder-menus this)))
|
||||
;; Stolen from stepper
|
||||
|
||||
;; Stolen from stepper
|
||||
(define warning-color "yellow")
|
||||
(define warning-font normal-control-font)
|
||||
|
||||
(define warning-color "yellow")
|
||||
(define warning-font normal-control-font)
|
||||
|
||||
(define warning-canvas%
|
||||
(class canvas%
|
||||
(init-field warning)
|
||||
(inherit get-dc get-client-size)
|
||||
(define/override (on-paint)
|
||||
(let ([dc (get-dc)])
|
||||
(send dc set-font warning-font)
|
||||
(let-values ([(cw ch) (get-client-size)]
|
||||
[(tw th dont-care dont-care2) (send dc get-text-extent warning)])
|
||||
(send dc set-pen (send the-pen-list find-or-create-pen warning-color 1 'solid))
|
||||
(send dc set-brush (send the-brush-list find-or-create-brush warning-color 'solid))
|
||||
(send dc draw-rectangle 0 0 cw ch)
|
||||
(send dc draw-text
|
||||
warning
|
||||
(- (/ cw 2) (/ tw 2))
|
||||
(- (/ ch 2) (/ th 2))))))
|
||||
(super-new)
|
||||
(inherit min-width min-height stretchable-height)
|
||||
(let-values ([(tw th dc dc2) (send (get-dc) get-text-extent warning warning-font)])
|
||||
(min-width (+ 2 (inexact->exact (ceiling tw))))
|
||||
(min-height (+ 2 (inexact->exact (ceiling th)))))
|
||||
(stretchable-height #f)))
|
||||
|
||||
)
|
||||
(define warning-canvas%
|
||||
(class canvas%
|
||||
(init-field warning)
|
||||
(inherit get-dc get-client-size)
|
||||
(define/override (on-paint)
|
||||
(let ([dc (get-dc)])
|
||||
(send dc set-font warning-font)
|
||||
(let-values ([(cw ch) (get-client-size)]
|
||||
[(tw th dont-care dont-care2) (send dc get-text-extent warning)])
|
||||
(send dc set-pen (send the-pen-list find-or-create-pen warning-color 1 'solid))
|
||||
(send dc set-brush (send the-brush-list find-or-create-brush warning-color 'solid))
|
||||
(send dc draw-rectangle 0 0 cw ch)
|
||||
(send dc draw-text
|
||||
warning
|
||||
(- (/ cw 2) (/ tw 2))
|
||||
(- (/ ch 2) (/ th 2))))))
|
||||
(super-new)
|
||||
(inherit min-width min-height stretchable-height)
|
||||
(let-values ([(tw th dc dc2) (send (get-dc) get-text-extent warning warning-font)])
|
||||
(min-width (+ 2 (inexact->exact (ceiling tw))))
|
||||
(min-height (+ 2 (inexact->exact (ceiling th)))))
|
||||
(stretchable-height #f)))
|
||||
|
|
|
|||
|
|
@ -1,320 +1,319 @@
|
|||
|
||||
(module hiding-panel mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "list.ss")
|
||||
(lib "boundmap.ss" "syntax")
|
||||
"util.ss"
|
||||
"../model/synth-engine.ss"
|
||||
"../syntax-browser/util.ss"
|
||||
"../util/hiding.ss")
|
||||
(provide macro-hiding-prefs-widget%)
|
||||
#lang scheme/base
|
||||
(require scheme/class
|
||||
scheme/gui
|
||||
scheme/list
|
||||
syntax/boundmap
|
||||
"../model/synth-engine.ss"
|
||||
"../syntax-browser/util.ss"
|
||||
"../util/notify.ss"
|
||||
"../util/hiding.ss")
|
||||
(provide macro-hiding-prefs-widget%)
|
||||
|
||||
(define mode:disable "Disable")
|
||||
(define mode:standard "Standard")
|
||||
(define mode:custom "Custom ...")
|
||||
(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 (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))
|
||||
(define standard-policy
|
||||
(make-policy #t #t #t #t null))
|
||||
|
||||
;; macro-hiding-prefs-widget%
|
||||
(define macro-hiding-prefs-widget%
|
||||
(class object%
|
||||
(init parent)
|
||||
(init-field stepper)
|
||||
(init-field config)
|
||||
;; macro-hiding-prefs-widget%
|
||||
(define macro-hiding-prefs-widget%
|
||||
(class object%
|
||||
(init parent)
|
||||
(init-field stepper)
|
||||
(init-field config)
|
||||
|
||||
(define/public (get-policy)
|
||||
(let ([mode (get-mode)])
|
||||
(cond [(not (macro-hiding-enabled?)) #f]
|
||||
[(equal? mode mode:standard) standard-policy]
|
||||
[(equal? mode mode:custom) (get-custom-policy)])))
|
||||
(define/public (get-policy)
|
||||
(let ([mode (get-mode)])
|
||||
(cond [(not (macro-hiding-enabled?)) #f]
|
||||
[(equal? mode mode:standard) standard-policy]
|
||||
[(equal? mode mode:custom) (get-custom-policy)])))
|
||||
|
||||
(define/private (get-custom-policy)
|
||||
(let ([hide-mzscheme? (send box:hide-mzscheme get-value)]
|
||||
[hide-libs? (send box:hide-libs get-value)]
|
||||
[hide-contracts? (send box:hide-contracts get-value)]
|
||||
[hide-transformers? (send box:hide-phase1 get-value)]
|
||||
[specialized-policies (get-specialized-policies)])
|
||||
(make-policy hide-mzscheme?
|
||||
hide-libs?
|
||||
hide-contracts?
|
||||
hide-transformers?
|
||||
specialized-policies)))
|
||||
(define/private (get-custom-policy)
|
||||
(let ([hide-mzscheme? (send box:hide-mzscheme get-value)]
|
||||
[hide-libs? (send box:hide-libs get-value)]
|
||||
[hide-contracts? (send box:hide-contracts get-value)]
|
||||
[hide-transformers? (send box:hide-phase1 get-value)]
|
||||
[specialized-policies (get-specialized-policies)])
|
||||
(make-policy hide-mzscheme?
|
||||
hide-libs?
|
||||
hide-contracts?
|
||||
hide-transformers?
|
||||
specialized-policies)))
|
||||
|
||||
(define super-panel
|
||||
(new vertical-panel%
|
||||
(parent parent)
|
||||
(stretchable-height #f)))
|
||||
(define top-line-panel
|
||||
(new horizontal-panel%
|
||||
(parent super-panel)
|
||||
(alignment '(left center))
|
||||
(stretchable-height #f)))
|
||||
(define customize-panel
|
||||
(new horizontal-panel%
|
||||
(parent super-panel)
|
||||
(stretchable-height #f)
|
||||
(alignment '(left top))
|
||||
(style '(deleted))))
|
||||
(define left-pane
|
||||
(new vertical-pane%
|
||||
(parent customize-panel)
|
||||
(stretchable-width #f)
|
||||
(alignment '(left top))))
|
||||
(define right-pane
|
||||
(new vertical-pane%
|
||||
(parent customize-panel)))
|
||||
(define super-panel
|
||||
(new vertical-panel%
|
||||
(parent parent)
|
||||
(stretchable-height #f)))
|
||||
(define top-line-panel
|
||||
(new horizontal-panel%
|
||||
(parent super-panel)
|
||||
(alignment '(left center))
|
||||
(stretchable-height #f)))
|
||||
(define customize-panel
|
||||
(new horizontal-panel%
|
||||
(parent super-panel)
|
||||
(stretchable-height #f)
|
||||
(alignment '(left top))
|
||||
(style '(deleted))))
|
||||
(define left-pane
|
||||
(new vertical-pane%
|
||||
(parent customize-panel)
|
||||
(stretchable-width #f)
|
||||
(alignment '(left top))))
|
||||
(define right-pane
|
||||
(new vertical-pane%
|
||||
(parent customize-panel)))
|
||||
|
||||
(define mode-selector
|
||||
(choice/notify-box
|
||||
top-line-panel
|
||||
"Macro hiding: "
|
||||
(list mode:disable mode:standard mode:custom)
|
||||
(get-field macro-hiding-mode config)))
|
||||
(define top-line-inner-panel
|
||||
(new horizontal-panel%
|
||||
(parent top-line-panel)
|
||||
(alignment '(right center))
|
||||
(style '(deleted))))
|
||||
(define mode-selector
|
||||
(choice/notify-box
|
||||
top-line-panel
|
||||
"Macro hiding: "
|
||||
(list mode:disable mode:standard mode:custom)
|
||||
(get-field macro-hiding-mode config)))
|
||||
(define top-line-inner-panel
|
||||
(new horizontal-panel%
|
||||
(parent top-line-panel)
|
||||
(alignment '(right center))
|
||||
(style '(deleted))))
|
||||
|
||||
(define/private (get-mode)
|
||||
(send config get-macro-hiding-mode))
|
||||
(define/private (get-mode)
|
||||
(send config get-macro-hiding-mode))
|
||||
|
||||
(define/private (macro-hiding-enabled?)
|
||||
(let ([mode (get-mode)])
|
||||
(or (equal? mode mode:standard)
|
||||
(and (equal? mode mode:custom)
|
||||
(send box:hiding get-value)))))
|
||||
(define/private (macro-hiding-enabled?)
|
||||
(let ([mode (get-mode)])
|
||||
(or (equal? mode mode:standard)
|
||||
(and (equal? mode mode:custom)
|
||||
(send box:hiding get-value)))))
|
||||
|
||||
(define/private (ensure-custom-mode)
|
||||
(unless (equal? (get-mode) mode:custom)
|
||||
(send config set-macro-hiding-mode mode:custom)))
|
||||
(define/private (ensure-custom-mode)
|
||||
(unless (equal? (get-mode) mode:custom)
|
||||
(send config set-macro-hiding-mode mode:custom)))
|
||||
|
||||
(define/private (update-visibility)
|
||||
(let ([customizing (equal? (get-mode) mode:custom)])
|
||||
(send top-line-panel change-children
|
||||
(lambda (children)
|
||||
(append (remq top-line-inner-panel children)
|
||||
(if customizing (list top-line-inner-panel) null))))
|
||||
(send super-panel change-children
|
||||
(lambda (children)
|
||||
(append (remq customize-panel children)
|
||||
(if (and customizing (send box:edit get-value))
|
||||
(list customize-panel)
|
||||
null))))))
|
||||
(define/private (update-visibility)
|
||||
(let ([customizing (equal? (get-mode) mode:custom)])
|
||||
(send top-line-panel change-children
|
||||
(lambda (children)
|
||||
(append (remq top-line-inner-panel children)
|
||||
(if customizing (list top-line-inner-panel) null))))
|
||||
(send super-panel change-children
|
||||
(lambda (children)
|
||||
(append (remq customize-panel children)
|
||||
(if (and customizing (send box:edit get-value))
|
||||
(list customize-panel)
|
||||
null))))))
|
||||
|
||||
(send config listen-macro-hiding-mode
|
||||
(lambda (value)
|
||||
(update-visibility)
|
||||
(force-refresh)))
|
||||
(send config listen-macro-hiding-mode
|
||||
(lambda (value)
|
||||
(update-visibility)
|
||||
(force-refresh)))
|
||||
|
||||
(define box:hiding
|
||||
(new check-box%
|
||||
(label "Enable macro hiding")
|
||||
(value #t)
|
||||
(parent top-line-inner-panel)
|
||||
(callback (lambda (c e) (force-refresh)))))
|
||||
(define box:edit
|
||||
(new check-box%
|
||||
(label "Show policy editor")
|
||||
(parent top-line-inner-panel)
|
||||
(value #t)
|
||||
(callback (lambda (c e) (update-visibility)))))
|
||||
(define box:hiding
|
||||
(new check-box%
|
||||
(label "Enable macro hiding")
|
||||
(value #t)
|
||||
(parent top-line-inner-panel)
|
||||
(callback (lambda (c e) (force-refresh)))))
|
||||
(define box:edit
|
||||
(new check-box%
|
||||
(label "Show policy editor")
|
||||
(parent top-line-inner-panel)
|
||||
(value #t)
|
||||
(callback (lambda (c e) (update-visibility)))))
|
||||
|
||||
(define box:hide-mzscheme
|
||||
(new check-box%
|
||||
(label "Hide mzscheme syntax")
|
||||
(parent left-pane)
|
||||
(value #t)
|
||||
(callback (lambda (c e) (refresh)))))
|
||||
(define box:hide-libs
|
||||
(new check-box%
|
||||
(label "Hide library syntax")
|
||||
(parent left-pane)
|
||||
(value #t)
|
||||
(callback (lambda (c e) (refresh)))))
|
||||
(define box:hide-contracts
|
||||
(new check-box%
|
||||
(label "Hide contracts (heuristic)")
|
||||
(parent left-pane)
|
||||
(value #t)
|
||||
(callback (lambda (c e) (refresh)))))
|
||||
(define box:hide-phase1
|
||||
(new check-box%
|
||||
(label "Hide phase>0")
|
||||
(parent left-pane)
|
||||
(value #t)
|
||||
(callback (lambda (c e) (refresh)))))
|
||||
(define box:hide-mzscheme
|
||||
(new check-box%
|
||||
(label "Hide mzscheme syntax")
|
||||
(parent left-pane)
|
||||
(value #t)
|
||||
(callback (lambda (c e) (refresh)))))
|
||||
(define box:hide-libs
|
||||
(new check-box%
|
||||
(label "Hide library syntax")
|
||||
(parent left-pane)
|
||||
(value #t)
|
||||
(callback (lambda (c e) (refresh)))))
|
||||
(define box:hide-contracts
|
||||
(new check-box%
|
||||
(label "Hide contracts (heuristic)")
|
||||
(parent left-pane)
|
||||
(value #t)
|
||||
(callback (lambda (c e) (refresh)))))
|
||||
(define box:hide-phase1
|
||||
(new check-box%
|
||||
(label "Hide phase>0")
|
||||
(parent left-pane)
|
||||
(value #t)
|
||||
(callback (lambda (c e) (refresh)))))
|
||||
|
||||
(define look-ctl
|
||||
(new list-box% (parent right-pane) (label "")
|
||||
(choices null) (style '(extended))
|
||||
(callback
|
||||
(lambda (c e)
|
||||
(send delete-ctl enable (pair? (send c get-selections)))))))
|
||||
(define look-ctl
|
||||
(new list-box% (parent right-pane) (label "")
|
||||
(choices null) (style '(extended))
|
||||
(callback
|
||||
(lambda (c e)
|
||||
(send delete-ctl enable (pair? (send c get-selections)))))))
|
||||
|
||||
(define look-button-pane
|
||||
(new horizontal-pane% (parent right-pane) (stretchable-width #f)))
|
||||
(define look-button-pane
|
||||
(new horizontal-pane% (parent right-pane) (stretchable-width #f)))
|
||||
|
||||
(define delete-ctl
|
||||
(new button% (parent look-button-pane) (label "Delete rule") (enabled #f)
|
||||
(callback (lambda _ (delete-selected) (refresh)))))
|
||||
(define add-hide-id-button
|
||||
(new button% (parent look-button-pane) (label "Hide macro") (enabled #f)
|
||||
(callback (lambda _ (add-hide-identifier) (refresh)))))
|
||||
(define add-show-id-button
|
||||
(new button% (parent look-button-pane) (label "Show macro") (enabled #f)
|
||||
(callback (lambda _ (add-show-identifier) (refresh)))))
|
||||
#;(new grow-box-spacer-pane% (parent right-pane))
|
||||
(define delete-ctl
|
||||
(new button% (parent look-button-pane) (label "Delete rule") (enabled #f)
|
||||
(callback (lambda _ (delete-selected) (refresh)))))
|
||||
(define add-hide-id-button
|
||||
(new button% (parent look-button-pane) (label "Hide macro") (enabled #f)
|
||||
(callback (lambda _ (add-hide-identifier) (refresh)))))
|
||||
(define add-show-id-button
|
||||
(new button% (parent look-button-pane) (label "Show macro") (enabled #f)
|
||||
(callback (lambda _ (add-show-identifier) (refresh)))))
|
||||
#;(new grow-box-spacer-pane% (parent right-pane))
|
||||
|
||||
;; Methods
|
||||
;; Methods
|
||||
|
||||
(define stx #f)
|
||||
(define stx-name #f)
|
||||
(define stx #f)
|
||||
(define stx-name #f)
|
||||
|
||||
;; refresh : -> void
|
||||
(define/public (refresh)
|
||||
(when (macro-hiding-enabled?)
|
||||
(send stepper refresh/resynth)))
|
||||
;; refresh : -> void
|
||||
(define/public (refresh)
|
||||
(when (macro-hiding-enabled?)
|
||||
(send stepper refresh/resynth)))
|
||||
|
||||
;; force-refresh : -> void
|
||||
(define/private (force-refresh)
|
||||
(send stepper refresh/resynth))
|
||||
;; force-refresh : -> void
|
||||
(define/private (force-refresh)
|
||||
(send stepper refresh/resynth))
|
||||
|
||||
;; set-syntax : syntax/#f -> void
|
||||
(define/public (set-syntax lstx)
|
||||
(set! stx (and (identifier? lstx) lstx))
|
||||
(when (identifier? stx)
|
||||
(let ([binding (identifier-binding stx)])
|
||||
(if (pair? binding)
|
||||
(set! stx-name (cadr binding))
|
||||
(set! stx-name (syntax-e stx)))))
|
||||
(send add-show-id-button enable (identifier? lstx))
|
||||
(send add-hide-id-button enable (identifier? lstx)))
|
||||
;; set-syntax : syntax/#f -> void
|
||||
(define/public (set-syntax lstx)
|
||||
(set! stx (and (identifier? lstx) lstx))
|
||||
(when (identifier? stx)
|
||||
(let ([binding (identifier-binding stx)])
|
||||
(if (pair? binding)
|
||||
(set! stx-name (cadr binding))
|
||||
(set! stx-name (syntax-e stx)))))
|
||||
(send add-show-id-button enable (identifier? lstx))
|
||||
(send add-hide-id-button enable (identifier? lstx)))
|
||||
|
||||
(define identifier-policies null)
|
||||
(define identifier-policies null)
|
||||
|
||||
(define/private (get-specialized-policies)
|
||||
(map (lambda (policy)
|
||||
(define key (mcar policy))
|
||||
(define show? (mcdr policy))
|
||||
(cond [(pair? key)
|
||||
(lambda (id binding return)
|
||||
(when (and (pair? binding)
|
||||
(equal? key (get-id-key/binding id binding)))
|
||||
(return show?)))]
|
||||
[else
|
||||
(lambda (id binding return)
|
||||
(when (module-identifier=? id key)
|
||||
(return show?)))]))
|
||||
identifier-policies))
|
||||
(define/private (get-specialized-policies)
|
||||
(map (lambda (policy)
|
||||
(define key (mcar policy))
|
||||
(define show? (mcdr policy))
|
||||
(cond [(pair? key)
|
||||
(lambda (id binding return)
|
||||
(when (and (pair? binding)
|
||||
(equal? key (get-id-key/binding id binding)))
|
||||
(return show?)))]
|
||||
[else
|
||||
(lambda (id binding return)
|
||||
(when (free-identifier=? id key)
|
||||
(return show?)))]))
|
||||
identifier-policies))
|
||||
|
||||
(define/public (add-hide-identifier)
|
||||
(add-identifier-policy #f)
|
||||
(ensure-custom-mode))
|
||||
(define/public (add-hide-identifier)
|
||||
(add-identifier-policy #f)
|
||||
(ensure-custom-mode))
|
||||
|
||||
(define/public (add-show-identifier)
|
||||
(add-identifier-policy #t)
|
||||
(ensure-custom-mode))
|
||||
(define/public (add-show-identifier)
|
||||
(add-identifier-policy #t)
|
||||
(ensure-custom-mode))
|
||||
|
||||
(define/private (add-identifier-policy show?)
|
||||
(when (identifier? stx)
|
||||
(let ([key (get-id-key stx)])
|
||||
(let loop ([i 0] [policies identifier-policies])
|
||||
(cond [(null? policies)
|
||||
(set! identifier-policies
|
||||
(cons (mcons key show?) identifier-policies))
|
||||
(send look-ctl append "")
|
||||
(update-list-view i key show?)]
|
||||
[(key=? key (mcar (car policies)))
|
||||
(set-mcdr! (car policies) show?)
|
||||
(update-list-view i key show?)]
|
||||
[else (loop (add1 i) (cdr policies))])))))
|
||||
(define/private (add-identifier-policy show?)
|
||||
(when (identifier? stx)
|
||||
(let ([key (get-id-key stx)])
|
||||
(let loop ([i 0] [policies identifier-policies])
|
||||
(cond [(null? policies)
|
||||
(set! identifier-policies
|
||||
(cons (mcons key show?) identifier-policies))
|
||||
(send look-ctl append "")
|
||||
(update-list-view i key show?)]
|
||||
[(key=? key (mcar (car policies)))
|
||||
(set-mcdr! (car policies) show?)
|
||||
(update-list-view i key show?)]
|
||||
[else (loop (add1 i) (cdr policies))])))))
|
||||
|
||||
(define/private (update-list-view index key show?)
|
||||
(send look-ctl set-data index key)
|
||||
(send look-ctl set-string
|
||||
index
|
||||
(string-append (if show? "show " "hide ")
|
||||
(key->text key))))
|
||||
(define/private (update-list-view index key show?)
|
||||
(send look-ctl set-data index key)
|
||||
(send look-ctl set-string
|
||||
index
|
||||
(string-append (if show? "show " "hide ")
|
||||
(key->text key))))
|
||||
|
||||
(define/private (delete-selected)
|
||||
(define to-delete (sort (send look-ctl get-selections) <))
|
||||
(set! identifier-policies
|
||||
(let loop ([i 0] [policies identifier-policies] [to-delete to-delete])
|
||||
(cond [(null? to-delete) policies]
|
||||
[(= i (car to-delete))
|
||||
(loop (add1 i) (cdr policies) (cdr to-delete))]
|
||||
[else
|
||||
(cons (car policies)
|
||||
(loop (add1 i) (cdr policies) to-delete))])))
|
||||
(for-each (lambda (n) (send look-ctl delete n)) (reverse to-delete)))
|
||||
(define/private (delete-selected)
|
||||
(define to-delete (sort (send look-ctl get-selections) <))
|
||||
(set! identifier-policies
|
||||
(let loop ([i 0] [policies identifier-policies] [to-delete to-delete])
|
||||
(cond [(null? to-delete) policies]
|
||||
[(= i (car to-delete))
|
||||
(loop (add1 i) (cdr policies) (cdr to-delete))]
|
||||
[else
|
||||
(cons (car policies)
|
||||
(loop (add1 i) (cdr policies) to-delete))])))
|
||||
(for-each (lambda (n) (send look-ctl delete n)) (reverse to-delete)))
|
||||
|
||||
(super-new)
|
||||
(update-visibility)))
|
||||
(super-new)
|
||||
(update-visibility)))
|
||||
|
||||
(define (get-id-key id)
|
||||
id
|
||||
#; ;; FIXME
|
||||
(let ([binding (identifier-binding id)])
|
||||
(get-id-key/binding id binding)))
|
||||
(define (get-id-key id)
|
||||
id
|
||||
#; ;; FIXME
|
||||
(let ([binding (identifier-binding id)])
|
||||
(get-id-key/binding id binding)))
|
||||
|
||||
(define (get-id-key/binding id binding)
|
||||
(cond [(pair? binding)
|
||||
(list (car binding) (cadr binding))]
|
||||
[else id]))
|
||||
(define (get-id-key/binding id binding)
|
||||
(cond [(pair? binding)
|
||||
(list (car binding) (cadr binding))]
|
||||
[else id]))
|
||||
|
||||
(define (key=? key1 key2)
|
||||
(cond [(and (identifier? key1) (identifier? key2))
|
||||
(module-identifier=? key1 key2)]
|
||||
[(and (pair? key1) (pair? key2))
|
||||
(and (equal? (car key1) (car key2))
|
||||
(equal? (cadr key1) (cadr key2)))]
|
||||
[else #f]))
|
||||
(define (key=? key1 key2)
|
||||
(cond [(and (identifier? key1) (identifier? key2))
|
||||
(free-identifier=? key1 key2)]
|
||||
[(and (pair? key1) (pair? key2))
|
||||
(and (equal? (car key1) (car key2))
|
||||
(equal? (cadr key1) (cadr key2)))]
|
||||
[else #f]))
|
||||
|
||||
(define (key->text key)
|
||||
(cond [(pair? key)
|
||||
(let ([name (cadddr key)]
|
||||
[mod (caddr key)])
|
||||
(format "'~s' from ~a"
|
||||
name
|
||||
(mpi->string mod)))]
|
||||
[else (symbol->string (syntax-e key))]))
|
||||
(define (key->text key)
|
||||
(cond [(pair? key)
|
||||
(let ([name (cadddr key)]
|
||||
[mod (caddr key)])
|
||||
(format "'~s' from ~a"
|
||||
name
|
||||
(mpi->string mod)))]
|
||||
[else (symbol->string (syntax-e key))]))
|
||||
|
||||
)
|
||||
|
|
|
|||
|
|
@ -1,48 +1,46 @@
|
|||
|
||||
(module interfaces mzscheme
|
||||
(require (lib "unit.ss"))
|
||||
(provide (all-defined))
|
||||
|
||||
;; Signatures
|
||||
#lang scheme/base
|
||||
(require scheme/unit)
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define-signature view^
|
||||
(macro-stepper-frame%
|
||||
macro-stepper-widget%
|
||||
make-macro-stepper
|
||||
go
|
||||
go/deriv))
|
||||
;; Signatures
|
||||
|
||||
(define-signature view-base^
|
||||
(base-frame%))
|
||||
(define-signature view^
|
||||
(macro-stepper-frame%
|
||||
macro-stepper-widget%
|
||||
make-macro-stepper
|
||||
go
|
||||
go/deriv))
|
||||
|
||||
(define-signature prefs^
|
||||
(pref:width
|
||||
pref:height
|
||||
pref:props-percentage
|
||||
pref:macro-hiding-mode
|
||||
pref:show-syntax-properties?
|
||||
pref:show-hiding-panel?
|
||||
pref:identifier=?
|
||||
pref:show-rename-steps?
|
||||
pref:highlight-foci?
|
||||
pref:highlight-frontier?
|
||||
pref:suppress-warnings?
|
||||
pref:one-by-one?
|
||||
pref:extra-navigation?
|
||||
pref:debug-catch-errors?
|
||||
pref:force-letrec-transformation?
|
||||
))
|
||||
(define-signature view-base^
|
||||
(base-frame%))
|
||||
|
||||
;; macro-stepper-config%
|
||||
;; all fields are notify-box% objects
|
||||
;; width
|
||||
;; height
|
||||
;; macro-hiding?
|
||||
;; hide-primitives?
|
||||
;; hide-libs?
|
||||
;; show-syntax-properties?
|
||||
;; show-hiding-panel?
|
||||
;; show-rename-steps?
|
||||
;; highlight-foci?
|
||||
(define-signature prefs^
|
||||
(pref:width
|
||||
pref:height
|
||||
pref:props-percentage
|
||||
pref:macro-hiding-mode
|
||||
pref:show-syntax-properties?
|
||||
pref:show-hiding-panel?
|
||||
pref:identifier=?
|
||||
pref:show-rename-steps?
|
||||
pref:highlight-foci?
|
||||
pref:highlight-frontier?
|
||||
pref:suppress-warnings?
|
||||
pref:one-by-one?
|
||||
pref:extra-navigation?
|
||||
pref:debug-catch-errors?
|
||||
pref:force-letrec-transformation?
|
||||
))
|
||||
|
||||
)
|
||||
;; macro-stepper-config%
|
||||
;; all fields are notify-box% objects
|
||||
;; width
|
||||
;; height
|
||||
;; macro-hiding?
|
||||
;; hide-primitives?
|
||||
;; hide-libs?
|
||||
;; show-syntax-properties?
|
||||
;; show-hiding-panel?
|
||||
;; show-rename-steps?
|
||||
;; highlight-foci?
|
||||
|
|
|
|||
|
|
@ -1,100 +1,98 @@
|
|||
|
||||
(module prefs mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "framework.ss" "framework")
|
||||
"../util/notify.ss"
|
||||
"../util/misc.ss")
|
||||
(provide macro-stepper-config-base%
|
||||
macro-stepper-config/prefs%
|
||||
macro-stepper-config/prefs/readonly%)
|
||||
#lang scheme/base
|
||||
(require scheme/class
|
||||
framework/framework
|
||||
"../util/notify.ss"
|
||||
"../util/misc.ss")
|
||||
(provide macro-stepper-config-base%
|
||||
macro-stepper-config/prefs%
|
||||
macro-stepper-config/prefs/readonly%)
|
||||
|
||||
(preferences:set-default 'MacroStepper:Frame:Width 700 number?)
|
||||
(preferences:set-default 'MacroStepper:Frame:Height 600 number?)
|
||||
(preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?)
|
||||
(preferences:set-default 'MacroStepper:MacroHidingMode "Standard" string?)
|
||||
(preferences:set-default 'MacroStepper:ShowSyntaxProperties? #f boolean?)
|
||||
(preferences:set-default 'MacroStepper:ShowHidingPanel? #t boolean?)
|
||||
(preferences:set-default 'MacroStepper:IdentifierComparison "bound-identifier=?" string?)
|
||||
(preferences:set-default 'MacroStepper:HighlightFoci? #t boolean?)
|
||||
(preferences:set-default 'MacroStepper:HighlightFrontier? #t boolean?)
|
||||
(preferences:set-default 'MacroStepper:ShowRenameSteps? #f boolean?)
|
||||
(preferences:set-default 'MacroStepper:SuppressWarnings? #f boolean?)
|
||||
(preferences:set-default 'MacroStepper:OneByOne? #f boolean?)
|
||||
(preferences:set-default 'MacroStepper:ExtraNavigation? #f boolean?)
|
||||
(preferences:set-default 'MacroStepper:DebugCatchErrors? #t boolean?)
|
||||
(preferences:set-default 'MacroStepper:ForceLetrecTransformation? #f boolean?)
|
||||
(preferences:set-default 'MacroStepper:Frame:Width 700 number?)
|
||||
(preferences:set-default 'MacroStepper:Frame:Height 600 number?)
|
||||
(preferences:set-default 'MacroStepper:PropertiesPanelPercentage 1/3 number?)
|
||||
(preferences:set-default 'MacroStepper:MacroHidingMode "Standard" string?)
|
||||
(preferences:set-default 'MacroStepper:ShowSyntaxProperties? #f boolean?)
|
||||
(preferences:set-default 'MacroStepper:ShowHidingPanel? #t boolean?)
|
||||
(preferences:set-default 'MacroStepper:IdentifierComparison "bound-identifier=?" string?)
|
||||
(preferences:set-default 'MacroStepper:HighlightFoci? #t boolean?)
|
||||
(preferences:set-default 'MacroStepper:HighlightFrontier? #t boolean?)
|
||||
(preferences:set-default 'MacroStepper:ShowRenameSteps? #f boolean?)
|
||||
(preferences:set-default 'MacroStepper:SuppressWarnings? #f boolean?)
|
||||
(preferences:set-default 'MacroStepper:OneByOne? #f boolean?)
|
||||
(preferences:set-default 'MacroStepper:ExtraNavigation? #f boolean?)
|
||||
(preferences:set-default 'MacroStepper:DebugCatchErrors? #t boolean?)
|
||||
(preferences:set-default 'MacroStepper:ForceLetrecTransformation? #f boolean?)
|
||||
|
||||
(pref:get/set pref:width MacroStepper:Frame:Width)
|
||||
(pref:get/set pref:height MacroStepper:Frame:Height)
|
||||
(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?)
|
||||
(pref:get/set pref:show-hiding-panel? MacroStepper:ShowHidingPanel?)
|
||||
(pref:get/set pref:identifier=? MacroStepper:IdentifierComparison)
|
||||
(pref:get/set pref:highlight-foci? MacroStepper:HighlightFoci?)
|
||||
(pref:get/set pref:highlight-frontier? MacroStepper:HighlightFrontier?)
|
||||
(pref:get/set pref:show-rename-steps? MacroStepper:ShowRenameSteps?)
|
||||
(pref:get/set pref:suppress-warnings? MacroStepper:SuppressWarnings?)
|
||||
(pref:get/set pref:one-by-one? MacroStepper:OneByOne?)
|
||||
(pref:get/set pref:extra-navigation? MacroStepper:ExtraNavigation?)
|
||||
(pref:get/set pref:debug-catch-errors? MacroStepper:DebugCatchErrors?)
|
||||
(pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?)
|
||||
(pref:get/set pref:width MacroStepper:Frame:Width)
|
||||
(pref:get/set pref:height MacroStepper:Frame:Height)
|
||||
(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?)
|
||||
(pref:get/set pref:show-hiding-panel? MacroStepper:ShowHidingPanel?)
|
||||
(pref:get/set pref:identifier=? MacroStepper:IdentifierComparison)
|
||||
(pref:get/set pref:highlight-foci? MacroStepper:HighlightFoci?)
|
||||
(pref:get/set pref:highlight-frontier? MacroStepper:HighlightFrontier?)
|
||||
(pref:get/set pref:show-rename-steps? MacroStepper:ShowRenameSteps?)
|
||||
(pref:get/set pref:suppress-warnings? MacroStepper:SuppressWarnings?)
|
||||
(pref:get/set pref:one-by-one? MacroStepper:OneByOne?)
|
||||
(pref:get/set pref:extra-navigation? MacroStepper:ExtraNavigation?)
|
||||
(pref:get/set pref:debug-catch-errors? MacroStepper:DebugCatchErrors?)
|
||||
(pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?)
|
||||
|
||||
(define macro-stepper-config-base%
|
||||
(class object%
|
||||
(notify-methods width)
|
||||
(notify-methods height)
|
||||
(notify-methods macro-hiding-mode)
|
||||
(notify-methods props-percentage)
|
||||
(notify-methods show-syntax-properties?)
|
||||
(notify-methods show-hiding-panel?)
|
||||
(notify-methods identifier=?)
|
||||
(notify-methods highlight-foci?)
|
||||
(notify-methods highlight-frontier?)
|
||||
(notify-methods show-rename-steps?)
|
||||
(notify-methods suppress-warnings?)
|
||||
(notify-methods one-by-one?)
|
||||
(notify-methods extra-navigation?)
|
||||
(notify-methods debug-catch-errors?)
|
||||
(notify-methods force-letrec-transformation?)
|
||||
(super-new)))
|
||||
(define macro-stepper-config-base%
|
||||
(class object%
|
||||
(notify-methods width)
|
||||
(notify-methods height)
|
||||
(notify-methods macro-hiding-mode)
|
||||
(notify-methods props-percentage)
|
||||
(notify-methods show-syntax-properties?)
|
||||
(notify-methods show-hiding-panel?)
|
||||
(notify-methods identifier=?)
|
||||
(notify-methods highlight-foci?)
|
||||
(notify-methods highlight-frontier?)
|
||||
(notify-methods show-rename-steps?)
|
||||
(notify-methods suppress-warnings?)
|
||||
(notify-methods one-by-one?)
|
||||
(notify-methods extra-navigation?)
|
||||
(notify-methods debug-catch-errors?)
|
||||
(notify-methods force-letrec-transformation?)
|
||||
(super-new)))
|
||||
|
||||
(define macro-stepper-config/prefs%
|
||||
(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-percentage pref:props-percentage)
|
||||
(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=?)
|
||||
(connect-to-pref highlight-foci? pref:highlight-foci?)
|
||||
(connect-to-pref highlight-frontier? pref:highlight-frontier?)
|
||||
(connect-to-pref show-rename-steps? pref:show-rename-steps?)
|
||||
(connect-to-pref suppress-warnings? pref:suppress-warnings?)
|
||||
(connect-to-pref one-by-one? pref:one-by-one?)
|
||||
(connect-to-pref extra-navigation? pref:extra-navigation?)
|
||||
(connect-to-pref debug-catch-errors? pref:debug-catch-errors?)
|
||||
(connect-to-pref force-letrec-transformation? pref:force-letrec-transformation?)
|
||||
(super-new)))
|
||||
(define macro-stepper-config/prefs%
|
||||
(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-percentage pref:props-percentage)
|
||||
(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=?)
|
||||
(connect-to-pref highlight-foci? pref:highlight-foci?)
|
||||
(connect-to-pref highlight-frontier? pref:highlight-frontier?)
|
||||
(connect-to-pref show-rename-steps? pref:show-rename-steps?)
|
||||
(connect-to-pref suppress-warnings? pref:suppress-warnings?)
|
||||
(connect-to-pref one-by-one? pref:one-by-one?)
|
||||
(connect-to-pref extra-navigation? pref:extra-navigation?)
|
||||
(connect-to-pref debug-catch-errors? pref:debug-catch-errors?)
|
||||
(connect-to-pref force-letrec-transformation? pref:force-letrec-transformation?)
|
||||
(super-new)))
|
||||
|
||||
(define macro-stepper-config/prefs/readonly%
|
||||
(class macro-stepper-config-base%
|
||||
(connect-to-pref/readonly width pref:width)
|
||||
(connect-to-pref/readonly height pref:height)
|
||||
(connect-to-pref/readonly macro-hiding-mode pref:macro-hiding-mode)
|
||||
(connect-to-pref/readonly props-percentage pref:props-percentage)
|
||||
(connect-to-pref/readonly show-syntax-properties? pref:show-syntax-properties?)
|
||||
(connect-to-pref/readonly show-hiding-panel? pref:show-hiding-panel?)
|
||||
(connect-to-pref/readonly identifier=? pref:identifier=?)
|
||||
(connect-to-pref/readonly highlight-foci? pref:highlight-foci?)
|
||||
(connect-to-pref/readonly highlight-frontier? pref:highlight-frontier?)
|
||||
(connect-to-pref/readonly show-rename-steps? pref:show-rename-steps?)
|
||||
(connect-to-pref/readonly suppress-warnings? pref:suppress-warnings?)
|
||||
(connect-to-pref/readonly one-by-one? pref:one-by-one?)
|
||||
(connect-to-pref/readonly extra-navigation? pref:extra-navigation?)
|
||||
(connect-to-pref/readonly debug-catch-errors? pref:debug-catch-errors?)
|
||||
(connect-to-pref/readonly force-letrec-transformation? pref:force-letrec-transformation?)
|
||||
(super-new)))
|
||||
|
||||
)
|
||||
(define macro-stepper-config/prefs/readonly%
|
||||
(class macro-stepper-config-base%
|
||||
(connect-to-pref/readonly width pref:width)
|
||||
(connect-to-pref/readonly height pref:height)
|
||||
(connect-to-pref/readonly macro-hiding-mode pref:macro-hiding-mode)
|
||||
(connect-to-pref/readonly props-percentage pref:props-percentage)
|
||||
(connect-to-pref/readonly show-syntax-properties? pref:show-syntax-properties?)
|
||||
(connect-to-pref/readonly show-hiding-panel? pref:show-hiding-panel?)
|
||||
(connect-to-pref/readonly identifier=? pref:identifier=?)
|
||||
(connect-to-pref/readonly highlight-foci? pref:highlight-foci?)
|
||||
(connect-to-pref/readonly highlight-frontier? pref:highlight-frontier?)
|
||||
(connect-to-pref/readonly show-rename-steps? pref:show-rename-steps?)
|
||||
(connect-to-pref/readonly suppress-warnings? pref:suppress-warnings?)
|
||||
(connect-to-pref/readonly one-by-one? pref:one-by-one?)
|
||||
(connect-to-pref/readonly extra-navigation? pref:extra-navigation?)
|
||||
(connect-to-pref/readonly debug-catch-errors? pref:debug-catch-errors?)
|
||||
(connect-to-pref/readonly force-letrec-transformation? pref:force-letrec-transformation?)
|
||||
(super-new)))
|
||||
|
|
|
|||
|
|
@ -1,433 +1,432 @@
|
|||
|
||||
(module stepper mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "unit.ss")
|
||||
(lib "list.ss")
|
||||
(lib "plt-match.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
(lib "boundmap.ss" "syntax")
|
||||
"interfaces.ss"
|
||||
"prefs.ss"
|
||||
"extensions.ss"
|
||||
"warning.ss"
|
||||
"hiding-panel.ss"
|
||||
"term-record.ss"
|
||||
(prefix s: "../syntax-browser/widget.ss")
|
||||
(prefix s: "../syntax-browser/params.ss")
|
||||
"../model/deriv.ss"
|
||||
"../model/deriv-util.ss"
|
||||
"../model/deriv-find.ss"
|
||||
"../model/trace.ss"
|
||||
"../model/reductions.ss"
|
||||
"../model/hide.ss"
|
||||
"../model/steps.ss"
|
||||
"cursor.ss"
|
||||
"util.ss")
|
||||
(provide macro-stepper-widget%
|
||||
macro-stepper-widget/process-mixin)
|
||||
#lang scheme/base
|
||||
(require scheme/class
|
||||
scheme/unit
|
||||
scheme/list
|
||||
scheme/match
|
||||
scheme/gui
|
||||
framework/framework
|
||||
syntax/boundmap
|
||||
"interfaces.ss"
|
||||
"prefs.ss"
|
||||
"extensions.ss"
|
||||
"warning.ss"
|
||||
"hiding-panel.ss"
|
||||
"term-record.ss"
|
||||
(prefix-in s: "../syntax-browser/widget.ss")
|
||||
(prefix-in s: "../syntax-browser/params.ss")
|
||||
"../model/deriv.ss"
|
||||
"../model/deriv-util.ss"
|
||||
"../model/deriv-find.ss"
|
||||
"../model/trace.ss"
|
||||
"../model/reductions.ss"
|
||||
"../model/hide.ss"
|
||||
"../model/steps.ss"
|
||||
"cursor.ss"
|
||||
"../util/notify.ss")
|
||||
(provide macro-stepper-widget%
|
||||
macro-stepper-widget/process-mixin)
|
||||
|
||||
;; Macro Stepper
|
||||
;; Macro Stepper
|
||||
|
||||
;; macro-stepper-widget%
|
||||
(define macro-stepper-widget%
|
||||
(class* object% ()
|
||||
(init-field parent)
|
||||
(init-field config)
|
||||
;; macro-stepper-widget%
|
||||
(define macro-stepper-widget%
|
||||
(class* object% ()
|
||||
(init-field parent)
|
||||
(init-field config)
|
||||
|
||||
;; Terms
|
||||
;; Terms
|
||||
|
||||
;; all-terms : (list-of TermRecord)
|
||||
;; (Reversed)
|
||||
(define all-terms null)
|
||||
;; all-terms : (list-of TermRecord)
|
||||
;; (Reversed)
|
||||
(define all-terms null)
|
||||
|
||||
;; terms : (Cursor-of TermRecord)
|
||||
;; Contains visible terms of all-terms
|
||||
(define terms (cursor:new null))
|
||||
;; terms : (Cursor-of TermRecord)
|
||||
;; Contains visible terms of all-terms
|
||||
(define terms (cursor:new null))
|
||||
|
||||
;; focused-term : -> TermRecord or #f
|
||||
(define (focused-term)
|
||||
(cursor:next terms))
|
||||
;; focused-term : -> TermRecord or #f
|
||||
(define (focused-term)
|
||||
(cursor:next terms))
|
||||
|
||||
;; add-deriv : Deriv -> void
|
||||
(define/public (add-deriv d)
|
||||
(let ([trec (new term-record% (stepper this) (raw-deriv d))])
|
||||
(add trec)))
|
||||
;; add-deriv : Deriv -> void
|
||||
(define/public (add-deriv d)
|
||||
(let ([trec (new term-record% (stepper this) (raw-deriv d))])
|
||||
(add trec)))
|
||||
|
||||
;; add-trace : (list-of event) -> void
|
||||
(define/public (add-trace events)
|
||||
(let ([trec (new term-record% (stepper this) (events events))])
|
||||
(add trec)))
|
||||
;; add-trace : (list-of event) -> void
|
||||
(define/public (add-trace events)
|
||||
(let ([trec (new term-record% (stepper this) (events events))])
|
||||
(add trec)))
|
||||
|
||||
;; add : TermRecord -> void
|
||||
(define/public (add trec)
|
||||
(set! all-terms (cons trec all-terms))
|
||||
(let ([display-new-term? (cursor:at-end? terms)]
|
||||
[invisible? (send trec get-deriv-hidden?)])
|
||||
(unless invisible?
|
||||
(cursor:add-to-end! terms (list trec))
|
||||
(trim-navigator)
|
||||
(if display-new-term?
|
||||
(refresh)
|
||||
(update)))))
|
||||
;; add : TermRecord -> void
|
||||
(define/public (add trec)
|
||||
(set! all-terms (cons trec all-terms))
|
||||
(let ([display-new-term? (cursor:at-end? terms)]
|
||||
[invisible? (send trec get-deriv-hidden?)])
|
||||
(unless invisible?
|
||||
(cursor:add-to-end! terms (list trec))
|
||||
(trim-navigator)
|
||||
(if display-new-term?
|
||||
(refresh)
|
||||
(update)))))
|
||||
|
||||
;; remove-current-term : -> void
|
||||
(define/public (remove-current-term)
|
||||
(cursor:remove-current! terms)
|
||||
(trim-navigator)
|
||||
(refresh))
|
||||
;; remove-current-term : -> void
|
||||
(define/public (remove-current-term)
|
||||
(cursor:remove-current! terms)
|
||||
(trim-navigator)
|
||||
(refresh))
|
||||
|
||||
(define/public (get-config) config)
|
||||
(define/public (get-controller) sbc)
|
||||
(define/public (get-view) sbview)
|
||||
(define/public (get-warnings-area) warnings-area)
|
||||
(define/public (get-macro-hiding-prefs) macro-hiding-prefs)
|
||||
(define/public (get-config) config)
|
||||
(define/public (get-controller) sbc)
|
||||
(define/public (get-view) sbview)
|
||||
(define/public (get-warnings-area) warnings-area)
|
||||
(define/public (get-macro-hiding-prefs) macro-hiding-prefs)
|
||||
|
||||
(define/public (reset-primary-partition)
|
||||
(send sbc reset-primary-partition)
|
||||
(update/preserve-view))
|
||||
(define/public (reset-primary-partition)
|
||||
(send sbc reset-primary-partition)
|
||||
(update/preserve-view))
|
||||
|
||||
(define area (new vertical-panel% (parent parent)))
|
||||
(define supernavigator
|
||||
(new horizontal-panel%
|
||||
(parent area)
|
||||
(stretchable-height #f)
|
||||
(alignment '(center center))))
|
||||
(define navigator
|
||||
(new horizontal-panel%
|
||||
(parent supernavigator)
|
||||
(stretchable-width #f)
|
||||
(stretchable-height #f)
|
||||
(alignment '(left center))))
|
||||
(define extra-navigator
|
||||
(new horizontal-panel%
|
||||
(parent supernavigator)
|
||||
(stretchable-width #f)
|
||||
(stretchable-height #f)
|
||||
(alignment '(left center))
|
||||
(style '(deleted))))
|
||||
(define area (new vertical-panel% (parent parent)))
|
||||
(define supernavigator
|
||||
(new horizontal-panel%
|
||||
(parent area)
|
||||
(stretchable-height #f)
|
||||
(alignment '(center center))))
|
||||
(define navigator
|
||||
(new horizontal-panel%
|
||||
(parent supernavigator)
|
||||
(stretchable-width #f)
|
||||
(stretchable-height #f)
|
||||
(alignment '(left center))))
|
||||
(define extra-navigator
|
||||
(new horizontal-panel%
|
||||
(parent supernavigator)
|
||||
(stretchable-width #f)
|
||||
(stretchable-height #f)
|
||||
(alignment '(left center))
|
||||
(style '(deleted))))
|
||||
|
||||
(define warnings-area (new stepper-warnings% (parent area)))
|
||||
|
||||
(define sbview (new stepper-syntax-widget%
|
||||
(parent area)
|
||||
(macro-stepper this)))
|
||||
(define sbc (send sbview get-controller))
|
||||
(define control-pane
|
||||
(new vertical-panel% (parent area) (stretchable-height #f)))
|
||||
(define macro-hiding-prefs
|
||||
(new macro-hiding-prefs-widget%
|
||||
(parent control-pane)
|
||||
(stepper this)
|
||||
(config config)))
|
||||
|
||||
(send config listen-show-syntax-properties?
|
||||
(lambda (show?) (send sbview show-props show?)))
|
||||
(send config listen-show-hiding-panel?
|
||||
(lambda (show?) (show-macro-hiding-prefs show?)))
|
||||
(send sbc listen-selected-syntax
|
||||
(lambda (stx) (send macro-hiding-prefs set-syntax stx)))
|
||||
(send config listen-highlight-foci?
|
||||
(lambda (_) (update/preserve-view)))
|
||||
(send config listen-highlight-frontier?
|
||||
(lambda (_) (update/preserve-view)))
|
||||
(send config listen-show-rename-steps?
|
||||
(lambda (_) (refresh/re-reduce)))
|
||||
(send config listen-one-by-one?
|
||||
(lambda (_) (refresh/re-reduce)))
|
||||
(send config listen-force-letrec-transformation?
|
||||
(lambda (_) (refresh/resynth)))
|
||||
(send config listen-extra-navigation?
|
||||
(lambda (show?) (show-extra-navigation show?)))
|
||||
|
||||
(define nav:up
|
||||
(new button% (label "Previous term") (parent navigator)
|
||||
(callback (lambda (b e) (navigate-up)))))
|
||||
(define nav:start
|
||||
(new button% (label "<-- Start") (parent navigator)
|
||||
(callback (lambda (b e) (navigate-to-start)))))
|
||||
(define nav:previous
|
||||
(new button% (label "<- Step") (parent navigator)
|
||||
(callback (lambda (b e) (navigate-previous)))))
|
||||
(define nav:next
|
||||
(new button% (label "Step ->") (parent navigator)
|
||||
(callback (lambda (b e) (navigate-next)))))
|
||||
(define nav:end
|
||||
(new button% (label "End -->") (parent navigator)
|
||||
(callback (lambda (b e) (navigate-to-end)))))
|
||||
(define nav:down
|
||||
(new button% (label "Next term") (parent navigator)
|
||||
(callback (lambda (b e) (navigate-down)))))
|
||||
|
||||
(define/private (trim-navigator)
|
||||
(if (> (length (cursor->list terms)) 1)
|
||||
(send navigator change-children
|
||||
(lambda _
|
||||
(list nav:up
|
||||
nav:start
|
||||
nav:previous
|
||||
nav:next
|
||||
nav:end
|
||||
nav:down)))
|
||||
(send navigator change-children
|
||||
(lambda _
|
||||
(list nav:start
|
||||
nav:previous
|
||||
nav:next
|
||||
nav:end)))))
|
||||
|
||||
(define/public (show-macro-hiding-prefs show?)
|
||||
(send area change-children
|
||||
(lambda (children)
|
||||
(if show?
|
||||
(append (remq control-pane children) (list control-pane))
|
||||
(remq control-pane children)))))
|
||||
|
||||
(define/private (show-extra-navigation show?)
|
||||
(send supernavigator change-children
|
||||
(lambda (children)
|
||||
(if show?
|
||||
(list navigator extra-navigator)
|
||||
(list navigator)))))
|
||||
|
||||
;; Navigation
|
||||
|
||||
(define/public-final (at-start?)
|
||||
(send (focused-term) at-start?))
|
||||
(define/public-final (at-end?)
|
||||
(send (focused-term) at-end?))
|
||||
|
||||
(define/public-final (navigate-to-start)
|
||||
(send (focused-term) navigate-to-start)
|
||||
(update/save-position))
|
||||
(define/public-final (navigate-to-end)
|
||||
(send (focused-term) navigate-to-end)
|
||||
(update/save-position))
|
||||
(define/public-final (navigate-previous)
|
||||
(send (focused-term) navigate-previous)
|
||||
(update/save-position))
|
||||
(define/public-final (navigate-next)
|
||||
(send (focused-term) navigate-next)
|
||||
(update/save-position))
|
||||
|
||||
(define/public-final (navigate-up)
|
||||
(when (focused-term)
|
||||
(send (focused-term) on-lose-focus))
|
||||
(cursor:move-prev terms)
|
||||
(refresh/move))
|
||||
(define/public-final (navigate-down)
|
||||
(when (focused-term)
|
||||
(send (focused-term) on-lose-focus))
|
||||
(cursor:move-next terms)
|
||||
(refresh/move))
|
||||
|
||||
;; Update
|
||||
|
||||
;; update/save-position : -> void
|
||||
(define/private (update/save-position)
|
||||
(update/preserve-lines-view))
|
||||
|
||||
;; update/preserve-lines-view : -> void
|
||||
(define/public (update/preserve-lines-view)
|
||||
(define text (send sbview get-text))
|
||||
(define start-box (box 0))
|
||||
(define end-box (box 0))
|
||||
(send text get-visible-line-range start-box end-box)
|
||||
(update)
|
||||
(send text scroll-to-position
|
||||
(send text line-start-position (unbox start-box))
|
||||
#f
|
||||
(send text line-start-position (unbox end-box))
|
||||
'start))
|
||||
|
||||
;; update/preserve-view : -> void
|
||||
(define/public (update/preserve-view)
|
||||
(define text (send sbview get-text))
|
||||
(define start-box (box 0))
|
||||
(define end-box (box 0))
|
||||
(send text get-visible-position-range start-box end-box)
|
||||
(update)
|
||||
(send text scroll-to-position (unbox start-box) #f (unbox end-box) 'start))
|
||||
|
||||
;; update : -> void
|
||||
;; Updates the terms in the syntax browser to the current step
|
||||
(define/private (update)
|
||||
(define text (send sbview get-text))
|
||||
(define position-of-interest 0)
|
||||
(define multiple-terms? (> (length (cursor->list terms)) 1))
|
||||
(send text begin-edit-sequence)
|
||||
(send sbview erase-all)
|
||||
|
||||
(define warnings-area (new stepper-warnings% (parent area)))
|
||||
|
||||
(define sbview (new stepper-syntax-widget%
|
||||
(parent area)
|
||||
(macro-stepper this)))
|
||||
(define sbc (send sbview get-controller))
|
||||
(define control-pane
|
||||
(new vertical-panel% (parent area) (stretchable-height #f)))
|
||||
(define macro-hiding-prefs
|
||||
(new macro-hiding-prefs-widget%
|
||||
(parent control-pane)
|
||||
(stepper this)
|
||||
(config config)))
|
||||
(update:show-prefix)
|
||||
(when multiple-terms? (send sbview add-separator))
|
||||
(set! position-of-interest (send text last-position))
|
||||
(update:show-current-step)
|
||||
(when multiple-terms? (send sbview add-separator))
|
||||
(update:show-suffix)
|
||||
(send text end-edit-sequence)
|
||||
(send text scroll-to-position
|
||||
position-of-interest
|
||||
#f
|
||||
(send text last-position)
|
||||
'start)
|
||||
(enable/disable-buttons))
|
||||
|
||||
(send config listen-show-syntax-properties?
|
||||
(lambda (show?) (send sbview show-props show?)))
|
||||
(send config listen-show-hiding-panel?
|
||||
(lambda (show?) (show-macro-hiding-prefs show?)))
|
||||
(send sbc listen-selected-syntax
|
||||
(lambda (stx) (send macro-hiding-prefs set-syntax stx)))
|
||||
(send config listen-highlight-foci?
|
||||
(lambda (_) (update/preserve-view)))
|
||||
(send config listen-highlight-frontier?
|
||||
(lambda (_) (update/preserve-view)))
|
||||
(send config listen-show-rename-steps?
|
||||
(lambda (_) (refresh/re-reduce)))
|
||||
(send config listen-one-by-one?
|
||||
(lambda (_) (refresh/re-reduce)))
|
||||
(send config listen-force-letrec-transformation?
|
||||
(lambda (_) (refresh/resynth)))
|
||||
(send config listen-extra-navigation?
|
||||
(lambda (show?) (show-extra-navigation show?)))
|
||||
;; update:show-prefix : -> void
|
||||
(define/private (update:show-prefix)
|
||||
;; Show the final terms from the cached synth'd derivs
|
||||
(for-each (lambda (trec) (send trec display-final-term))
|
||||
(cursor:prefix->list terms)))
|
||||
|
||||
(define nav:up
|
||||
(new button% (label "Previous term") (parent navigator)
|
||||
(callback (lambda (b e) (navigate-up)))))
|
||||
(define nav:start
|
||||
(new button% (label "<-- Start") (parent navigator)
|
||||
(callback (lambda (b e) (navigate-to-start)))))
|
||||
(define nav:previous
|
||||
(new button% (label "<- Step") (parent navigator)
|
||||
(callback (lambda (b e) (navigate-previous)))))
|
||||
(define nav:next
|
||||
(new button% (label "Step ->") (parent navigator)
|
||||
(callback (lambda (b e) (navigate-next)))))
|
||||
(define nav:end
|
||||
(new button% (label "End -->") (parent navigator)
|
||||
(callback (lambda (b e) (navigate-to-end)))))
|
||||
(define nav:down
|
||||
(new button% (label "Next term") (parent navigator)
|
||||
(callback (lambda (b e) (navigate-down)))))
|
||||
;; update:show-current-step : -> void
|
||||
(define/private (update:show-current-step)
|
||||
(when (focused-term)
|
||||
(send (focused-term) display-step)))
|
||||
|
||||
(define/private (trim-navigator)
|
||||
(if (> (length (cursor->list terms)) 1)
|
||||
(send navigator change-children
|
||||
(lambda _
|
||||
(list nav:up
|
||||
nav:start
|
||||
nav:previous
|
||||
nav:next
|
||||
nav:end
|
||||
nav:down)))
|
||||
(send navigator change-children
|
||||
(lambda _
|
||||
(list nav:start
|
||||
nav:previous
|
||||
nav:next
|
||||
nav:end)))))
|
||||
;; update:show-suffix : -> void
|
||||
(define/private (update:show-suffix)
|
||||
(let ([suffix0 (cursor:suffix->list terms)])
|
||||
(when (pair? suffix0)
|
||||
(for-each (lambda (trec)
|
||||
(send trec display-initial-term))
|
||||
(cdr suffix0)))))
|
||||
|
||||
(define/public (show-macro-hiding-prefs show?)
|
||||
(send area change-children
|
||||
(lambda (children)
|
||||
(if show?
|
||||
(append (remq control-pane children) (list control-pane))
|
||||
(remq control-pane children)))))
|
||||
;; enable/disable-buttons : -> void
|
||||
(define/private (enable/disable-buttons)
|
||||
(define term (focused-term))
|
||||
(send nav:start enable (and term (send term has-prev?)))
|
||||
(send nav:previous enable (and term (send term has-prev?)))
|
||||
(send nav:next enable (and term (send term has-next?)))
|
||||
(send nav:end enable (and term (send term has-next?)))
|
||||
(send nav:up enable (cursor:has-prev? terms))
|
||||
(send nav:down enable (cursor:has-next? terms)))
|
||||
|
||||
(define/private (show-extra-navigation show?)
|
||||
(send supernavigator change-children
|
||||
(lambda (children)
|
||||
(if show?
|
||||
(list navigator extra-navigator)
|
||||
(list navigator)))))
|
||||
;; --
|
||||
|
||||
;; Navigation
|
||||
;; refresh/resynth : -> void
|
||||
;; Macro hiding policy has changed; invalidate cached parts of trec
|
||||
(define/public (refresh/resynth)
|
||||
(for-each (lambda (trec) (send trec invalidate-synth!))
|
||||
(cursor->list terms))
|
||||
(refresh))
|
||||
|
||||
(define/public-final (at-start?)
|
||||
(send (focused-term) at-start?))
|
||||
(define/public-final (at-end?)
|
||||
(send (focused-term) at-end?))
|
||||
;; refresh/re-reduce : -> void
|
||||
;; Reduction config has changed; invalidate cached parts of trec
|
||||
(define/private (refresh/re-reduce)
|
||||
(for-each (lambda (trec) (send trec invalidate-steps!))
|
||||
(cursor->list terms))
|
||||
(refresh))
|
||||
|
||||
(define/public-final (navigate-to-start)
|
||||
(send (focused-term) navigate-to-start)
|
||||
(update/save-position))
|
||||
(define/public-final (navigate-to-end)
|
||||
(send (focused-term) navigate-to-end)
|
||||
(update/save-position))
|
||||
(define/public-final (navigate-previous)
|
||||
(send (focused-term) navigate-previous)
|
||||
(update/save-position))
|
||||
(define/public-final (navigate-next)
|
||||
(send (focused-term) navigate-next)
|
||||
(update/save-position))
|
||||
;; refresh/move : -> void
|
||||
;; Moving between terms; clear the saved position
|
||||
(define/private (refresh/move)
|
||||
(refresh))
|
||||
|
||||
(define/public-final (navigate-up)
|
||||
(when (focused-term)
|
||||
(send (focused-term) on-lose-focus))
|
||||
(cursor:move-prev terms)
|
||||
(refresh/move))
|
||||
(define/public-final (navigate-down)
|
||||
(when (focused-term)
|
||||
(send (focused-term) on-lose-focus))
|
||||
(cursor:move-next terms)
|
||||
(refresh/move))
|
||||
;; refresh : -> void
|
||||
(define/public (refresh)
|
||||
(send warnings-area clear)
|
||||
(when (focused-term)
|
||||
(send (focused-term) on-get-focus))
|
||||
(update))
|
||||
|
||||
;; Update
|
||||
;; delayed-recache-errors : (list-of (cons exn string))
|
||||
(define delayed-recache-errors null)
|
||||
|
||||
;; update/save-position : -> void
|
||||
(define/private (update/save-position)
|
||||
(update/preserve-lines-view))
|
||||
;; handle-recache-error : exception string -> void
|
||||
(define/private (handle-recache-error exn part)
|
||||
(if (send config get-debug-catch-errors?)
|
||||
(begin
|
||||
(set! delayed-recache-errors
|
||||
(cons (cons exn part) delayed-recache-errors))
|
||||
(queue-callback
|
||||
(lambda ()
|
||||
(when (pair? delayed-recache-errors)
|
||||
(message-box
|
||||
"Error"
|
||||
(string-append
|
||||
"Internal errors in macro stepper:\n"
|
||||
(if (memq 'macro-hiding (map cdr delayed-recache-errors))
|
||||
(string-append
|
||||
"Macro hiding failed on one or more terms. "
|
||||
"The macro stepper is showing the terms "
|
||||
"with macro hiding disabled.\n")
|
||||
"")
|
||||
(if (memq 'reductions (map cdr delayed-recache-errors))
|
||||
(string-append
|
||||
"The macro stepper failed to compute the reduction sequence "
|
||||
"for one or more terms.\n")
|
||||
"")))
|
||||
(set! delayed-recache-errors null)))))
|
||||
(raise exn)))
|
||||
|
||||
;; update/preserve-lines-view : -> void
|
||||
(define/public (update/preserve-lines-view)
|
||||
(define text (send sbview get-text))
|
||||
(define start-box (box 0))
|
||||
(define end-box (box 0))
|
||||
(send text get-visible-line-range start-box end-box)
|
||||
(update)
|
||||
(send text scroll-to-position
|
||||
(send text line-start-position (unbox start-box))
|
||||
#f
|
||||
(send text line-start-position (unbox end-box))
|
||||
'start))
|
||||
|
||||
;; update/preserve-view : -> void
|
||||
(define/public (update/preserve-view)
|
||||
(define text (send sbview get-text))
|
||||
(define start-box (box 0))
|
||||
(define end-box (box 0))
|
||||
(send text get-visible-position-range start-box end-box)
|
||||
(update)
|
||||
(send text scroll-to-position (unbox start-box) #f (unbox end-box) 'start))
|
||||
(define/private (foci x) (if (list? x) x (list x)))
|
||||
|
||||
;; update : -> void
|
||||
;; Updates the terms in the syntax browser to the current step
|
||||
(define/private (update)
|
||||
(define text (send sbview get-text))
|
||||
(define position-of-interest 0)
|
||||
(define multiple-terms? (> (length (cursor->list terms)) 1))
|
||||
(send text begin-edit-sequence)
|
||||
(send sbview erase-all)
|
||||
|
||||
(update:show-prefix)
|
||||
(when multiple-terms? (send sbview add-separator))
|
||||
(set! position-of-interest (send text last-position))
|
||||
(update:show-current-step)
|
||||
(when multiple-terms? (send sbview add-separator))
|
||||
(update:show-suffix)
|
||||
(send text end-edit-sequence)
|
||||
(send text scroll-to-position
|
||||
position-of-interest
|
||||
#f
|
||||
(send text last-position)
|
||||
'start)
|
||||
(enable/disable-buttons))
|
||||
;; Hiding policy
|
||||
|
||||
(define/public (get-show-macro?)
|
||||
(send macro-hiding-prefs get-policy))
|
||||
|
||||
;; update:show-prefix : -> void
|
||||
(define/private (update:show-prefix)
|
||||
;; Show the final terms from the cached synth'd derivs
|
||||
(for-each (lambda (trec) (send trec display-final-term))
|
||||
(cursor:prefix->list terms)))
|
||||
;; Derivation pre-processing
|
||||
|
||||
;; update:show-current-step : -> void
|
||||
(define/private (update:show-current-step)
|
||||
(when (focused-term)
|
||||
(send (focused-term) display-step)))
|
||||
(define/public (get-preprocess-deriv) (lambda (d) d))
|
||||
|
||||
;; update:show-suffix : -> void
|
||||
(define/private (update:show-suffix)
|
||||
(let ([suffix0 (cursor:suffix->list terms)])
|
||||
(when (pair? suffix0)
|
||||
(for-each (lambda (trec)
|
||||
(send trec display-initial-term))
|
||||
(cdr suffix0)))))
|
||||
;; Initialization
|
||||
|
||||
;; enable/disable-buttons : -> void
|
||||
(define/private (enable/disable-buttons)
|
||||
(define term (focused-term))
|
||||
(send nav:start enable (and term (send term has-prev?)))
|
||||
(send nav:previous enable (and term (send term has-prev?)))
|
||||
(send nav:next enable (and term (send term has-next?)))
|
||||
(send nav:end enable (and term (send term has-next?)))
|
||||
(send nav:up enable (cursor:has-prev? terms))
|
||||
(send nav:down enable (cursor:has-next? terms)))
|
||||
(super-new)
|
||||
(send sbview show-props (send config get-show-syntax-properties?))
|
||||
(show-macro-hiding-prefs (send config get-show-hiding-panel?))
|
||||
(show-extra-navigation (send config get-extra-navigation?))
|
||||
(refresh/move)
|
||||
))
|
||||
|
||||
;; --
|
||||
(define (macro-stepper-widget/process-mixin %)
|
||||
(class %
|
||||
(super-new)
|
||||
(define/override (get-preprocess-deriv)
|
||||
(lambda (d) (get-original-part d)))
|
||||
|
||||
;; refresh/resynth : -> void
|
||||
;; Macro hiding policy has changed; invalidate cached parts of trec
|
||||
(define/public (refresh/resynth)
|
||||
(for-each (lambda (trec) (send trec invalidate-synth!))
|
||||
(cursor->list terms))
|
||||
(refresh))
|
||||
;; get-original-part : Deriv -> Deriv/#f
|
||||
;; Strip off mzscheme's #%top-interaction
|
||||
;; Careful: the #%top-interaction node may be inside of a lift-deriv
|
||||
(define/private (get-original-part deriv)
|
||||
(let ([deriv* (adjust-deriv/lift deriv)])
|
||||
deriv*))
|
||||
|
||||
;; adjust-deriv/lift : Derivation -> (list-of Derivation)
|
||||
(define/private (adjust-deriv/lift deriv)
|
||||
(match deriv
|
||||
[(Wrap lift-deriv (e1 e2 first lifted-stx second))
|
||||
(let ([first (adjust-deriv/top first)])
|
||||
(and first
|
||||
(let ([e1 (wderiv-e1 first)])
|
||||
(make-lift-deriv e1 e2 first lifted-stx second))))]
|
||||
[else (adjust-deriv/top deriv)]))
|
||||
|
||||
;; refresh/re-reduce : -> void
|
||||
;; Reduction config has changed; invalidate cached parts of trec
|
||||
(define/private (refresh/re-reduce)
|
||||
(for-each (lambda (trec) (send trec invalidate-steps!))
|
||||
(cursor->list terms))
|
||||
(refresh))
|
||||
;; adjust-deriv/top : Derivation -> Derivation
|
||||
(define/private (adjust-deriv/top deriv)
|
||||
(if (syntax-source (wderiv-e1 deriv))
|
||||
deriv
|
||||
;; It's not original...
|
||||
;; Strip out mzscheme's top-interactions
|
||||
;; Keep anything that is a non-mzscheme top-interaction
|
||||
;; Drop everything else (not original program)
|
||||
(match deriv
|
||||
[(Wrap mrule (e1 e2 tx next))
|
||||
(match tx
|
||||
[(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 seq))
|
||||
(cond [(ormap (lambda (x) (top-interaction-kw? x))
|
||||
rs)
|
||||
;; Just mzscheme's top-interaction; strip it out
|
||||
(adjust-deriv/top next)]
|
||||
[(equal? (map syntax-e rs) '(#%top-interaction))
|
||||
;; A *different* top interaction; keep it
|
||||
deriv]
|
||||
[else
|
||||
;; Not original and not tagged with top-interaction
|
||||
#f])])]
|
||||
[else #f])))
|
||||
|
||||
;; refresh/move : -> void
|
||||
;; Moving between terms; clear the saved position
|
||||
(define/private (refresh/move)
|
||||
(refresh))
|
||||
(define/public (top-interaction-kw? x)
|
||||
(free-identifier=? x #'#%top-interaction))
|
||||
|
||||
;; refresh : -> void
|
||||
(define/public (refresh)
|
||||
(send warnings-area clear)
|
||||
(when (focused-term)
|
||||
(send (focused-term) on-get-focus))
|
||||
(update))
|
||||
|
||||
;; delayed-recache-errors : (list-of (cons exn string))
|
||||
(define delayed-recache-errors null)
|
||||
|
||||
;; handle-recache-error : exception string -> void
|
||||
(define/private (handle-recache-error exn part)
|
||||
(if (send config get-debug-catch-errors?)
|
||||
(begin
|
||||
(set! delayed-recache-errors
|
||||
(cons (cons exn part) delayed-recache-errors))
|
||||
(queue-callback
|
||||
(lambda ()
|
||||
(when (pair? delayed-recache-errors)
|
||||
(message-box
|
||||
"Error"
|
||||
(string-append
|
||||
"Internal errors in macro stepper:\n"
|
||||
(if (memq 'macro-hiding (map cdr delayed-recache-errors))
|
||||
(string-append
|
||||
"Macro hiding failed on one or more terms. "
|
||||
"The macro stepper is showing the terms "
|
||||
"with macro hiding disabled.\n")
|
||||
"")
|
||||
(if (memq 'reductions (map cdr delayed-recache-errors))
|
||||
(string-append
|
||||
"The macro stepper failed to compute the reduction sequence "
|
||||
"for one or more terms.\n")
|
||||
"")))
|
||||
(set! delayed-recache-errors null)))))
|
||||
(raise exn)))
|
||||
|
||||
(define/private (foci x) (if (list? x) x (list x)))
|
||||
|
||||
;; Hiding policy
|
||||
|
||||
(define/public (get-show-macro?)
|
||||
(send macro-hiding-prefs get-policy))
|
||||
|
||||
;; Derivation pre-processing
|
||||
|
||||
(define/public (get-preprocess-deriv) (lambda (d) d))
|
||||
|
||||
;; Initialization
|
||||
|
||||
(super-new)
|
||||
(send sbview show-props (send config get-show-syntax-properties?))
|
||||
(show-macro-hiding-prefs (send config get-show-hiding-panel?))
|
||||
(show-extra-navigation (send config get-extra-navigation?))
|
||||
(refresh/move)
|
||||
))
|
||||
|
||||
(define (macro-stepper-widget/process-mixin %)
|
||||
(class %
|
||||
(super-new)
|
||||
(define/override (get-preprocess-deriv)
|
||||
(lambda (d) (get-original-part d)))
|
||||
|
||||
;; get-original-part : Deriv -> Deriv/#f
|
||||
;; Strip off mzscheme's #%top-interaction
|
||||
;; Careful: the #%top-interaction node may be inside of a lift-deriv
|
||||
(define/private (get-original-part deriv)
|
||||
(let ([deriv* (adjust-deriv/lift deriv)])
|
||||
deriv*))
|
||||
|
||||
;; adjust-deriv/lift : Derivation -> (list-of Derivation)
|
||||
(define/private (adjust-deriv/lift deriv)
|
||||
(match deriv
|
||||
[(Wrap lift-deriv (e1 e2 first lifted-stx second))
|
||||
(let ([first (adjust-deriv/top first)])
|
||||
(and first
|
||||
(let ([e1 (wderiv-e1 first)])
|
||||
(make-lift-deriv e1 e2 first lifted-stx second))))]
|
||||
[else (adjust-deriv/top deriv)]))
|
||||
|
||||
;; adjust-deriv/top : Derivation -> Derivation
|
||||
(define/private (adjust-deriv/top deriv)
|
||||
(if (syntax-source (wderiv-e1 deriv))
|
||||
deriv
|
||||
;; It's not original...
|
||||
;; Strip out mzscheme's top-interactions
|
||||
;; Keep anything that is a non-mzscheme top-interaction
|
||||
;; Drop everything else (not original program)
|
||||
(match deriv
|
||||
[(Wrap mrule (e1 e2 tx next))
|
||||
(match tx
|
||||
[(Wrap transformation (e1 e2 rs ?1 me1 locals ?2 me2 seq))
|
||||
(cond [(ormap (lambda (x) (top-interaction-kw? x))
|
||||
rs)
|
||||
;; Just mzscheme's top-interaction; strip it out
|
||||
(adjust-deriv/top next)]
|
||||
[(equal? (map syntax-e rs) '(#%top-interaction))
|
||||
;; A *different* top interaction; keep it
|
||||
deriv]
|
||||
[else
|
||||
;; Not original and not tagged with top-interaction
|
||||
#f])])]
|
||||
[else #f])))
|
||||
|
||||
(define/public (top-interaction-kw? x)
|
||||
(module-identifier=? x #'#%top-interaction))
|
||||
|
||||
))
|
||||
)
|
||||
))
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,43 +1,41 @@
|
|||
|
||||
(module view mzscheme
|
||||
(require (lib "class.ss")
|
||||
(lib "pretty.ss")
|
||||
(lib "mred.ss" "mred")
|
||||
(lib "framework.ss" "framework")
|
||||
"interfaces.ss"
|
||||
"frame.ss"
|
||||
"prefs.ss"
|
||||
"../model/trace.ss")
|
||||
(provide (all-defined))
|
||||
#lang scheme/base
|
||||
(require scheme/class
|
||||
scheme/pretty
|
||||
scheme/gui
|
||||
framework/framework
|
||||
"interfaces.ss"
|
||||
"frame.ss"
|
||||
"prefs.ss"
|
||||
"../model/trace.ss")
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define macro-stepper-frame%
|
||||
(macro-stepper-frame-mixin
|
||||
(frame:standard-menus-mixin
|
||||
(frame:basic-mixin frame%))))
|
||||
(define macro-stepper-frame%
|
||||
(macro-stepper-frame-mixin
|
||||
(frame:standard-menus-mixin
|
||||
(frame:basic-mixin frame%))))
|
||||
|
||||
;; Main entry points
|
||||
;; Main entry points
|
||||
|
||||
(define (make-macro-stepper)
|
||||
(let ([f (new macro-stepper-frame%
|
||||
(config (new macro-stepper-config/prefs%)))])
|
||||
(send f show #t)
|
||||
(send f get-widget)))
|
||||
(define (make-macro-stepper)
|
||||
(let ([f (new macro-stepper-frame%
|
||||
(config (new macro-stepper-config/prefs%)))])
|
||||
(send f show #t)
|
||||
(send f get-widget)))
|
||||
|
||||
(define (go stx)
|
||||
(let ([stepper (make-macro-stepper)])
|
||||
(send stepper add-deriv (trace stx))
|
||||
stepper))
|
||||
(define (go stx)
|
||||
(let ([stepper (make-macro-stepper)])
|
||||
(send stepper add-deriv (trace stx))
|
||||
stepper))
|
||||
|
||||
(define (go/deriv deriv)
|
||||
(let* ([f (new macro-stepper-frame%)]
|
||||
[w (send f get-widget)])
|
||||
(send w add-deriv deriv)
|
||||
(send f show #t)
|
||||
w))
|
||||
(define (go/deriv deriv)
|
||||
(let* ([f (new macro-stepper-frame%)]
|
||||
[w (send f get-widget)])
|
||||
(send w add-deriv deriv)
|
||||
(send f show #t)
|
||||
w))
|
||||
|
||||
(define (go/trace events)
|
||||
(let* ([w (make-macro-stepper)])
|
||||
(send w add-trace events)
|
||||
w))
|
||||
|
||||
)
|
||||
(define (go/trace events)
|
||||
(let* ([w (make-macro-stepper)])
|
||||
(send w add-trace events)
|
||||
w))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user