macro-stepper: replaced {scheme -> racket}, {*.ss -> *.rkt}, etc
original commit: efc03566055f549de2a9bf32a402185f66c14a64
This commit is contained in:
Ryan Culpepper
parent
9cb5f4756d
commit
79f7ee3048
|
|
@ -1,8 +1,8 @@
|
|||
#lang scheme/base
|
||||
(require scheme/contract
|
||||
"model/trace.ss"
|
||||
"model/reductions-config.ss"
|
||||
"model/reductions.ss")
|
||||
#lang racket/base
|
||||
(require racket/contract
|
||||
"model/trace.rkt"
|
||||
"model/reductions-config.rkt"
|
||||
"model/reductions.rkt")
|
||||
|
||||
(provide/contract
|
||||
[expand-only
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
#lang setup/infotab
|
||||
|
||||
(define tools '(["tool.ss"]))
|
||||
(define tools '(["tool.rkt"]))
|
||||
(define tool-names '("Macro Stepper"))
|
||||
(define scribblings '(("macro-debugger.scrbl" () (tool-library))))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,4 @@
|
|||
#lang scheme/base
|
||||
|
||||
#lang racket/base
|
||||
(require syntax/stx)
|
||||
(provide (struct-out ref)
|
||||
(struct-out tail)
|
||||
|
|
|
|||
|
|
@ -1,19 +1,18 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
(require racket/match
|
||||
"trace.rkt"
|
||||
"reductions.rkt"
|
||||
"reductions-config.rkt"
|
||||
"deriv-util.rkt"
|
||||
"hiding-policies.rkt"
|
||||
"deriv.rkt"
|
||||
"steps.rkt")
|
||||
|
||||
(require scheme/match
|
||||
"trace.ss"
|
||||
"reductions.ss"
|
||||
"reductions-config.ss"
|
||||
"deriv-util.ss"
|
||||
"hiding-policies.ss"
|
||||
"deriv.ss"
|
||||
"steps.ss")
|
||||
|
||||
(provide (all-from-out "trace.ss")
|
||||
(all-from-out "reductions.ss")
|
||||
(all-from-out "reductions-config.ss")
|
||||
(all-from-out "deriv.ss")
|
||||
(all-from-out "deriv-util.ss")
|
||||
(all-from-out "hiding-policies.ss")
|
||||
(all-from-out "steps.ss")
|
||||
(all-from-out scheme/match))
|
||||
(provide (all-from-out "trace.rkt")
|
||||
(all-from-out "reductions.rkt")
|
||||
(all-from-out "reductions-config.rkt")
|
||||
(all-from-out "deriv.rkt")
|
||||
(all-from-out "deriv-util.rkt")
|
||||
(all-from-out "hiding-policies.rkt")
|
||||
(all-from-out "steps.rkt")
|
||||
(all-from-out racket/match))
|
||||
|
|
|
|||
|
|
@ -1,5 +1,4 @@
|
|||
|
||||
#lang scheme/base
|
||||
#lang racket/base
|
||||
(provide (all-defined-out))
|
||||
|
||||
;; A Node(a) is:
|
||||
|
|
|
|||
|
|
@ -1,12 +1,11 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require (for-syntax scheme/base)
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base)
|
||||
syntax/stx
|
||||
"yacc-ext.ss"
|
||||
"yacc-interrupted.ss"
|
||||
"deriv.ss"
|
||||
"deriv-util.ss"
|
||||
"deriv-tokens.ss")
|
||||
"yacc-ext.rkt"
|
||||
"yacc-interrupted.rkt"
|
||||
"deriv.rkt"
|
||||
"deriv-util.rkt"
|
||||
"deriv-tokens.rkt")
|
||||
(provide parse-derivation)
|
||||
|
||||
(define (deriv-error ok? name value start end)
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
|
||||
#lang scheme/base
|
||||
#lang racket/base
|
||||
(require parser-tools/lex
|
||||
"deriv.ss")
|
||||
"deriv.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define-tokens basic-tokens
|
||||
|
|
|
|||
|
|
@ -1,11 +1,10 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require (for-syntax scheme/base)
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base)
|
||||
(for-syntax racket/private/struct-info)
|
||||
scheme/list
|
||||
scheme/match
|
||||
racket/list
|
||||
racket/match
|
||||
unstable/struct
|
||||
"deriv.ss")
|
||||
"deriv.rkt")
|
||||
|
||||
(provide make
|
||||
|
||||
|
|
|
|||
|
|
@ -1,368 +1,5 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require scheme/contract
|
||||
#lang racket/base
|
||||
(require racket/contract
|
||||
syntax/stx
|
||||
"deriv-c.ss")
|
||||
|
||||
(provide (all-from-out "deriv-c.ss"))
|
||||
|
||||
#|
|
||||
|
||||
(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 syntax/f (?? syntax?))
|
||||
(define syntaxes/c stx-list-like?)
|
||||
(define syntaxes/f (?? syntaxes/c))
|
||||
(define resolves/c (listof identifier?))
|
||||
|
||||
(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))]
|
||||
[me2 (?? syntax?)]
|
||||
[?2 (?? exn?)]
|
||||
[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 (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 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 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?])))
|
||||
|#
|
||||
"deriv-c.rkt")
|
||||
(provide (all-from-out "deriv-c.rkt"))
|
||||
|
|
|
|||
|
|
@ -1,10 +1,8 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require (for-syntax scheme/base)
|
||||
scheme/match
|
||||
syntax/boundmap
|
||||
"reductions-config.ss"
|
||||
"../util/mpi.ss")
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base)
|
||||
racket/match
|
||||
"reductions-config.rkt"
|
||||
"../util/mpi.rkt")
|
||||
(provide policy->predicate)
|
||||
|
||||
;; A Policy is one of
|
||||
|
|
|
|||
|
|
@ -1,14 +1,13 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (for-syntax scheme/base)
|
||||
scheme/list
|
||||
scheme/contract
|
||||
scheme/match
|
||||
"deriv.ss"
|
||||
"deriv-util.ss"
|
||||
"stx-util.ss"
|
||||
"context.ss"
|
||||
"steps.ss")
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base)
|
||||
racket/list
|
||||
racket/contract
|
||||
racket/match
|
||||
"deriv.rkt"
|
||||
"deriv-util.rkt"
|
||||
"stx-util.rkt"
|
||||
"context.rkt"
|
||||
"steps.rkt")
|
||||
|
||||
(define-syntax-rule (STRICT-CHECKS form ...)
|
||||
(when #f
|
||||
|
|
|
|||
|
|
@ -1,16 +1,16 @@
|
|||
#lang scheme/base
|
||||
(require (for-syntax scheme/base)
|
||||
(for-syntax syntax/parse)
|
||||
scheme/list
|
||||
scheme/contract
|
||||
"deriv.ss"
|
||||
"deriv-util.ss"
|
||||
"stx-util.ss"
|
||||
"context.ss"
|
||||
"steps.ss"
|
||||
"reductions-config.ss")
|
||||
(provide (all-from-out "steps.ss")
|
||||
(all-from-out "reductions-config.ss")
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
syntax/parse)
|
||||
racket/list
|
||||
racket/contract
|
||||
"deriv.rkt"
|
||||
"deriv-util.rkt"
|
||||
"stx-util.rkt"
|
||||
"context.rkt"
|
||||
"steps.rkt"
|
||||
"reductions-config.rkt")
|
||||
(provide (all-from-out "steps.rkt")
|
||||
(all-from-out "reductions-config.rkt")
|
||||
DEBUG
|
||||
R
|
||||
!)
|
||||
|
|
|
|||
|
|
@ -1,10 +1,9 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require scheme/match
|
||||
"stx-util.ss"
|
||||
"deriv-util.ss"
|
||||
"deriv.ss"
|
||||
"reductions-engine.ss")
|
||||
#lang racket/base
|
||||
(require racket/match
|
||||
"stx-util.rkt"
|
||||
"deriv-util.rkt"
|
||||
"deriv.rkt"
|
||||
"reductions-engine.rkt")
|
||||
|
||||
(provide reductions
|
||||
reductions+)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang scheme/base
|
||||
(require "deriv.ss"
|
||||
"deriv-util.ss")
|
||||
#lang racket/base
|
||||
(require "deriv.rkt"
|
||||
"deriv-util.rkt")
|
||||
(provide (struct-out protostep)
|
||||
(struct-out step)
|
||||
(struct-out misstep)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require (for-syntax scheme/base)
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base)
|
||||
syntax/stx)
|
||||
|
||||
(provide (all-defined-out)
|
||||
|
|
|
|||
|
|
@ -1,10 +1,9 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require scheme/class
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
parser-tools/lex
|
||||
"deriv-tokens.ss"
|
||||
"deriv-parser.ss"
|
||||
"../syntax-browser.ss")
|
||||
"deriv-tokens.rkt"
|
||||
"deriv-parser.rkt"
|
||||
"../syntax-browser.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define current-expand-observe
|
||||
|
|
|
|||
|
|
@ -1,10 +1,9 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require scheme/promise
|
||||
#lang racket/base
|
||||
(require racket/promise
|
||||
parser-tools/lex
|
||||
"deriv.ss"
|
||||
"deriv-parser.ss"
|
||||
"deriv-tokens.ss")
|
||||
"deriv.rkt"
|
||||
"deriv-parser.rkt"
|
||||
"deriv-tokens.rkt")
|
||||
|
||||
(provide trace
|
||||
trace*
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require (prefix-in yacc: parser-tools/yacc)
|
||||
(for-syntax scheme/base))
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base)
|
||||
(prefix-in yacc: parser-tools/yacc))
|
||||
(provide parser
|
||||
options
|
||||
productions
|
||||
|
|
|
|||
|
|
@ -1,9 +1,7 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require (for-syntax scheme/base
|
||||
mzlib/etc
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
unstable/syntax)
|
||||
"yacc-ext.ss")
|
||||
"yacc-ext.rkt")
|
||||
(provide ! ? !!
|
||||
define-production-splitter
|
||||
skipped-token-values
|
||||
|
|
|
|||
|
|
@ -1,13 +1,12 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require scheme/list
|
||||
scheme/pretty
|
||||
"model/trace.ss"
|
||||
"model/reductions.ss"
|
||||
"model/reductions-config.ss"
|
||||
"model/steps.ss"
|
||||
"syntax-browser/partition.ss"
|
||||
"syntax-browser/pretty-helper.ss")
|
||||
#lang racket/base
|
||||
(require racket/list
|
||||
racket/pretty
|
||||
"model/trace.rkt"
|
||||
"model/reductions.rkt"
|
||||
"model/reductions-config.rkt"
|
||||
"model/steps.rkt"
|
||||
"syntax-browser/partition.rkt"
|
||||
"syntax-browser/pretty-helper.rkt")
|
||||
(provide expand/step-text
|
||||
stepper-text)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require "view/view.ss")
|
||||
#lang racket/base
|
||||
(require "view/view.rkt")
|
||||
(provide expand/step)
|
||||
|
||||
(define (expand/step stx)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require "syntax-browser/frame.ss")
|
||||
#lang racket/base
|
||||
(require "syntax-browser/frame.rkt")
|
||||
(provide browse-syntax
|
||||
browse-syntaxes
|
||||
make-syntax-browser)
|
||||
|
|
|
|||
|
|
@ -1,10 +1,8 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
(rename-in unstable/class-iop
|
||||
[send/i send:]
|
||||
[init-field/i init-field:])
|
||||
"interfaces.ss"
|
||||
"partition.ss"
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
unstable/class-iop
|
||||
"interfaces.rkt"
|
||||
"partition.rkt"
|
||||
unstable/gui/notify)
|
||||
(provide controller%)
|
||||
|
||||
|
|
@ -33,13 +31,13 @@
|
|||
(super-new)
|
||||
(listen-selected-syntax
|
||||
(lambda (new-value)
|
||||
(for-each (lambda (display) (send: display display<%> refresh))
|
||||
(for-each (lambda (display) (send/i display display<%> refresh))
|
||||
displays)))))
|
||||
|
||||
;; mark-manager-mixin
|
||||
(define mark-manager-mixin
|
||||
(mixin () (mark-manager<%>)
|
||||
(init-field: [primary-partition partition<%> (new-bound-partition)])
|
||||
(init-field/i [primary-partition partition<%> (new-bound-partition)])
|
||||
(super-new)
|
||||
|
||||
;; get-primary-partition : -> partition
|
||||
|
|
@ -65,7 +63,7 @@
|
|||
(listen-secondary-partition
|
||||
(lambda (p)
|
||||
(for ([d displays])
|
||||
(send: d display<%> refresh))))
|
||||
(send/i d display<%> refresh))))
|
||||
(super-new)))
|
||||
|
||||
(define controller%
|
||||
|
|
|
|||
|
|
@ -1,16 +1,14 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
scheme/gui
|
||||
scheme/list
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/gui
|
||||
racket/list
|
||||
racket/block
|
||||
framework
|
||||
(rename-in unstable/class-iop
|
||||
[send/i send:]
|
||||
[init-field/i init-field:])
|
||||
(only-in mzlib/etc begin-with-definitions)
|
||||
"pretty-printer.ss"
|
||||
"interfaces.ss"
|
||||
"prefs.ss"
|
||||
"util.ss")
|
||||
unstable/class-iop
|
||||
"pretty-printer.rkt"
|
||||
"interfaces.rkt"
|
||||
"prefs.rkt"
|
||||
"util.rkt")
|
||||
(provide print-syntax-to-editor
|
||||
code-style)
|
||||
|
||||
|
|
@ -27,13 +25,13 @@
|
|||
;; -> display<%>
|
||||
(define (print-syntax-to-editor stx text controller config columns
|
||||
[insertion-point (send text last-position)])
|
||||
(begin-with-definitions
|
||||
(block
|
||||
(define output-port (open-output-string/count-lines))
|
||||
(define range
|
||||
(pretty-print-syntax stx output-port
|
||||
(send: controller controller<%> get-primary-partition)
|
||||
(length (send: config config<%> get-colors))
|
||||
(send: config config<%> get-suffix-option)
|
||||
(send/i controller controller<%> get-primary-partition)
|
||||
(length (send/i config config<%> get-colors))
|
||||
(send/i config config<%> get-suffix-option)
|
||||
(send config get-pretty-styles)
|
||||
columns))
|
||||
(define output-string (get-output-string output-port))
|
||||
|
|
@ -56,15 +54,15 @@
|
|||
;; display%
|
||||
(define display%
|
||||
(class* object% (display<%>)
|
||||
(init-field: [controller controller<%>]
|
||||
[config config<%>]
|
||||
[range range<%>])
|
||||
(init-field/i [controller controller<%>]
|
||||
[config config<%>]
|
||||
[range range<%>])
|
||||
(init-field text
|
||||
start-position
|
||||
end-position)
|
||||
|
||||
(define base-style
|
||||
(code-style text (send: config config<%> get-syntax-font-size)))
|
||||
(code-style text (send/i config config<%> get-syntax-font-size)))
|
||||
|
||||
(define extra-styles (make-hasheq))
|
||||
|
||||
|
|
@ -78,10 +76,10 @@
|
|||
;; add-clickbacks : -> void
|
||||
(define/private (add-clickbacks)
|
||||
(define (the-clickback editor start end)
|
||||
(send: controller selection-manager<%> set-selected-syntax
|
||||
(send/i controller selection-manager<%> set-selected-syntax
|
||||
(clickback->stx
|
||||
(- start start-position) (- end start-position))))
|
||||
(for ([range (send: range range<%> all-ranges)])
|
||||
(for ([range (send/i range range<%> all-ranges)])
|
||||
(let ([stx (range-obj range)]
|
||||
[start (range-start range)]
|
||||
[end (range-end range)])
|
||||
|
|
@ -91,7 +89,7 @@
|
|||
;; clickback->stx : num num -> syntax
|
||||
;; FIXME: use vectors for treerange-subs and do binary search to narrow?
|
||||
(define/private (clickback->stx start end)
|
||||
(let ([treeranges (send: range range<%> get-treeranges)])
|
||||
(let ([treeranges (send/i range range<%> get-treeranges)])
|
||||
(let loop* ([treeranges treeranges])
|
||||
(for/or ([tr treeranges])
|
||||
(cond [(and (= (treerange-start tr) start)
|
||||
|
|
@ -111,7 +109,7 @@
|
|||
(change-style (unhighlight-d) start-position end-position))
|
||||
(apply-extra-styles)
|
||||
(let ([selected-syntax
|
||||
(send: controller selection-manager<%>
|
||||
(send/i controller selection-manager<%>
|
||||
get-selected-syntax)])
|
||||
(apply-secondary-partition-styles selected-syntax)
|
||||
(apply-selection-styles selected-syntax))
|
||||
|
|
@ -162,13 +160,13 @@
|
|||
(list->vector
|
||||
(map color-style
|
||||
(map translate-color
|
||||
(send: config config<%> get-colors)))))
|
||||
(send/i config config<%> get-colors)))))
|
||||
(define overflow-style (color-style (translate-color "darkgray")))
|
||||
(define color-partition
|
||||
(send: controller mark-manager<%> get-primary-partition))
|
||||
(send/i controller mark-manager<%> get-primary-partition))
|
||||
(define offset start-position)
|
||||
;; Optimization: don't call change-style when new style = old style
|
||||
(let tr*loop ([trs (send: range range<%> get-treeranges)] [old-style #f])
|
||||
(let tr*loop ([trs (send/i range range<%> get-treeranges)] [old-style #f])
|
||||
(for ([tr trs])
|
||||
(define stx (treerange-obj tr))
|
||||
(define start (treerange-start tr))
|
||||
|
|
@ -184,7 +182,7 @@
|
|||
;; 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 partition<%> get-partition stx)])
|
||||
(let ([n (send/i partition partition<%> get-partition stx)])
|
||||
(cond [(< n (vector-length color-vector))
|
||||
(vector-ref color-vector n)]
|
||||
[else
|
||||
|
|
@ -197,7 +195,7 @@
|
|||
;; Applies externally-added styles (such as highlighting)
|
||||
(define/private (apply-extra-styles)
|
||||
(for ([(stx style-deltas) extra-styles])
|
||||
(for ([r (send: range range<%> get-ranges stx)])
|
||||
(for ([r (send/i range range<%> get-ranges stx)])
|
||||
(for ([style-delta style-deltas])
|
||||
(restyle-range r style-delta)))))
|
||||
|
||||
|
|
@ -207,23 +205,23 @@
|
|||
(define/private (apply-secondary-partition-styles selected-syntax)
|
||||
(when (identifier? selected-syntax)
|
||||
(let ([partition
|
||||
(send: controller secondary-partition<%>
|
||||
(send/i controller secondary-partition<%>
|
||||
get-secondary-partition)])
|
||||
(when partition
|
||||
(for ([id (send: range range<%> get-identifier-list)])
|
||||
(when (send: partition partition<%>
|
||||
(for ([id (send/i range range<%> get-identifier-list)])
|
||||
(when (send/i partition partition<%>
|
||||
same-partition? selected-syntax id)
|
||||
(draw-secondary-connection id)))))))
|
||||
|
||||
;; apply-selection-styles : syntax -> void
|
||||
;; Styles subterms eq to the selected syntax
|
||||
(define/private (apply-selection-styles selected-syntax)
|
||||
(for ([r (send: range range<%> get-ranges selected-syntax)])
|
||||
(for ([r (send/i range range<%> get-ranges selected-syntax)])
|
||||
(restyle-range r (select-highlight-d))))
|
||||
|
||||
;; draw-secondary-connection : syntax -> void
|
||||
(define/private (draw-secondary-connection stx2)
|
||||
(for ([r (send: range range<%> get-ranges stx2)])
|
||||
(for ([r (send/i range range<%> get-ranges stx2)])
|
||||
(restyle-range r (select-sub-highlight-d))))
|
||||
|
||||
;; restyle-range : (cons num num) style-delta% -> void
|
||||
|
|
@ -238,11 +236,11 @@
|
|||
|
||||
;; Initialize
|
||||
(super-new)
|
||||
(send: controller controller<%> add-syntax-display this)))
|
||||
(send/i controller controller<%> add-syntax-display this)))
|
||||
|
||||
;; fixup-parentheses : string range -> void
|
||||
(define (fixup-parentheses string range)
|
||||
(for ([r (send: range range<%> all-ranges)])
|
||||
(for ([r (send/i range range<%> all-ranges)])
|
||||
(let ([stx (range-obj r)]
|
||||
[start (range-start r)]
|
||||
[end (range-end r)])
|
||||
|
|
|
|||
|
|
@ -1,11 +1,10 @@
|
|||
#lang racket/base
|
||||
(require "interfaces.rkt"
|
||||
"widget.rkt"
|
||||
"keymap.rkt"
|
||||
"partition.rkt")
|
||||
|
||||
#lang scheme/base
|
||||
(require "interfaces.ss"
|
||||
"widget.ss"
|
||||
"keymap.ss"
|
||||
"partition.ss")
|
||||
|
||||
(provide (all-from-out "interfaces.ss")
|
||||
(all-from-out "widget.ss")
|
||||
(all-from-out "keymap.ss")
|
||||
(provide (all-from-out "interfaces.rkt")
|
||||
(all-from-out "widget.rkt")
|
||||
(all-from-out "keymap.rkt")
|
||||
identifier=-choices)
|
||||
|
|
|
|||
|
|
@ -1,17 +1,13 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
(rename-in unstable/class-iop
|
||||
[define/i define:]
|
||||
[send/i send:]
|
||||
[send*/i send*:]
|
||||
[init-field/i init-field:])
|
||||
scheme/gui
|
||||
framework/framework
|
||||
scheme/list
|
||||
"interfaces.ss"
|
||||
"partition.ss"
|
||||
"prefs.ss"
|
||||
"widget.ss")
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/gui
|
||||
racket/list
|
||||
framework
|
||||
unstable/class-iop
|
||||
"interfaces.rkt"
|
||||
"partition.rkt"
|
||||
"prefs.rkt"
|
||||
"widget.rkt")
|
||||
(provide browse-syntax
|
||||
browse-syntaxes
|
||||
make-syntax-browser
|
||||
|
|
@ -26,7 +22,7 @@
|
|||
(define (browse-syntaxes stxs)
|
||||
(let ((w (make-syntax-browser)))
|
||||
(for ([stx stxs])
|
||||
(send*: w syntax-browser<%>
|
||||
(send*/i w syntax-browser<%>
|
||||
(add-syntax stx)
|
||||
(add-separator)))))
|
||||
|
||||
|
|
@ -41,17 +37,17 @@
|
|||
(class* frame% ()
|
||||
(inherit get-width
|
||||
get-height)
|
||||
(init-field: [config config<%> (new syntax-prefs%)])
|
||||
(init-field/i [config config<%> (new syntax-prefs%)])
|
||||
(super-new (label "Syntax Browser")
|
||||
(width (send: config config<%> get-width))
|
||||
(height (send: config config<%> get-height)))
|
||||
(define: widget syntax-browser<%>
|
||||
(width (send/i config config<%> get-width))
|
||||
(height (send/i config config<%> get-height)))
|
||||
(define/i widget syntax-browser<%>
|
||||
(new syntax-widget/controls%
|
||||
(parent this)
|
||||
(config config)))
|
||||
(define/public (get-widget) widget)
|
||||
(define/augment (on-close)
|
||||
(send*: config config<%>
|
||||
(send*/i config config<%>
|
||||
(set-width (get-width))
|
||||
(set-height (get-height)))
|
||||
(send widget shutdown)
|
||||
|
|
@ -81,22 +77,22 @@
|
|||
(choices (map car -identifier=-choices))
|
||||
(callback
|
||||
(lambda (c e)
|
||||
(send: (get-controller) controller<%> set-identifier=?
|
||||
(send/i (get-controller) controller<%> set-identifier=?
|
||||
(assoc (send c get-string-selection)
|
||||
-identifier=-choices))))))
|
||||
(new button%
|
||||
(label "Clear")
|
||||
(parent -control-panel)
|
||||
(callback (lambda _ (send: (get-controller) controller<%> set-selected-syntax #f))))
|
||||
(callback (lambda _ (send/i (get-controller) controller<%> set-selected-syntax #f))))
|
||||
(new button%
|
||||
(label "Properties")
|
||||
(parent -control-panel)
|
||||
(callback
|
||||
(lambda _
|
||||
(send: config config<%> set-props-shown?
|
||||
(not (send: config config<%> get-props-shown?))))))
|
||||
(send/i config config<%> set-props-shown?
|
||||
(not (send/i config config<%> get-props-shown?))))))
|
||||
|
||||
(send: (get-controller) controller<%> listen-identifier=?
|
||||
(send/i (get-controller) controller<%> listen-identifier=?
|
||||
(lambda (name+func)
|
||||
(send -choice set-selection
|
||||
(or (send -choice find-string (car name+func)) 0))))
|
||||
|
|
|
|||
|
|
@ -1,8 +1,6 @@
|
|||
|
||||
#lang scheme/base
|
||||
|
||||
(require scheme/class
|
||||
scheme/gui)
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/gui)
|
||||
(provide hrule-snip%)
|
||||
|
||||
;; hrule-snip%
|
||||
|
|
@ -53,5 +51,5 @@
|
|||
(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")))
|
||||
(format "~s" '(lib "hrule-snip.rkt" "macro-debugger" "syntax-browser")))
|
||||
(send (get-the-snip-class-list) add snip-class)
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
#lang scheme/base
|
||||
(require scheme/contract
|
||||
scheme/class
|
||||
scheme/gui
|
||||
#lang racket/base
|
||||
(require racket/contract
|
||||
racket/class
|
||||
racket/gui
|
||||
framework
|
||||
"prefs.ss"
|
||||
"controller.ss"
|
||||
"display.ss")
|
||||
"prefs.rkt"
|
||||
"controller.rkt"
|
||||
"display.rkt")
|
||||
|
||||
#|
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
unstable/class-iop
|
||||
(for-syntax scheme/base))
|
||||
(for-syntax racket/base))
|
||||
(provide (all-defined-out))
|
||||
|
||||
;; Helpers
|
||||
|
|
@ -14,7 +14,7 @@
|
|||
[else (error '->string)]))
|
||||
(string->symbol (apply string-append (map ->string args))))
|
||||
|
||||
;; not in notify.ss because notify depends on scheme/gui
|
||||
;; not in notify.rkt because notify depends on gui
|
||||
(define-interface-expander methods:notify
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
scheme/gui
|
||||
scheme/pretty
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/gui
|
||||
racket/pretty
|
||||
unstable/gui/notify
|
||||
"interfaces.ss"
|
||||
"partition.ss")
|
||||
"interfaces.rkt"
|
||||
"partition.rkt")
|
||||
(provide syntax-keymap%)
|
||||
|
||||
(define keymap/popup%
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
syntax/boundmap
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
syntax/stx
|
||||
"interfaces.rkt"
|
||||
"../util/stxobj.rkt")
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
framework/framework
|
||||
"interfaces.ss"
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
framework
|
||||
"interfaces.rkt"
|
||||
unstable/gui/notify
|
||||
unstable/gui/prefs)
|
||||
(provide prefs-base%
|
||||
|
|
|
|||
|
|
@ -1,11 +1,10 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
scheme/pretty
|
||||
(rename-in unstable/class-iop
|
||||
[send/i send:])
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/pretty
|
||||
unstable/class-iop
|
||||
syntax/stx
|
||||
unstable/struct
|
||||
"interfaces.ss")
|
||||
"interfaces.rkt")
|
||||
(provide (all-defined-out))
|
||||
|
||||
;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it
|
||||
|
|
@ -64,12 +63,12 @@
|
|||
((never)
|
||||
(make-id-syntax-dummy sym sym))
|
||||
((always)
|
||||
(let ([n (send: partition partition<%> get-partition id)])
|
||||
(let ([n (send/i partition partition<%> get-partition id)])
|
||||
(if (zero? n)
|
||||
(make-id-syntax-dummy sym sym)
|
||||
(make-id-syntax-dummy (suffix sym n) sym))))
|
||||
((over-limit)
|
||||
(let ([n (send: partition partition<%> get-partition id)])
|
||||
(let ([n (send/i partition partition<%> get-partition id)])
|
||||
(if (<= n limit)
|
||||
(make-id-syntax-dummy sym sym)
|
||||
(make-id-syntax-dummy (suffix sym n) sym))))))
|
||||
|
|
@ -82,7 +81,7 @@
|
|||
=> (lambda (datum) datum)]
|
||||
[(and partition (identifier? obj))
|
||||
(when (and (eq? suffixopt 'all-if-over-limit)
|
||||
(> (send: partition partition<%> count) limit))
|
||||
(> (send/i partition partition<%> count) limit))
|
||||
(call-with-values (lambda () (table stx partition #f 'always))
|
||||
escape))
|
||||
(let ([lp-datum (make-identifier-proxy obj)])
|
||||
|
|
@ -91,7 +90,7 @@
|
|||
lp-datum)]
|
||||
[(and (syntax? obj) (check+convert-special-expression obj))
|
||||
=> (lambda (newobj)
|
||||
(when partition (send: partition partition<%> get-partition obj))
|
||||
(when partition (send/i partition partition<%> get-partition obj))
|
||||
(let* ([inner (cadr newobj)]
|
||||
[lp-inner-datum (loop inner)]
|
||||
[lp-datum (list (car newobj) lp-inner-datum)])
|
||||
|
|
@ -101,7 +100,7 @@
|
|||
(hash-set! stx=>flat obj lp-datum)
|
||||
lp-datum))]
|
||||
[(syntax? obj)
|
||||
(when partition (send: partition partition<%> get-partition obj))
|
||||
(when partition (send/i partition partition<%> get-partition obj))
|
||||
(let ([lp-datum (loop (syntax-e obj))])
|
||||
(hash-set! flat=>stx lp-datum obj)
|
||||
(hash-set! stx=>flat obj lp-datum)
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
#lang scheme/base
|
||||
(require scheme/list
|
||||
scheme/class
|
||||
scheme/pretty
|
||||
scheme/gui
|
||||
"pretty-helper.ss"
|
||||
"interfaces.ss")
|
||||
#lang racket/base
|
||||
(require racket/list
|
||||
racket/class
|
||||
racket/pretty
|
||||
racket/gui
|
||||
"pretty-helper.rkt"
|
||||
"interfaces.rkt")
|
||||
(provide pretty-print-syntax)
|
||||
|
||||
;; FIXME: Need to disable printing of structs with custom-write property
|
||||
|
|
|
|||
|
|
@ -1,12 +1,11 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
scheme/gui
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/gui
|
||||
framework
|
||||
(rename-in unstable/class-iop
|
||||
[send/i send:])
|
||||
"interfaces.ss"
|
||||
"util.ss"
|
||||
"../util/mpi.ss"
|
||||
unstable/class-iop
|
||||
"interfaces.rkt"
|
||||
"util.rkt"
|
||||
"../util/mpi.rkt"
|
||||
"../util/stxobj.rkt")
|
||||
(provide properties-view%
|
||||
properties-snip%)
|
||||
|
|
@ -44,10 +43,10 @@
|
|||
(field (text (new color-text%)))
|
||||
(field (pdisplayer (new properties-displayer% (text text))))
|
||||
|
||||
(send: controller selection-manager<%> listen-selected-syntax
|
||||
(lambda (stx)
|
||||
(set! selected-syntax stx)
|
||||
(refresh)))
|
||||
(send/i controller selection-manager<%> listen-selected-syntax
|
||||
(lambda (stx)
|
||||
(set! selected-syntax stx)
|
||||
(refresh)))
|
||||
(super-new)
|
||||
|
||||
;; get-mode : -> symbol
|
||||
|
|
|
|||
|
|
@ -1,14 +1,13 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
(rename-in unstable/class-iop
|
||||
[send/i send:])
|
||||
mzlib/string
|
||||
mred
|
||||
"interfaces.ss"
|
||||
"controller.ss"
|
||||
"properties.ss"
|
||||
"prefs.ss"
|
||||
(except-in "snip.ss"
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/gui
|
||||
(only-in mzlib/string read-from-string)
|
||||
unstable/class-iop
|
||||
"interfaces.rkt"
|
||||
"controller.rkt"
|
||||
"properties.rkt"
|
||||
"prefs.rkt"
|
||||
(except-in "snip.rkt"
|
||||
snip-class))
|
||||
|
||||
(provide decorated-syntax-snip%
|
||||
|
|
@ -145,8 +144,8 @@
|
|||
(define/public (read-special src line col pos)
|
||||
(send the-syntax-snip read-special src line col pos))
|
||||
|
||||
(send: config config<%> listen-props-shown?
|
||||
(lambda (?) (refresh-contents)))
|
||||
(send/i config config<%> listen-props-shown?
|
||||
(lambda (?) (refresh-contents)))
|
||||
|
||||
(super-new)
|
||||
(set-snipclass snip-class)
|
||||
|
|
@ -198,7 +197,7 @@
|
|||
|
||||
;; SNIPCLASS
|
||||
|
||||
;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
|
||||
;; COPIED AND MODIFIED from mrlib/syntax-browser.rkt
|
||||
(define decorated-syntax-snipclass%
|
||||
(class snip-class%
|
||||
(define/override (read stream)
|
||||
|
|
@ -210,4 +209,4 @@
|
|||
(define snip-class (make-object decorated-syntax-snipclass%))
|
||||
(send snip-class set-version 2)
|
||||
(send snip-class set-classname
|
||||
(format "~s" '(lib "macro-debugger/syntax-browser/snip-decorated.ss")))
|
||||
(format "~s" '(lib "macro-debugger/syntax-browser/snip-decorated.rkt")))
|
||||
|
|
|
|||
|
|
@ -1,16 +1,14 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
(rename-in unstable/class-iop
|
||||
[send/i send:])
|
||||
scheme/match
|
||||
mzlib/string
|
||||
mred
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/gui
|
||||
racket/match
|
||||
(only-in mzlib/string read-from-string)
|
||||
framework
|
||||
"interfaces.ss"
|
||||
"display.ss"
|
||||
"controller.ss"
|
||||
"keymap.ss"
|
||||
"prefs.ss")
|
||||
"interfaces.rkt"
|
||||
"display.rkt"
|
||||
"controller.rkt"
|
||||
"keymap.rkt"
|
||||
"prefs.rkt")
|
||||
|
||||
(provide syntax-snip%
|
||||
marshall-syntax
|
||||
|
|
@ -167,7 +165,7 @@
|
|||
|
||||
;; SNIPCLASS
|
||||
|
||||
;; COPIED AND MODIFIED from mrlib/syntax-browser.ss
|
||||
;; COPIED AND MODIFIED from mrlib/syntax-browser.rkt
|
||||
(define syntax-snipclass%
|
||||
(class snip-class%
|
||||
(define/override (read stream)
|
||||
|
|
@ -178,4 +176,4 @@
|
|||
(define snip-class (new syntax-snipclass%))
|
||||
(send snip-class set-version 2)
|
||||
(send snip-class set-classname
|
||||
(format "~s" '(lib "macro-debugger/syntax-browser/snip.ss")))
|
||||
(format "~s" '(lib "macro-debugger/syntax-browser/snip.rkt")))
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
#lang scheme/base
|
||||
(require scheme/list
|
||||
scheme/class
|
||||
scheme/gui
|
||||
#lang racket/base
|
||||
(require racket/list
|
||||
racket/class
|
||||
racket/gui
|
||||
drracket/arrow
|
||||
framework/framework
|
||||
unstable/interval-map
|
||||
unstable/gui/notify
|
||||
"interfaces.ss")
|
||||
"interfaces.rkt")
|
||||
|
||||
(provide text:hover<%>
|
||||
text:hover-drawings<%>
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require scheme/class)
|
||||
#lang racket/base
|
||||
(require racket/class)
|
||||
(provide with-unlock
|
||||
make-text-port)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,21 +1,20 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
mred
|
||||
framework/framework
|
||||
scheme/list
|
||||
scheme/match
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/gui
|
||||
racket/list
|
||||
racket/match
|
||||
framework
|
||||
syntax/id-table
|
||||
(rename-in unstable/class-iop
|
||||
[send/i send:])
|
||||
"interfaces.ss"
|
||||
"controller.ss"
|
||||
"display.ss"
|
||||
"keymap.ss"
|
||||
"hrule-snip.ss"
|
||||
"properties.ss"
|
||||
"text.ss"
|
||||
"util.ss"
|
||||
"../util/mpi.ss")
|
||||
unstable/class-iop
|
||||
"interfaces.rkt"
|
||||
"controller.rkt"
|
||||
"display.rkt"
|
||||
"keymap.rkt"
|
||||
"hrule-snip.rkt"
|
||||
"properties.rkt"
|
||||
"text.rkt"
|
||||
"util.rkt"
|
||||
"../util/mpi.rkt")
|
||||
(provide widget%)
|
||||
|
||||
;; widget%
|
||||
|
|
@ -55,7 +54,7 @@
|
|||
(define/private (internal-show-props show?)
|
||||
(if show?
|
||||
(unless (send -props-panel is-shown?)
|
||||
(let ([p (send: config config<%> get-props-percentage)])
|
||||
(let ([p (send/i config config<%> get-props-percentage)])
|
||||
(send -split-panel add-child -props-panel)
|
||||
(update-props-percentage p))
|
||||
(send -props-panel show #t))
|
||||
|
|
@ -82,7 +81,7 @@
|
|||
|
||||
(define/public (shutdown)
|
||||
(when (props-panel-shown?)
|
||||
(send: config config<%> set-props-percentage
|
||||
(send/i config config<%> set-props-percentage
|
||||
(cadr (send -split-panel get-percentages)))))
|
||||
|
||||
;; syntax-browser<%> Methods
|
||||
|
|
@ -115,29 +114,29 @@
|
|||
#:substitutions [substitutions null])
|
||||
(let ([display (internal-add-syntax stx)]
|
||||
[definite-table (make-hasheq)])
|
||||
(let ([range (send: display display<%> get-range)]
|
||||
[offset (send: display display<%> get-start-position)])
|
||||
(let ([range (send/i display display<%> get-range)]
|
||||
[offset (send/i display display<%> get-start-position)])
|
||||
(for ([subst substitutions])
|
||||
(for ([r (send: range range<%> get-ranges (car subst))])
|
||||
(for ([r (send/i range range<%> get-ranges (car subst))])
|
||||
(with-unlock -text
|
||||
(send -text insert (cdr subst)
|
||||
(+ offset (car r))
|
||||
(+ offset (cdr r))
|
||||
#f)
|
||||
(send -text change-style
|
||||
(code-style -text (send: config config<%> get-syntax-font-size))
|
||||
(code-style -text (send/i config config<%> get-syntax-font-size))
|
||||
(+ offset (car r))
|
||||
(+ offset (cdr r)))))))
|
||||
(for ([hi-stxs hi-stxss] [hi-color hi-colors])
|
||||
(send: display display<%> highlight-syntaxes hi-stxs hi-color))
|
||||
(send/i display display<%> highlight-syntaxes hi-stxs hi-color))
|
||||
(for ([definite definites])
|
||||
(hash-set! definite-table definite #t)
|
||||
(when shift-table
|
||||
(for ([shifted-definite (hash-ref shift-table definite null)])
|
||||
(hash-set! definite-table shifted-definite #t))))
|
||||
(let ([binder-table (make-free-id-table)])
|
||||
(define range (send: display display<%> get-range))
|
||||
(define start (send: display display<%> get-start-position))
|
||||
(define range (send/i display display<%> get-range))
|
||||
(define start (send/i display display<%> get-start-position))
|
||||
(define (get-binders id)
|
||||
(let ([binder (free-id-table-ref binder-table id #f)])
|
||||
(cond [(not binder) null]
|
||||
|
|
@ -149,17 +148,17 @@
|
|||
(for ([binder binders])
|
||||
(free-id-table-set! binder-table binder binder))
|
||||
;; Underline binders (and shifted binders)
|
||||
(send: display display<%> underline-syntaxes
|
||||
(send/i display display<%> underline-syntaxes
|
||||
(append (apply append (map get-shifted binders))
|
||||
binders))
|
||||
;; Make arrows (& billboards, when enabled)
|
||||
(for ([id (send: range range<%> get-identifier-list)])
|
||||
(for ([id (send/i range range<%> get-identifier-list)])
|
||||
(define definite? (hash-ref definite-table id #f))
|
||||
(when #f ;; DISABLED
|
||||
(add-binding-billboard start range id definite?))
|
||||
(for ([binder (get-binders id)])
|
||||
(for ([binder-r (send: range range<%> get-ranges binder)])
|
||||
(for ([id-r (send: range range<%> get-ranges id)])
|
||||
(for ([binder-r (send/i range range<%> get-ranges binder)])
|
||||
(for ([id-r (send/i range range<%> get-ranges id)])
|
||||
(add-binding-arrow start binder-r id-r definite?))))))
|
||||
(void)))
|
||||
|
||||
|
|
@ -187,7 +186,7 @@
|
|||
(+ start (cdr id-r))
|
||||
(string-append "from " (mpi->string src-mod))
|
||||
(if definite? "blue" "purple")))
|
||||
(send: range range<%> get-ranges id))]
|
||||
(send/i range range<%> get-ranges id))]
|
||||
[_ (void)]))
|
||||
|
||||
(define/public (add-separator)
|
||||
|
|
@ -200,7 +199,7 @@
|
|||
(with-unlock -text
|
||||
(send -text erase)
|
||||
(send -text delete-all-drawings))
|
||||
(send: controller displays-manager<%> remove-all-syntax-displays))
|
||||
(send/i controller displays-manager<%> remove-all-syntax-displays))
|
||||
|
||||
(define/public (get-text) -text)
|
||||
|
||||
|
|
@ -218,7 +217,7 @@
|
|||
display)))
|
||||
|
||||
(define/private (calculate-columns)
|
||||
(define style (code-style -text (send: config config<%> get-syntax-font-size)))
|
||||
(define style (code-style -text (send/i config config<%> get-syntax-font-size)))
|
||||
(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)))))
|
||||
|
|
@ -227,13 +226,13 @@
|
|||
(super-new)
|
||||
(setup-keymap)
|
||||
|
||||
(send: config config<%> listen-props-shown?
|
||||
(send/i config config<%> listen-props-shown?
|
||||
(lambda (show?)
|
||||
(show-props show?)))
|
||||
(send: config config<%> listen-props-percentage
|
||||
(send/i config config<%> listen-props-percentage
|
||||
(lambda (p)
|
||||
(update-props-percentage p)))
|
||||
(internal-show-props (send: config config<%> get-props-shown?))))
|
||||
(internal-show-props (send/i config config<%> get-props-shown?))))
|
||||
|
||||
|
||||
(define clickback-style
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang scheme/base
|
||||
(require scheme/match
|
||||
scheme/string)
|
||||
#lang racket/base
|
||||
(require racket/match
|
||||
racket/string)
|
||||
|
||||
(provide mpi->list
|
||||
mpi->string
|
||||
|
|
@ -176,7 +176,7 @@
|
|||
[package (string-append (caddr m) ".plt")]
|
||||
[version (and (cadddr m) (parse-version (cadddr m)))]
|
||||
[path (list-ref m 4)])
|
||||
`(planet ,(string-append (or path "main") ".ss")
|
||||
`(planet ,(string-append (or path "main") ".rkt")
|
||||
(,owner ,package . ,version)))))
|
||||
|
||||
(define (parse-version str)
|
||||
|
|
@ -186,7 +186,7 @@
|
|||
(define (split-mods* path)
|
||||
(let ([mods (split-mods path)])
|
||||
(if (and (pair? mods) (null? (cdr mods)))
|
||||
(append mods (list "main.ss"))
|
||||
(append mods (list "main.rkt"))
|
||||
mods)))
|
||||
|
||||
(define (split-mods path [more null])
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
#lang racket
|
||||
#lang racket/base
|
||||
(require (rename-in racket/contract [-> c:->])
|
||||
ffi/unsafe)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,4 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require scheme/promise)
|
||||
#lang racket/base
|
||||
(provide cursor?
|
||||
cursor-position
|
||||
cursor:new
|
||||
|
|
|
|||
|
|
@ -1,6 +1,5 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require scheme/pretty)
|
||||
#lang racket/base
|
||||
(require racket/pretty)
|
||||
(provide write-debug-file
|
||||
load-debug-file)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,12 +1,11 @@
|
|||
#lang scheme/base
|
||||
(require scheme/pretty
|
||||
scheme/class
|
||||
(rename-in unstable/class-iop
|
||||
[send/i send:])
|
||||
"interfaces.ss"
|
||||
"debug-format.ss"
|
||||
"prefs.ss"
|
||||
"view.ss")
|
||||
#lang racket/base
|
||||
(require racket/pretty
|
||||
racket/class
|
||||
unstable/class-iop
|
||||
"interfaces.rkt"
|
||||
"debug-format.rkt"
|
||||
"prefs.rkt"
|
||||
"view.rkt")
|
||||
(provide debug-file)
|
||||
|
||||
(define (widget-mixin %)
|
||||
|
|
@ -30,5 +29,5 @@
|
|||
(pretty-print msg)
|
||||
(pretty-print ctx)
|
||||
(let* ([w (make-stepper)])
|
||||
(send: w widget<%> add-trace events)
|
||||
(send/i w widget<%> add-trace events)
|
||||
w)))
|
||||
|
|
|
|||
|
|
@ -1,27 +1,22 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
(rename-in unstable/class-iop
|
||||
[send/i send:]
|
||||
[send*/i send*:]
|
||||
[init-field/i init-field:])
|
||||
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")
|
||||
(prefix-in s: "../syntax-browser/keymap.ss")
|
||||
(prefix-in s: "../syntax-browser/interfaces.ss")
|
||||
"../model/deriv.ss"
|
||||
"../model/deriv-util.ss"
|
||||
"../model/trace.ss"
|
||||
"../model/steps.ss"
|
||||
"cursor.ss"
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/unit
|
||||
racket/list
|
||||
racket/match
|
||||
racket/gui
|
||||
framework
|
||||
unstable/class-iop
|
||||
"interfaces.rkt"
|
||||
"prefs.rkt"
|
||||
"hiding-panel.rkt"
|
||||
(prefix-in s: "../syntax-browser/widget.rkt")
|
||||
(prefix-in s: "../syntax-browser/keymap.rkt")
|
||||
(prefix-in s: "../syntax-browser/interfaces.rkt")
|
||||
"../model/deriv.rkt"
|
||||
"../model/deriv-util.rkt"
|
||||
"../model/trace.rkt"
|
||||
"../model/steps.rkt"
|
||||
"cursor.rkt"
|
||||
unstable/gui/notify)
|
||||
(provide stepper-keymap%
|
||||
stepper-syntax-widget%)
|
||||
|
|
@ -30,7 +25,7 @@
|
|||
|
||||
(define stepper-keymap%
|
||||
(class s:syntax-keymap%
|
||||
(init-field: (macro-stepper widget<%>))
|
||||
(init-field/i (macro-stepper widget<%>))
|
||||
(inherit-field config
|
||||
controller)
|
||||
(inherit add-function
|
||||
|
|
@ -42,17 +37,17 @@
|
|||
(super-new)
|
||||
|
||||
(define/public (get-hiding-panel)
|
||||
(send: macro-stepper widget<%> get-macro-hiding-prefs))
|
||||
(send/i macro-stepper widget<%> get-macro-hiding-prefs))
|
||||
|
||||
(add-function "hiding:show-macro"
|
||||
(lambda (i e)
|
||||
(send*: (get-hiding-panel) hiding-prefs<%>
|
||||
(send*/i (get-hiding-panel) hiding-prefs<%>
|
||||
(add-show-identifier)
|
||||
(refresh))))
|
||||
|
||||
(add-function "hiding:hide-macro"
|
||||
(lambda (i e)
|
||||
(send*: (get-hiding-panel) hiding-prefs<%>
|
||||
(send*/i (get-hiding-panel) hiding-prefs<%>
|
||||
(add-hide-identifier)
|
||||
(refresh))))
|
||||
|
||||
|
|
@ -78,21 +73,21 @@
|
|||
|
||||
(define stepper-syntax-widget%
|
||||
(class s:widget%
|
||||
(init-field: (macro-stepper widget<%>))
|
||||
(init-field/i (macro-stepper widget<%>))
|
||||
(inherit get-text)
|
||||
(inherit-field controller)
|
||||
|
||||
(define/override (setup-keymap)
|
||||
(new stepper-keymap%
|
||||
(editor (get-text))
|
||||
(config (send: macro-stepper widget<%> get-config))
|
||||
(config (send/i macro-stepper widget<%> get-config))
|
||||
(controller controller)
|
||||
(macro-stepper macro-stepper)))
|
||||
|
||||
(define/override (show-props show?)
|
||||
(super show-props show?)
|
||||
(send: macro-stepper widget<%> update/preserve-view))
|
||||
(send/i macro-stepper widget<%> update/preserve-view))
|
||||
|
||||
(super-new
|
||||
(config (send: macro-stepper widget<%> get-config)))))
|
||||
(config (send/i macro-stepper widget<%> get-config)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,27 +1,23 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
(rename-in unstable/class-iop
|
||||
[define/i define:]
|
||||
[send/i send:])
|
||||
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/interfaces.ss")
|
||||
"../model/deriv.ss"
|
||||
"../model/deriv-util.ss"
|
||||
"../model/trace.ss"
|
||||
"../model/steps.ss"
|
||||
"cursor.ss"
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/unit
|
||||
racket/list
|
||||
racket/file
|
||||
racket/match
|
||||
racket/gui
|
||||
framework
|
||||
unstable/class-iop
|
||||
"interfaces.rkt"
|
||||
"stepper.rkt"
|
||||
"prefs.rkt"
|
||||
"hiding-panel.rkt"
|
||||
(prefix-in sb: "../syntax-browser/embed.rkt")
|
||||
(prefix-in sb: "../syntax-browser/interfaces.rkt")
|
||||
"../model/deriv.rkt"
|
||||
"../model/deriv-util.rkt"
|
||||
"../model/trace.rkt"
|
||||
"../model/steps.rkt"
|
||||
"cursor.rkt"
|
||||
unstable/gui/notify)
|
||||
(provide macro-stepper-frame-mixin)
|
||||
|
||||
|
|
@ -49,8 +45,8 @@
|
|||
get-help-menu)
|
||||
|
||||
(super-new (label (make-label))
|
||||
(width (send: config config<%> get-width))
|
||||
(height (send: config config<%> get-height)))
|
||||
(width (send/i config config<%> get-width))
|
||||
(height (send/i config config<%> get-height)))
|
||||
|
||||
(define/private (make-label)
|
||||
(if filename
|
||||
|
|
@ -65,10 +61,10 @@
|
|||
;; to doing something. Avoid unnecessary updates.
|
||||
(define-values (w0 h0) (get-size))
|
||||
(define/override (on-size w h)
|
||||
(send: config config<%> set-width w)
|
||||
(send: config config<%> set-height h)
|
||||
(send/i config config<%> set-width w)
|
||||
(send/i config config<%> set-height h)
|
||||
(unless (and (= w0 w) (= h0 h))
|
||||
(send: widget widget<%> update/preserve-view))
|
||||
(send/i widget widget<%> update/preserve-view))
|
||||
(set!-values (w0 h0) (values w h)))
|
||||
|
||||
(define warning-panel
|
||||
|
|
@ -80,13 +76,13 @@
|
|||
(define/public (get-macro-stepper-widget%)
|
||||
macro-stepper-widget%)
|
||||
|
||||
(define: widget widget<%>
|
||||
(define/i widget widget<%>
|
||||
(new (get-macro-stepper-widget%)
|
||||
(parent (get-area-container))
|
||||
(director director)
|
||||
(config config)))
|
||||
(define: controller sb:controller<%>
|
||||
(send: widget widget<%> get-controller))
|
||||
(define/i controller sb:controller<%>
|
||||
(send/i widget widget<%> get-controller))
|
||||
|
||||
(define/public (get-widget) widget)
|
||||
(define/public (get-controller) controller)
|
||||
|
|
@ -128,11 +124,11 @@
|
|||
(new (get-menu-item%)
|
||||
(label "Duplicate stepper")
|
||||
(parent file-menu)
|
||||
(callback (lambda _ (send: widget widget<%> duplicate-stepper))))
|
||||
(callback (lambda _ (send/i widget widget<%> duplicate-stepper))))
|
||||
(new (get-menu-item%)
|
||||
(label "Duplicate stepper (current term only)")
|
||||
(parent file-menu)
|
||||
(callback (lambda _ (send: widget widget<%> show-in-new-frame)))))
|
||||
(callback (lambda _ (send/i widget widget<%> show-in-new-frame)))))
|
||||
|
||||
(menu-option/notify-box stepper-menu
|
||||
"View syntax properties"
|
||||
|
|
@ -149,23 +145,23 @@
|
|||
(parent id-menu)
|
||||
(callback
|
||||
(lambda _
|
||||
(send: controller sb:controller<%> set-identifier=? p))))])
|
||||
(send: controller sb:controller<%> listen-identifier=?
|
||||
(send/i controller sb:controller<%> set-identifier=? p))))])
|
||||
(send/i controller sb:controller<%> listen-identifier=?
|
||||
(lambda (name+func)
|
||||
(send this-choice check
|
||||
(eq? (car name+func) (car p)))))))
|
||||
(sb:identifier=-choices)))
|
||||
|
||||
(let ([identifier=? (send: config config<%> get-identifier=?)])
|
||||
(let ([identifier=? (send/i config config<%> get-identifier=?)])
|
||||
(when identifier=?
|
||||
(let ([p (assoc identifier=? (sb:identifier=-choices))])
|
||||
(send: controller sb:controller<%> set-identifier=? p))))
|
||||
(send/i controller sb:controller<%> set-identifier=? p))))
|
||||
|
||||
(new (get-menu-item%)
|
||||
(label "Clear selection")
|
||||
(parent stepper-menu)
|
||||
(callback
|
||||
(lambda _ (send: controller sb:controller<%>
|
||||
(lambda _ (send/i controller sb:controller<%>
|
||||
set-selected-syntax #f))))
|
||||
|
||||
(new separator-menu-item% (parent stepper-menu))
|
||||
|
|
@ -177,11 +173,11 @@
|
|||
(new (get-menu-item%)
|
||||
(label "Remove selected term")
|
||||
(parent stepper-menu)
|
||||
(callback (lambda _ (send: widget widget<%> remove-current-term))))
|
||||
(callback (lambda _ (send/i widget widget<%> remove-current-term))))
|
||||
(new (get-menu-item%)
|
||||
(label "Reset mark numbering")
|
||||
(parent stepper-menu)
|
||||
(callback (lambda _ (send: widget widget<%> reset-primary-partition))))
|
||||
(callback (lambda _ (send/i widget widget<%> reset-primary-partition))))
|
||||
(let ([extras-menu
|
||||
(new (get-menu%)
|
||||
(label "Extra options")
|
||||
|
|
@ -191,11 +187,11 @@
|
|||
(parent extras-menu)
|
||||
(callback
|
||||
(lambda (i e)
|
||||
(send: config config<%> set-suffix-option
|
||||
(send/i config config<%> set-suffix-option
|
||||
(if (send i is-checked?)
|
||||
'always
|
||||
'over-limit))
|
||||
(send: widget widget<%> update/preserve-view))))
|
||||
(send/i widget widget<%> update/preserve-view))))
|
||||
(menu-option/notify-box extras-menu
|
||||
"Factor out common context?"
|
||||
(get-field split-context? config))
|
||||
|
|
|
|||
|
|
@ -1,14 +1,11 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
(rename-in unstable/class-iop
|
||||
[send/i send:]
|
||||
[init-field/i init-field:])
|
||||
scheme/gui
|
||||
scheme/list
|
||||
syntax/boundmap
|
||||
"interfaces.ss"
|
||||
"../model/hiding-policies.ss"
|
||||
"../util/mpi.ss"
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/gui
|
||||
racket/list
|
||||
unstable/class-iop
|
||||
"interfaces.rkt"
|
||||
"../model/hiding-policies.rkt"
|
||||
"../util/mpi.rkt"
|
||||
unstable/gui/notify)
|
||||
(provide macro-hiding-prefs-widget%)
|
||||
|
||||
|
|
@ -30,7 +27,7 @@ TODO
|
|||
(define macro-hiding-prefs-widget%
|
||||
(class* object% (hiding-prefs<%>)
|
||||
(init parent)
|
||||
(init-field: (stepper widget<%>))
|
||||
(init-field/i (stepper widget<%>))
|
||||
(init-field config)
|
||||
|
||||
(define/public (get-policy)
|
||||
|
|
@ -89,7 +86,7 @@ TODO
|
|||
(style '(deleted))))
|
||||
|
||||
(define/private (get-mode)
|
||||
(send: config config<%> get-macro-hiding-mode))
|
||||
(send/i config config<%> get-macro-hiding-mode))
|
||||
|
||||
(define/private (macro-hiding-enabled?)
|
||||
(let ([mode (get-mode)])
|
||||
|
|
@ -99,7 +96,7 @@ TODO
|
|||
|
||||
(define/private (ensure-custom-mode)
|
||||
(unless (equal? (get-mode) mode:custom)
|
||||
(send: config config<%> set-macro-hiding-mode mode:custom)))
|
||||
(send/i config config<%> set-macro-hiding-mode mode:custom)))
|
||||
|
||||
(define/private (update-visibility)
|
||||
(let ([customizing (equal? (get-mode) mode:custom)])
|
||||
|
|
@ -114,10 +111,10 @@ TODO
|
|||
(list customize-panel)
|
||||
null))))))
|
||||
|
||||
(send: config config<%> listen-macro-hiding-mode
|
||||
(lambda (value)
|
||||
(update-visibility)
|
||||
(force-refresh)))
|
||||
(send/i config config<%> listen-macro-hiding-mode
|
||||
(lambda (value)
|
||||
(update-visibility)
|
||||
(force-refresh)))
|
||||
|
||||
(define box:hiding
|
||||
(new check-box%
|
||||
|
|
@ -185,11 +182,11 @@ TODO
|
|||
;; refresh : -> void
|
||||
(define/public (refresh)
|
||||
(when (macro-hiding-enabled?)
|
||||
(send: stepper widget<%> refresh/resynth)))
|
||||
(send/i stepper widget<%> refresh/resynth)))
|
||||
|
||||
;; force-refresh : -> void
|
||||
(define/private (force-refresh)
|
||||
(send: stepper widget<%> refresh/resynth))
|
||||
(send/i stepper widget<%> refresh/resynth))
|
||||
|
||||
;; set-syntax : syntax/#f -> void
|
||||
(define/public (set-syntax lstx)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
(require unstable/class-iop
|
||||
(prefix-in sb: "../syntax-browser/interfaces.ss"))
|
||||
(prefix-in sb: "../syntax-browser/interfaces.rkt"))
|
||||
(provide (all-defined-out))
|
||||
|
||||
(define-interface config<%> (sb:config<%>)
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
framework/framework
|
||||
"interfaces.ss"
|
||||
"../syntax-browser/prefs.ss"
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
framework
|
||||
"interfaces.rkt"
|
||||
"../syntax-browser/prefs.rkt"
|
||||
unstable/gui/notify
|
||||
unstable/gui/prefs)
|
||||
(provide pref:macro-step-limit
|
||||
|
|
|
|||
|
|
@ -1,31 +1,26 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
(rename-in unstable/class-iop
|
||||
[send/i send:]
|
||||
[send*/i send*:]
|
||||
[init-field/i init-field:])
|
||||
scheme/unit
|
||||
scheme/list
|
||||
scheme/match
|
||||
scheme/gui
|
||||
framework/framework
|
||||
syntax/boundmap
|
||||
"interfaces.ss"
|
||||
"prefs.ss"
|
||||
"extensions.ss"
|
||||
"warning.ss"
|
||||
"hiding-panel.ss"
|
||||
"../model/deriv.ss"
|
||||
"../model/deriv-util.ss"
|
||||
"../model/deriv-parser.ss"
|
||||
"../model/trace.ss"
|
||||
"../model/reductions-config.ss"
|
||||
"../model/reductions.ss"
|
||||
"../model/steps.ss"
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/unit
|
||||
racket/list
|
||||
racket/match
|
||||
racket/gui
|
||||
framework
|
||||
unstable/class-iop
|
||||
"interfaces.rkt"
|
||||
"prefs.rkt"
|
||||
"extensions.rkt"
|
||||
"hiding-panel.rkt"
|
||||
"../model/deriv.rkt"
|
||||
"../model/deriv-util.rkt"
|
||||
"../model/deriv-parser.rkt"
|
||||
"../model/trace.rkt"
|
||||
"../model/reductions-config.rkt"
|
||||
"../model/reductions.rkt"
|
||||
"../model/steps.rkt"
|
||||
unstable/gui/notify
|
||||
(prefix-in sb: "../syntax-browser/interfaces.ss")
|
||||
"cursor.ss"
|
||||
"debug-format.ss")
|
||||
(prefix-in sb: "../syntax-browser/interfaces.rkt")
|
||||
"cursor.rkt"
|
||||
"debug-format.rkt")
|
||||
|
||||
#;
|
||||
(provide step-display%
|
||||
|
|
@ -42,23 +37,23 @@
|
|||
(define step-display%
|
||||
(class* object% (step-display<%>)
|
||||
|
||||
(init-field: (config config<%>))
|
||||
(init-field/i (config config<%>))
|
||||
(init-field ((sbview syntax-widget)))
|
||||
(super-new)
|
||||
|
||||
(define/public (add-internal-error part exn stx events)
|
||||
(send: sbview sb:syntax-browser<%> add-text
|
||||
(if part
|
||||
(format "Macro stepper error (~a)" part)
|
||||
"Macro stepper error"))
|
||||
(send/i sbview sb:syntax-browser<%> add-text
|
||||
(if part
|
||||
(format "Macro stepper error (~a)" part)
|
||||
"Macro stepper error"))
|
||||
(when (exn? exn)
|
||||
(send: sbview sb:syntax-browser<%> add-text " ")
|
||||
(send: sbview sb:syntax-browser<%> add-clickback "[details]"
|
||||
(lambda _ (show-internal-error-details exn events))))
|
||||
(send: sbview sb:syntax-browser<%> add-text ". ")
|
||||
(when stx (send: sbview sb:syntax-browser<%> add-text "Original syntax:"))
|
||||
(send: sbview sb:syntax-browser<%> add-text "\n")
|
||||
(when stx (send: sbview sb:syntax-browser<%> add-syntax stx)))
|
||||
(send/i sbview sb:syntax-browser<%> add-text " ")
|
||||
(send/i sbview sb:syntax-browser<%> add-clickback "[details]"
|
||||
(lambda _ (show-internal-error-details exn events))))
|
||||
(send/i sbview sb:syntax-browser<%> add-text ". ")
|
||||
(when stx (send/i sbview sb:syntax-browser<%> add-text "Original syntax:"))
|
||||
(send/i sbview sb:syntax-browser<%> add-text "\n")
|
||||
(when stx (send/i sbview sb:syntax-browser<%> add-syntax stx)))
|
||||
|
||||
(define/private (show-internal-error-details exn events)
|
||||
(case (message-box/custom "Macro stepper internal error"
|
||||
|
|
@ -77,7 +72,7 @@
|
|||
((3 #f) (void))))
|
||||
|
||||
(define/public (add-error exn)
|
||||
(send*: sbview sb:syntax-browser<%>
|
||||
(send*/i sbview sb:syntax-browser<%>
|
||||
(add-error-text (exn-message exn))
|
||||
(add-text "\n")))
|
||||
|
||||
|
|
@ -98,17 +93,17 @@
|
|||
#:binders [binders null]
|
||||
#:definites [definites null]
|
||||
#:shift-table [shift-table #f])
|
||||
(send: sbview sb:syntax-browser<%> add-syntax stx
|
||||
#:binders binders
|
||||
#:definites definites
|
||||
#:shift-table shift-table))
|
||||
(send/i sbview sb:syntax-browser<%> add-syntax stx
|
||||
#:binders binders
|
||||
#:definites definites
|
||||
#:shift-table shift-table))
|
||||
|
||||
(define/public (add-final stx error
|
||||
#:binders binders
|
||||
#:definites definites
|
||||
#:shift-table [shift-table #f])
|
||||
(when stx
|
||||
(send*: sbview sb:syntax-browser<%>
|
||||
(send*/i sbview sb:syntax-browser<%>
|
||||
(add-text "Expansion finished\n")
|
||||
(add-syntax stx
|
||||
#:binders binders
|
||||
|
|
@ -122,8 +117,8 @@
|
|||
(define state (protostep-s1 step))
|
||||
(define lctx (state-lctx state))
|
||||
(for ([bf lctx])
|
||||
(send: sbview sb:syntax-browser<%> add-text
|
||||
"\nwhile executing macro transformer in:\n")
|
||||
(send/i sbview sb:syntax-browser<%> add-text
|
||||
"\nwhile executing macro transformer in:\n")
|
||||
(insert-syntax/redex (bigframe-term bf)
|
||||
(bigframe-foci bf)
|
||||
(state-binders state)
|
||||
|
|
@ -152,7 +147,7 @@
|
|||
(show-lctx step shift-table)))
|
||||
|
||||
(define/private (factor-common-context state1 state2)
|
||||
(if (send: config config<%> get-split-context?)
|
||||
(if (send/i config config<%> get-split-context?)
|
||||
(factor-common-context* state1 state2)
|
||||
(values null state1 state2)))
|
||||
|
||||
|
|
@ -179,7 +174,7 @@
|
|||
(when (pair? ctx)
|
||||
(let* ([hole-stx #'~~HOLE~~]
|
||||
[the-syntax (context-fill ctx hole-stx)])
|
||||
(send*: sbview sb:syntax-browser<%>
|
||||
(send*/i sbview sb:syntax-browser<%>
|
||||
(add-text "\nin context:\n")
|
||||
(add-syntax the-syntax
|
||||
#:definites uses1
|
||||
|
|
@ -220,26 +215,26 @@
|
|||
(define state (protostep-s1 step))
|
||||
(show-state/redex state shift-table)
|
||||
(separator step)
|
||||
(send*: sbview sb:syntax-browser<%>
|
||||
(send*/i sbview sb:syntax-browser<%>
|
||||
(add-error-text (exn-message (misstep-exn step)))
|
||||
(add-text "\n"))
|
||||
(when (exn:fail:syntax? (misstep-exn step))
|
||||
(for ([e (exn:fail:syntax-exprs (misstep-exn step))])
|
||||
(send: sbview sb:syntax-browser<%> add-syntax e
|
||||
#:binders (or (state-binders state) null)
|
||||
#:definites (or (state-uses state) null)
|
||||
#:shift-table shift-table)))
|
||||
(send/i sbview sb:syntax-browser<%> add-syntax e
|
||||
#:binders (or (state-binders state) null)
|
||||
#:definites (or (state-uses state) null)
|
||||
#:shift-table shift-table)))
|
||||
(show-lctx step shift-table))
|
||||
|
||||
(define/private (show-remarkstep step shift-table)
|
||||
(define state (protostep-s1 step))
|
||||
(for ([content (in-list (remarkstep-contents step))])
|
||||
(cond [(string? content)
|
||||
(send*: sbview sb:syntax-browser<%>
|
||||
(send*/i sbview sb:syntax-browser<%>
|
||||
(add-text content)
|
||||
(add-text "\n"))]
|
||||
[(syntax? content)
|
||||
(send*: sbview sb:syntax-browser<%>
|
||||
(send*/i sbview sb:syntax-browser<%>
|
||||
(add-syntax content
|
||||
#:binders (or (state-binders state) null)
|
||||
#:definites (or (state-uses state) null)
|
||||
|
|
@ -250,16 +245,16 @@
|
|||
;; insert-syntax/color
|
||||
(define/private (insert-syntax/color stx foci binders shift-table
|
||||
definites frontier hi-color)
|
||||
(define highlight-foci? (send: config config<%> get-highlight-foci?))
|
||||
(define highlight-frontier? (send: config config<%> get-highlight-frontier?))
|
||||
(send: sbview sb:syntax-browser<%> add-syntax stx
|
||||
#:definites (or definites null)
|
||||
#:binders binders
|
||||
#:shift-table shift-table
|
||||
#:hi-colors (list hi-color
|
||||
"WhiteSmoke")
|
||||
#:hi-stxss (list (if highlight-foci? foci null)
|
||||
(if highlight-frontier? frontier null))))
|
||||
(define highlight-foci? (send/i config config<%> get-highlight-foci?))
|
||||
(define highlight-frontier? (send/i config config<%> get-highlight-frontier?))
|
||||
(send/i sbview sb:syntax-browser<%> add-syntax stx
|
||||
#:definites (or definites null)
|
||||
#:binders binders
|
||||
#:shift-table shift-table
|
||||
#:hi-colors (list hi-color
|
||||
"WhiteSmoke")
|
||||
#:hi-stxss (list (if highlight-foci? foci null)
|
||||
(if highlight-frontier? frontier null))))
|
||||
|
||||
;; insert-syntax/redex
|
||||
(define/private (insert-syntax/redex stx foci binders shift-table
|
||||
|
|
@ -275,7 +270,7 @@
|
|||
|
||||
;; insert-step-separator : string -> void
|
||||
(define/private (insert-step-separator text)
|
||||
(send*: sbview sb:syntax-browser<%>
|
||||
(send*/i sbview sb:syntax-browser<%>
|
||||
(add-text "\n ")
|
||||
(add-text
|
||||
(make-object image-snip%
|
||||
|
|
@ -287,14 +282,14 @@
|
|||
|
||||
;; insert-as-separator : string -> void
|
||||
(define/private (insert-as-separator text)
|
||||
(send*: sbview sb:syntax-browser<%>
|
||||
(send*/i sbview sb:syntax-browser<%>
|
||||
(add-text "\n ")
|
||||
(add-text text)
|
||||
(add-text "\n\n")))
|
||||
|
||||
;; insert-step-separator/small : string -> void
|
||||
(define/private (insert-step-separator/small text)
|
||||
(send*: sbview sb:syntax-browser<%>
|
||||
(send*/i sbview sb:syntax-browser<%>
|
||||
(add-text " ")
|
||||
(add-text
|
||||
(make-object image-snip%
|
||||
|
|
|
|||
|
|
@ -1,29 +1,24 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
(rename-in unstable/class-iop
|
||||
[define/i define:]
|
||||
[send/i send:]
|
||||
[send*/i send*:]
|
||||
[init-field/i init-field:])
|
||||
scheme/unit
|
||||
scheme/list
|
||||
scheme/match
|
||||
scheme/gui
|
||||
framework/framework
|
||||
syntax/boundmap
|
||||
"interfaces.ss"
|
||||
"prefs.ss"
|
||||
"extensions.ss"
|
||||
"hiding-panel.ss"
|
||||
"term-record.ss"
|
||||
"step-display.ss"
|
||||
(prefix-in sb: "../syntax-browser/interfaces.ss")
|
||||
"../model/deriv.ss"
|
||||
"../model/deriv-util.ss"
|
||||
"../model/trace.ss"
|
||||
"../model/reductions.ss"
|
||||
"../model/steps.ss"
|
||||
"cursor.ss"
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/unit
|
||||
racket/list
|
||||
racket/match
|
||||
racket/gui
|
||||
framework
|
||||
unstable/class-iop
|
||||
"interfaces.rkt"
|
||||
"prefs.rkt"
|
||||
"extensions.rkt"
|
||||
"hiding-panel.rkt"
|
||||
"term-record.rkt"
|
||||
"step-display.rkt"
|
||||
(prefix-in sb: "../syntax-browser/interfaces.rkt")
|
||||
"../model/deriv.rkt"
|
||||
"../model/deriv-util.rkt"
|
||||
"../model/trace.rkt"
|
||||
"../model/reductions.rkt"
|
||||
"../model/steps.rkt"
|
||||
"cursor.rkt"
|
||||
unstable/gui/notify
|
||||
(only-in mzscheme [#%top-interaction mz-top-interaction]))
|
||||
(provide macro-stepper-widget%
|
||||
|
|
@ -36,7 +31,7 @@
|
|||
(class* object% (widget<%>)
|
||||
(init-field parent)
|
||||
(init-field config)
|
||||
(init-field: (director director<%>))
|
||||
(init-field/i (director director<%>))
|
||||
|
||||
;; Terms
|
||||
|
||||
|
|
@ -69,7 +64,7 @@
|
|||
(define/public (add trec)
|
||||
(set! all-terms (cons trec all-terms))
|
||||
(let ([display-new-term? (cursor:at-end? terms)]
|
||||
[invisible? (send: trec term-record<%> get-deriv-hidden?)])
|
||||
[invisible? (send/i trec term-record<%> get-deriv-hidden?)])
|
||||
(unless invisible?
|
||||
(cursor:add-to-end! terms (list trec))
|
||||
(trim-navigator)
|
||||
|
|
@ -87,16 +82,16 @@
|
|||
(define/public (show-in-new-frame)
|
||||
(let ([term (focused-term)])
|
||||
(when term
|
||||
(let ([new-stepper (send: director director<%> new-stepper '(no-new-traces))])
|
||||
(send: new-stepper widget<%> add-deriv (send: term term-record<%> get-raw-deriv))
|
||||
(let ([new-stepper (send/i director director<%> new-stepper '(no-new-traces))])
|
||||
(send/i new-stepper widget<%> add-deriv (send/i term term-record<%> get-raw-deriv))
|
||||
(void)))))
|
||||
|
||||
;; duplicate-stepper : -> void
|
||||
(define/public (duplicate-stepper)
|
||||
(let ([new-stepper (send: director director<%> new-stepper)])
|
||||
(let ([new-stepper (send/i director director<%> new-stepper)])
|
||||
(for ([term (cursor->list terms)])
|
||||
(send: new-stepper widget<%> add-deriv
|
||||
(send: term term-record<%> get-raw-deriv)))))
|
||||
(send/i new-stepper widget<%> add-deriv
|
||||
(send/i term term-record<%> get-raw-deriv)))))
|
||||
|
||||
(define/public (get-config) config)
|
||||
(define/public (get-controller) sbc)
|
||||
|
|
@ -105,7 +100,7 @@
|
|||
(define/public (get-macro-hiding-prefs) macro-hiding-prefs)
|
||||
|
||||
(define/public (reset-primary-partition)
|
||||
(send: sbc sb:controller<%> reset-primary-partition)
|
||||
(send/i sbc sb:controller<%> reset-primary-partition)
|
||||
(update/preserve-view))
|
||||
|
||||
(define area (new vertical-panel% (parent parent)))
|
||||
|
|
@ -128,28 +123,28 @@
|
|||
(alignment '(left center))
|
||||
(style '(deleted))))
|
||||
|
||||
(define: sbview sb:syntax-browser<%>
|
||||
(define/i sbview sb:syntax-browser<%>
|
||||
(new stepper-syntax-widget%
|
||||
(parent area)
|
||||
(macro-stepper this)))
|
||||
(define: step-displayer step-display<%>
|
||||
(define/i step-displayer step-display<%>
|
||||
(new step-display%
|
||||
(config config)
|
||||
(syntax-widget sbview)))
|
||||
(define: sbc sb:controller<%>
|
||||
(send: sbview sb:syntax-browser<%> get-controller))
|
||||
(define/i sbc sb:controller<%>
|
||||
(send/i sbview sb:syntax-browser<%> get-controller))
|
||||
(define control-pane
|
||||
(new vertical-panel% (parent area) (stretchable-height #f)))
|
||||
(define: macro-hiding-prefs hiding-prefs<%>
|
||||
(define/i macro-hiding-prefs hiding-prefs<%>
|
||||
(new macro-hiding-prefs-widget%
|
||||
(parent control-pane)
|
||||
(stepper this)
|
||||
(config config)))
|
||||
|
||||
(send: sbc sb:controller<%>
|
||||
(send/i sbc sb:controller<%>
|
||||
listen-selected-syntax
|
||||
(lambda (stx) (send: macro-hiding-prefs hiding-prefs<%> set-syntax stx)))
|
||||
(send*: config config<%>
|
||||
(lambda (stx) (send/i macro-hiding-prefs hiding-prefs<%> set-syntax stx)))
|
||||
(send*/i config config<%>
|
||||
(listen-show-hiding-panel?
|
||||
(lambda (show?) (show-macro-hiding-panel show?)))
|
||||
(listen-split-context?
|
||||
|
|
@ -251,34 +246,34 @@
|
|||
;; Navigation
|
||||
#|
|
||||
(define/public-final (at-start?)
|
||||
(send: (focused-term) term-record<%> at-start?))
|
||||
(send/i (focused-term) term-record<%> at-start?))
|
||||
(define/public-final (at-end?)
|
||||
(send: (focused-term) term-record<%> at-end?))
|
||||
(send/i (focused-term) term-record<%> at-end?))
|
||||
|#
|
||||
(define/public-final (navigate-to-start)
|
||||
(send: (focused-term) term-record<%> navigate-to-start)
|
||||
(send/i (focused-term) term-record<%> navigate-to-start)
|
||||
(update/save-position))
|
||||
(define/public-final (navigate-to-end)
|
||||
(send: (focused-term) term-record<%> navigate-to-end)
|
||||
(send/i (focused-term) term-record<%> navigate-to-end)
|
||||
(update/save-position))
|
||||
(define/public-final (navigate-previous)
|
||||
(send: (focused-term) term-record<%> navigate-previous)
|
||||
(send/i (focused-term) term-record<%> navigate-previous)
|
||||
(update/save-position))
|
||||
(define/public-final (navigate-next)
|
||||
(send: (focused-term) term-record<%> navigate-next)
|
||||
(send/i (focused-term) term-record<%> navigate-next)
|
||||
(update/save-position))
|
||||
(define/public-final (navigate-to n)
|
||||
(send: (focused-term) term-record<%> navigate-to n)
|
||||
(send/i (focused-term) term-record<%> navigate-to n)
|
||||
(update/save-position))
|
||||
|
||||
(define/public-final (navigate-up)
|
||||
(when (focused-term)
|
||||
(send: (focused-term) term-record<%> on-lose-focus))
|
||||
(send/i (focused-term) term-record<%> on-lose-focus))
|
||||
(cursor:move-prev terms)
|
||||
(refresh/move))
|
||||
(define/public-final (navigate-down)
|
||||
(when (focused-term)
|
||||
(send: (focused-term) term-record<%> on-lose-focus))
|
||||
(send/i (focused-term) term-record<%> on-lose-focus))
|
||||
(cursor:move-next terms)
|
||||
(refresh/move))
|
||||
|
||||
|
|
@ -290,7 +285,7 @@
|
|||
|
||||
;; update/preserve-lines-view : -> void
|
||||
(define/public (update/preserve-lines-view)
|
||||
(define text (send: sbview sb:syntax-browser<%> get-text))
|
||||
(define text (send/i sbview sb:syntax-browser<%> get-text))
|
||||
(define start-box (box 0))
|
||||
(define end-box (box 0))
|
||||
(send text get-visible-line-range start-box end-box)
|
||||
|
|
@ -303,7 +298,7 @@
|
|||
|
||||
;; update/preserve-view : -> void
|
||||
(define/public (update/preserve-view)
|
||||
(define text (send: sbview sb:syntax-browser<%> get-text))
|
||||
(define text (send/i sbview sb:syntax-browser<%> get-text))
|
||||
(define start-box (box 0))
|
||||
(define end-box (box 0))
|
||||
(send text get-visible-position-range start-box end-box)
|
||||
|
|
@ -313,17 +308,17 @@
|
|||
;; update : -> void
|
||||
;; Updates the terms in the syntax browser to the current step
|
||||
(define/private (update)
|
||||
(define text (send: sbview sb:syntax-browser<%> get-text))
|
||||
(define text (send/i sbview sb:syntax-browser<%> get-text))
|
||||
(define position-of-interest 0)
|
||||
(define multiple-terms? (> (length (cursor->list terms)) 1))
|
||||
(send text begin-edit-sequence #f)
|
||||
(send: sbview sb:syntax-browser<%> erase-all)
|
||||
(send/i sbview sb:syntax-browser<%> erase-all)
|
||||
|
||||
(update:show-prefix)
|
||||
(when multiple-terms? (send: sbview sb:syntax-browser<%> add-separator))
|
||||
(when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator))
|
||||
(set! position-of-interest (send text last-position))
|
||||
(update:show-current-step)
|
||||
(when multiple-terms? (send: sbview sb:syntax-browser<%> add-separator))
|
||||
(when multiple-terms? (send/i sbview sb:syntax-browser<%> add-separator))
|
||||
(update:show-suffix)
|
||||
(send text end-edit-sequence)
|
||||
(send text scroll-to-position
|
||||
|
|
@ -337,35 +332,35 @@
|
|||
;; 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 term-record<%> display-final-term))
|
||||
(for-each (lambda (trec) (send/i trec term-record<%> display-final-term))
|
||||
(cursor:prefix->list terms)))
|
||||
|
||||
;; update:show-current-step : -> void
|
||||
(define/private (update:show-current-step)
|
||||
(when (focused-term)
|
||||
(send: (focused-term) term-record<%> display-step)))
|
||||
(send/i (focused-term) term-record<%> display-step)))
|
||||
|
||||
;; update:show-suffix : -> void
|
||||
(define/private (update:show-suffix)
|
||||
(let ([suffix0 (cursor:suffix->list terms)])
|
||||
(when (pair? suffix0)
|
||||
(for-each (lambda (trec)
|
||||
(send: trec term-record<%> display-initial-term))
|
||||
(send/i trec term-record<%> display-initial-term))
|
||||
(cdr suffix0)))))
|
||||
|
||||
;; update-nav-index : -> void
|
||||
(define/private (update-nav-index)
|
||||
(define term (focused-term))
|
||||
(set-current-step-index
|
||||
(and term (send: term term-record<%> get-step-index))))
|
||||
(and term (send/i term term-record<%> get-step-index))))
|
||||
|
||||
;; enable/disable-buttons : -> void
|
||||
(define/private (enable/disable-buttons)
|
||||
(define term (focused-term))
|
||||
(send nav:start enable (and term (send: term term-record<%> has-prev?)))
|
||||
(send nav:previous enable (and term (send: term term-record<%> has-prev?)))
|
||||
(send nav:next enable (and term (send: term term-record<%> has-next?)))
|
||||
(send nav:end enable (and term (send: term term-record<%> has-next?)))
|
||||
(send nav:start enable (and term (send/i term term-record<%> has-prev?)))
|
||||
(send nav:previous enable (and term (send/i term term-record<%> has-prev?)))
|
||||
(send nav:next enable (and term (send/i term term-record<%> has-next?)))
|
||||
(send nav:end enable (and term (send/i term term-record<%> has-next?)))
|
||||
(send nav:text enable (and term #t))
|
||||
(send nav:up enable (cursor:has-prev? terms))
|
||||
(send nav:down enable (cursor:has-next? terms)))
|
||||
|
|
@ -375,14 +370,14 @@
|
|||
;; refresh/resynth : -> void
|
||||
;; Macro hiding policy has changed; invalidate cached parts of trec
|
||||
(define/public (refresh/resynth)
|
||||
(for-each (lambda (trec) (send: trec term-record<%> invalidate-synth!))
|
||||
(for-each (lambda (trec) (send/i trec term-record<%> invalidate-synth!))
|
||||
(cursor->list terms))
|
||||
(refresh))
|
||||
|
||||
;; refresh/re-reduce : -> void
|
||||
;; Reduction config has changed; invalidate cached parts of trec
|
||||
(define/private (refresh/re-reduce)
|
||||
(for-each (lambda (trec) (send: trec term-record<%> invalidate-steps!))
|
||||
(for-each (lambda (trec) (send/i trec term-record<%> invalidate-steps!))
|
||||
(cursor->list terms))
|
||||
(refresh))
|
||||
|
||||
|
|
@ -394,11 +389,11 @@
|
|||
;; refresh : -> void
|
||||
(define/public (refresh)
|
||||
(when (focused-term)
|
||||
(send: (focused-term) term-record<%> on-get-focus))
|
||||
(send/i (focused-term) term-record<%> on-get-focus))
|
||||
(send nav:step-count set-label "")
|
||||
(let ([term (focused-term)])
|
||||
(when term
|
||||
(let ([step-count (send: term term-record<%> get-step-count)])
|
||||
(let ([step-count (send/i term term-record<%> get-step-count)])
|
||||
(when step-count
|
||||
;; +1 for end of expansion "step"
|
||||
(send nav:step-count set-label (format "of ~s" (add1 step-count)))))))
|
||||
|
|
@ -409,7 +404,7 @@
|
|||
;; Hiding policy
|
||||
|
||||
(define/public (get-show-macro?)
|
||||
(send: macro-hiding-prefs hiding-prefs<%> get-policy))
|
||||
(send/i macro-hiding-prefs hiding-prefs<%> get-policy))
|
||||
|
||||
;; Derivation pre-processing
|
||||
|
||||
|
|
@ -418,8 +413,8 @@
|
|||
;; Initialization
|
||||
|
||||
(super-new)
|
||||
(show-macro-hiding-panel (send: config config<%> get-show-hiding-panel?))
|
||||
(show-extra-navigation (send: config config<%> get-extra-navigation?))
|
||||
(show-macro-hiding-panel (send/i config config<%> get-show-hiding-panel?))
|
||||
(show-extra-navigation (send/i config config<%> get-extra-navigation?))
|
||||
(refresh/move)
|
||||
))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,33 +1,28 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
(rename-in unstable/class-iop
|
||||
[define/i define:]
|
||||
[send/i send:]
|
||||
[init-field/i init-field:])
|
||||
scheme/unit
|
||||
scheme/list
|
||||
scheme/match
|
||||
scheme/gui
|
||||
framework/framework
|
||||
syntax/boundmap
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/unit
|
||||
racket/list
|
||||
racket/match
|
||||
racket/gui
|
||||
framework
|
||||
syntax/stx
|
||||
unstable/find
|
||||
"interfaces.ss"
|
||||
"prefs.ss"
|
||||
"extensions.ss"
|
||||
"warning.ss"
|
||||
"hiding-panel.ss"
|
||||
"step-display.ss"
|
||||
"../model/deriv.ss"
|
||||
"../model/deriv-util.ss"
|
||||
"../model/deriv-parser.ss"
|
||||
"../model/trace.ss"
|
||||
"../model/reductions-config.ss"
|
||||
"../model/reductions.ss"
|
||||
"../model/steps.ss"
|
||||
unstable/class-iop
|
||||
"interfaces.rkt"
|
||||
"prefs.rkt"
|
||||
"extensions.rkt"
|
||||
"hiding-panel.rkt"
|
||||
"step-display.rkt"
|
||||
"../model/deriv.rkt"
|
||||
"../model/deriv-util.rkt"
|
||||
"../model/deriv-parser.rkt"
|
||||
"../model/trace.rkt"
|
||||
"../model/reductions-config.rkt"
|
||||
"../model/reductions.rkt"
|
||||
"../model/steps.rkt"
|
||||
unstable/gui/notify
|
||||
"cursor.ss"
|
||||
"debug-format.ss")
|
||||
"cursor.rkt"
|
||||
"debug-format.rkt")
|
||||
|
||||
(provide term-record%)
|
||||
|
||||
|
|
@ -35,12 +30,12 @@
|
|||
|
||||
(define term-record%
|
||||
(class* object% (term-record<%>)
|
||||
(init-field: (stepper widget<%>))
|
||||
(init-field/i (stepper widget<%>))
|
||||
|
||||
(define: config config<%>
|
||||
(send: stepper widget<%> get-config))
|
||||
(define: displayer step-display<%>
|
||||
(send: stepper widget<%> get-step-displayer))
|
||||
(define/i config config<%>
|
||||
(send/i stepper widget<%> get-config))
|
||||
(define/i displayer step-display<%>
|
||||
(send/i stepper widget<%> get-step-displayer))
|
||||
|
||||
;; Data
|
||||
|
||||
|
|
@ -134,7 +129,7 @@
|
|||
(unless (or deriv deriv-hidden?)
|
||||
(recache-raw-deriv!)
|
||||
(when raw-deriv
|
||||
(let ([process (send: stepper widget<%> get-preprocess-deriv)])
|
||||
(let ([process (send/i stepper widget<%> get-preprocess-deriv)])
|
||||
(let ([d (process raw-deriv)])
|
||||
(when (not d)
|
||||
(set! deriv-hidden? #t))
|
||||
|
|
@ -151,7 +146,7 @@
|
|||
(unless (or raw-steps raw-steps-oops)
|
||||
(recache-synth!)
|
||||
(when deriv
|
||||
(let ([show-macro? (or (send: stepper widget<%> get-show-macro?)
|
||||
(let ([show-macro? (or (send/i stepper widget<%> get-show-macro?)
|
||||
(lambda (id) #t))])
|
||||
(with-handlers ([(lambda (e) #t)
|
||||
(lambda (e)
|
||||
|
|
@ -173,12 +168,12 @@
|
|||
(set! steps
|
||||
(and raw-steps
|
||||
(let* ([filtered-steps
|
||||
(if (send: config config<%> get-show-rename-steps?)
|
||||
(if (send/i config config<%> get-show-rename-steps?)
|
||||
raw-steps
|
||||
(filter (lambda (x) (not (rename-step? x)))
|
||||
raw-steps))]
|
||||
[processed-steps
|
||||
(if (send: config config<%> get-one-by-one?)
|
||||
(if (send/i config config<%> get-one-by-one?)
|
||||
(reduce:one-by-one filtered-steps)
|
||||
filtered-steps)])
|
||||
(cursor:new processed-steps))))
|
||||
|
|
@ -280,21 +275,21 @@
|
|||
;; display-initial-term : -> void
|
||||
(define/public (display-initial-term)
|
||||
(cond [raw-deriv-oops
|
||||
(send: displayer step-display<%> add-internal-error
|
||||
"derivation" raw-deriv-oops #f events)]
|
||||
(send/i displayer step-display<%> add-internal-error
|
||||
"derivation" raw-deriv-oops #f events)]
|
||||
[else
|
||||
(send: displayer step-display<%> add-syntax (wderiv-e1 deriv))]))
|
||||
(send/i displayer step-display<%> add-syntax (wderiv-e1 deriv))]))
|
||||
|
||||
;; display-final-term : -> void
|
||||
(define/public (display-final-term)
|
||||
(recache-steps!)
|
||||
(cond [(syntax? raw-steps-estx)
|
||||
(send: displayer step-display<%> add-syntax raw-steps-estx
|
||||
#:binders raw-steps-binders
|
||||
#:shift-table shift-table
|
||||
#:definites raw-steps-definites)]
|
||||
(send/i displayer step-display<%> add-syntax raw-steps-estx
|
||||
#:binders raw-steps-binders
|
||||
#:shift-table shift-table
|
||||
#:definites raw-steps-definites)]
|
||||
[(exn? raw-steps-exn)
|
||||
(send: displayer step-display<%> add-error raw-steps-exn)]
|
||||
(send/i displayer step-display<%> add-error raw-steps-exn)]
|
||||
[else (display-oops #f)]))
|
||||
|
||||
;; display-step : -> void
|
||||
|
|
@ -303,24 +298,24 @@
|
|||
(cond [steps
|
||||
(let ([step (cursor:next steps)])
|
||||
(if step
|
||||
(send: displayer step-display<%> add-step step
|
||||
#:shift-table shift-table)
|
||||
(send: displayer step-display<%> add-final raw-steps-estx raw-steps-exn
|
||||
#:binders raw-steps-binders
|
||||
#:shift-table shift-table
|
||||
#:definites raw-steps-definites)))]
|
||||
(send/i displayer step-display<%> add-step step
|
||||
#:shift-table shift-table)
|
||||
(send/i displayer step-display<%> add-final raw-steps-estx raw-steps-exn
|
||||
#:binders raw-steps-binders
|
||||
#:shift-table shift-table
|
||||
#:definites raw-steps-definites)))]
|
||||
[else (display-oops #t)]))
|
||||
|
||||
;; display-oops : boolean -> void
|
||||
(define/private (display-oops show-syntax?)
|
||||
(cond [raw-steps-oops
|
||||
(send: displayer step-display<%> add-internal-error
|
||||
"steps" raw-steps-oops
|
||||
(and show-syntax? (wderiv-e1 deriv))
|
||||
events)]
|
||||
(send/i displayer step-display<%> add-internal-error
|
||||
"steps" raw-steps-oops
|
||||
(and show-syntax? (wderiv-e1 deriv))
|
||||
events)]
|
||||
[raw-deriv-oops
|
||||
(send: displayer step-display<%> add-internal-error
|
||||
"derivation" raw-deriv-oops #f events)]
|
||||
(send/i displayer step-display<%> add-internal-error
|
||||
"derivation" raw-deriv-oops #f events)]
|
||||
[else
|
||||
(error 'term-record::display-oops "internal error")]))
|
||||
))
|
||||
|
|
|
|||
|
|
@ -1,14 +1,13 @@
|
|||
#lang scheme/base
|
||||
(require scheme/class
|
||||
(rename-in unstable/class-iop
|
||||
[send/i send:])
|
||||
scheme/pretty
|
||||
scheme/gui
|
||||
framework/framework
|
||||
"interfaces.ss"
|
||||
"frame.ss"
|
||||
"prefs.ss"
|
||||
"../model/trace.ss")
|
||||
#lang racket/base
|
||||
(require racket/class
|
||||
racket/pretty
|
||||
racket/gui
|
||||
framework
|
||||
unstable/class-iop
|
||||
"interfaces.rkt"
|
||||
"frame.rkt"
|
||||
"prefs.rkt"
|
||||
"../model/trace.rkt")
|
||||
(provide macro-stepper-director%
|
||||
macro-stepper-frame%
|
||||
go)
|
||||
|
|
@ -28,23 +27,23 @@
|
|||
(hash-for-each stepper-frames
|
||||
(lambda (stepper-frame flags)
|
||||
(unless (memq 'no-obsolete flags)
|
||||
(send: stepper-frame stepper-frame<%> add-obsoleted-warning)))))
|
||||
(send/i stepper-frame stepper-frame<%> add-obsoleted-warning)))))
|
||||
(define/public (add-trace events)
|
||||
(hash-for-each stepper-frames
|
||||
(lambda (stepper-frame flags)
|
||||
(unless (memq 'no-new-traces flags)
|
||||
(send: (send: stepper-frame stepper-frame<%> get-widget) widget<%>
|
||||
(send/i (send/i stepper-frame stepper-frame<%> get-widget) widget<%>
|
||||
add-trace events)))))
|
||||
(define/public (add-deriv deriv)
|
||||
(hash-for-each stepper-frames
|
||||
(lambda (stepper-frame flags)
|
||||
(unless (memq 'no-new-traces flags)
|
||||
(send: (send: stepper-frame stepper-frame<%> get-widget) widget<%>
|
||||
(send/i (send/i stepper-frame stepper-frame<%> get-widget) widget<%>
|
||||
add-deriv deriv)))))
|
||||
|
||||
(define/public (new-stepper [flags '()])
|
||||
(define stepper-frame (new-stepper-frame))
|
||||
(define stepper (send: stepper-frame stepper-frame<%> get-widget))
|
||||
(define stepper (send/i stepper-frame stepper-frame<%> get-widget))
|
||||
(send stepper-frame show #t)
|
||||
(add-stepper! stepper-frame flags)
|
||||
stepper)
|
||||
|
|
@ -65,6 +64,6 @@
|
|||
|
||||
(define (go stx)
|
||||
(define director (new macro-stepper-director%))
|
||||
(define stepper (send: director director<%> new-stepper))
|
||||
(send: director director<%> add-deriv (trace stx))
|
||||
(define stepper (send/i director director<%> new-stepper))
|
||||
(send/i director director<%> add-deriv (trace stx))
|
||||
(void))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user