Skip to content

slideshow/step: record disappeared bindings & uses for step names #22

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Draft
wants to merge 2 commits into
base: master
Choose a base branch
from
Draft

slideshow/step: record disappeared bindings & uses for step names #22

Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
9b99dc8
slideshow/step: use modern Racket
LiberalArtist Nov 8, 2018
0e3cdd7
slideshow/step: record disappeared bindings & uses for step names
LiberalArtist Nov 8, 2018
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
233 changes: 121 additions & 112 deletions slideshow-lib/slideshow/step.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,117 +1,126 @@
#lang racket/base

(module step slideshow/slideshow
(require mzlib/list
mzlib/etc)
(require slideshow/slide
(only-in racket/list last-pair)
syntax/parse/define
(for-syntax racket/base
racket/syntax))

(provide with-steps with-steps~)

(define-syntax (with-steps stx)
(syntax-case stx ()
[(_ (step-name ...) expr0 expr ...)
#'(do-with-steps #f (step-name ...) expr0 expr ...)]))
(provide with-steps with-steps~)

(define-syntax-parser define-step
[(_ func:id macro:id steps-ids:id (arg:id ...)
(~optional
(~seq #:extra-args (reqd-extra-arg:id ...
[opt-extra-arg:id
opt-arg-default:expr] ...)))
body:expr)
(syntax/loc this-syntax
(begin
(define (func arg ...
(~? (~@ reqd-extra-arg ...))
(~? (~@ [opt-extra-arg opt-arg-default] ...)))
body)
(define-syntax-parser macro
#:disable-colon-notation
[(_ (~var arg id) ...
(~? (~@ (~var reqd-extra-arg expr) ...))
(~? (~@ (~optional (~var opt-extra-arg expr)) ...)))
#:do [(define steps-ids* (syntax-local-value #'steps-ids))]
#:fail-when (for/first ([id (in-list (list #'arg ...))]
#:unless
(member id steps-ids* free-identifier=?))
id)
"unknown step name"
(with-disappeared-uses
(record-disappeared-uses (list #'arg) ...)
(syntax/loc this-syntax
(func (quote arg) ...
(~? (~@ reqd-extra-arg ...))
(~? (~@ ((... ~?) opt-extra-arg) ...)))))])))])


(define-syntax-parser define-predicate/vproc
[(_ pred:id pred/p:id vproc:id proc:id
steps-ids:id
(arg:id ...)
body:expr)
#'(begin
(define-step pred/p pred steps-ids (arg ...) body)
(define-step v proc steps-ids (arg ...)
#:extra-args (f [else-f values])
(if (pred/p arg ...)
f
else-f))
(define-step v2 vproc steps-ids (arg ...)
(if (pred/p arg ...)
(let ([vproc (lambda (x) x)]) vproc)
(let ([vproc (lambda (x) (ghost x))]) vproc))))])

(define-syntax (with-steps~ stx)
(syntax-case stx ()
[(_ (step-name ...) expr0 expr ...)
#'(do-with-steps #t (step-name ...) expr0 expr ...)]))

(define-syntax (define-step stx)
(syntax-case stx ()
[(_ func id steps (arg ...)
(((extra-arg ...) (def-arg ...)) ...
((all-extra-arg ...) ()))
body)
(syntax/loc stx
(begin
(define func
(lambda (arg ... all-extra-arg ...)
body))
(define-syntax (id istx)
(syntax-case istx ()
[(_ arg ... extra-arg ...)
(syntax/loc istx (_ arg ... extra-arg ... def-arg ...))]
...
[(_ arg ... all-extra-arg ...)
(begin
(unless (ormap (lambda (i)
(and (identifier? #'arg)
(module-identifier=? i #'arg)))
(syntax->list (quote-syntax steps)))
(raise-syntax-error
#f
"unknown step name"
istx
#'arg))
...
(syntax/loc istx (func (quote arg) ... all-extra-arg ...)))]))))]))
(define-for-syntax (make-with-steps #:with-steps~ [for-with-steps~? #f])
(syntax-parser
[(_ (step-name:id ...) body0:expr body:expr ...)
#:do [(define step-names (syntax->list #'(step-name ...)))]
#:with (condense?-body ...)
(if for-with-steps~?
#`((skip-slides '#,(sub1 (length step-names)))
(last-pair steps))
(let ([non~-step-names
(filter (λ (id)
(not (regexp-match? #rx"~$" (symbol->string
(syntax->datum id)))))
step-names)])
#`[(skip-slides '#,(- (length step-names) (length non~-step-names)))
'(#,@non~-step-names)]))
(define-syntax-rule (with-captured
(name ...)
#:context context-expr
body ...)
(let ([context context-expr])
(with-syntax ([name (datum->syntax context 'name)] ...)
body ...)))
(syntax-property
(with-captured
(only? vonly only except? vexcept except
before? vbefore before after? vafter after
between? vbetween between between-excl? vbetween-excl between-excl)
#:context #'body0
#`(let ([steps '(step-name ...)])
(map (lambda (step)
(define-syntax steps-ids
(list (quote-syntax step-name) ...))
(define-predicate/vproc only? only?/p vonly only steps-ids
(p)
(eq? step p))
(define-predicate/vproc except? except?/p vexcept except steps-ids
(p)
(not (eq? step p)))
(define-predicate/vproc after? after?/p vafter after steps-ids
(p)
(memq step (or (memq p steps) null)))
(define-predicate/vproc before? vbefore?/p vbefore before steps-ids
(p)
(not (after?/p p)))
(define-predicate/vproc between? between?/p vbetween between steps-ids
(p1 p2)
(and (after?/p p1) (or (eq? step p2) (not (after?/p p2)))))
(define-predicate/vproc between-excl? between-excl?/p vbetween-excl between-excl steps-ids
(p1 p2)
(and (after?/p p1) (not (after?/p p2))))
(let () body0 body ...))
(cond
[condense?
condense?-body ...]
[else
steps]))))
'disappeared-binding (map syntax-local-introduce step-names))]))



(define-syntax with-steps
(make-with-steps))

(define-syntax with-steps~
(make-with-steps #:with-steps~ #t))

(define-syntax (define-predicate/vproc stx)
(syntax-case stx ()
[(_ pred pred/p vproc proc steps (arg ...) body)
#'(begin
(define-step pred/p pred steps (arg ...) ((() ())) body)
(define-step v proc steps (arg ...) (((f) (values))
((f else-f) ()))
(if (pred/p arg ...)
f
else-f))
(define-step v2 vproc steps (arg ...) ((() ()))
(if (pred/p arg ...)
(let ([vproc (lambda (x) x)]) vproc)
(let ([vproc (lambda (x) (ghost x))]) vproc))))]))

(define-syntax (do-with-steps stx)
(syntax-case stx ()
[(_ condensing (step-name ...) expr0 expr ...)
(let ([capturing (lambda (s)
(datum->syntax-object #'expr0 s))])
(with-syntax ([only? (capturing 'only?)]
[vonly (capturing 'vonly)]
[only (capturing 'only)]
[except? (capturing 'except?)]
[vexcept (capturing 'vexcept)]
[except (capturing 'except)]
[before? (capturing 'before?)]
[vbefore (capturing 'vbefore)]
[before (capturing 'before)]
[after? (capturing 'after?)]
[vafter (capturing 'vafter)]
[after (capturing 'after)]
[between? (capturing 'between?)]
[vbetween (capturing 'vbetween)]
[between (capturing 'between)]
[between-excl? (capturing 'between-excl?)]
[vbetween-excl (capturing 'vbetween-excl)]
[between-excl (capturing 'between-excl)])
#'(let ([steps '(step-name ...)])
(map (lambda (step)
(define-predicate/vproc only? only?/p vonly only (step-name ...)
(p)
(eq? step p))
(define-predicate/vproc except? except?/p vexcept except (step-name ...)
(p)
(not (eq? step p)))
(define-predicate/vproc after? after?/p vafter after (step-name ...)
(p)
(memq step (or (memq p steps) null)))
(define-predicate/vproc before? vbefore?/p vbefore before (step-name ...)
(p)
(not (after?/p p)))
(define-predicate/vproc between? between?/p vbetween between (step-name ...)
(p1 p2)
(and (after?/p p1) (or (eq? step p2) (not (after?/p p2)))))
(define-predicate/vproc between-excl? between-excl?/p vbetween-excl between-excl (step-name ...)
(p1 p2)
(and (after?/p p1) (not (after?/p p2))))
(let () expr0 expr ...))
(if (and condensing condense?)
(begin
(skip-slides (sub1 (length steps)))
(last-pair steps))
(if condense?
(let ([l (filter (lambda (id)
(not (regexp-match #rx"~$" (symbol->string id))))
steps)])
(skip-slides (- (length steps) (length l)))
l)
steps))))))])))