suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

some Racket-y (102); arrows and renaming for define-struct in teaching languages; need to find and run lang tests

Browse Source
This commit is contained in:
Matthias Felleisen 2014-08-01 08:59:57 -04:00
parent a57734d7ae
commit e430753b6c
1 changed files with 3027 additions and 2924 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

219
pkgs/htdp-pkgs/htdp-lib/lang/private/teach.rkt
View File

@ -32,8 +32,8 @@
;; reporting. As always, avoid using `local-expand' if there's no ;; reporting. As always, avoid using `local-expand' if there's no
;; error. ;; error.
(module teach mzscheme #lang mzscheme
(require mzlib/etc (require mzlib/etc
mzlib/list mzlib/list
mzlib/math mzlib/math
mzlib/pconvert-prop mzlib/pconvert-prop
@ -55,9 +55,9 @@
beginner-equal? beginner-equal~? teach-equal? beginner-equal? beginner-equal~? teach-equal?
advanced-cons advanced-list*)) advanced-cons advanced-list*))
(require "rewrite-error-message.rkt") (require "rewrite-error-message.rkt")
(require-for-syntax "teachhelp.rkt" (require-for-syntax "teachhelp.rkt"
"rewrite-error-message.rkt" "rewrite-error-message.rkt"
"teach-shared.rkt" "teach-shared.rkt"
"rewrite-error-message.rkt" "rewrite-error-message.rkt"
@ -74,12 +74,21 @@
stepper/private/syntax-property stepper/private/syntax-property
test-engine/racket-tests) test-engine/racket-tests)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-for-syntax EXPECTED-HEADER
;; run-time helpers "expected a variable name, or a function name and its variables (in parentheses), but found ~a")
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; verify-boolean is inserted to check for boolean results: (define-for-syntax EXPECTED-MATCH-PATTERN
(define (verify-boolean b where) "expected a pattern--answer clause after the expression following `match', but nothing's there")
(define-for-syntax EXPECTED-FUNCTION-NAME
"expected a function after the open parenthesis, but found a structure name")
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; run-time helpers
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; verify-boolean is inserted to check for boolean results:
(define (verify-boolean b where)
(if (or (eq? b #t) (eq? b #f)) (if (or (eq? b #t) (eq? b #f))
b b
(raise (raise
@ -87,34 +96,34 @@
(format "~a: question result is not true or false: ~e" where b) (format "~a: question result is not true or false: ~e" where b)
(current-continuation-marks))))) (current-continuation-marks)))))
(define (identifier-is-bound? id) (define (identifier-is-bound? id)
(or (identifier-binding id) (or (identifier-binding id)
;; identifier-binding returns #f for variable bound at the top-level, ;; identifier-binding returns #f for variable bound at the top-level,
;; check explicitly: ;; check explicitly:
(and (namespace-variable-value (syntax-e id) #t (lambda () #f)) #t))) (and (namespace-variable-value (syntax-e id) #t (lambda () #f)) #t)))
;; Wrapped around top-level definitions to disallow re-definition: ;; Wrapped around top-level definitions to disallow re-definition:
(define (check-top-level-not-defined who id) (define (check-top-level-not-defined who id)
(when (identifier-is-bound? id) (when (identifier-is-bound? id)
(raise-syntax-error #f "this name was defined previously and cannot be re-defined" id))) (raise-syntax-error #f "this name was defined previously and cannot be re-defined" id)))
(define (top/check-defined id) (define (top/check-defined id)
(namespace-variable-value (syntax-e id) #t (lambda () (raise-not-bound-error id)))) (namespace-variable-value (syntax-e id) #t (lambda () (raise-not-bound-error id))))
;; For quasiquote and shared: ;; For quasiquote and shared:
(require (rename "teachprims.rkt" the-cons advanced-cons)) (require (rename "teachprims.rkt" the-cons advanced-cons))
(require (only "teachprims.rkt" cyclic-list?)) (require (only "teachprims.rkt" cyclic-list?))
;; Referenced to ensure that evaluating `lambda' always ;; Referenced to ensure that evaluating `lambda' always
;; produces a new closure (instead of using a closure ;; produces a new closure (instead of using a closure
;; that's allocated once) ;; that's allocated once)
(define make-lambda-generative 5) (define make-lambda-generative 5)
;; A consistent pattern for stepper-skipto: ;; A consistent pattern for stepper-skipto:
(define-for-syntax (stepper-ignore-checker stx) (define-for-syntax (stepper-ignore-checker stx)
(stepper-syntax-property stx 'stepper-skipto '(syntax-e cdr syntax-e cdr car))) (stepper-syntax-property stx 'stepper-skipto '(syntax-e cdr syntax-e cdr car)))
(define-for-syntax (map-with-index proc . lists) (define-for-syntax (map-with-index proc . lists)
(let loop ([i 0] [lists lists] [rev-result '()]) (let loop ([i 0] [lists lists] [rev-result '()])
(if (null? (car lists)) (if (null? (car lists))
(reverse rev-result) (reverse rev-result)
@ -122,8 +131,8 @@
(map cdr lists) (map cdr lists)
(cons (apply proc i (map car lists)) rev-result))))) (cons (apply proc i (map car lists)) rev-result)))))
;; build-struct-names is hard to handle ;; build-struct-names is hard to handle
(define-for-syntax (make-struct-names name fields stx) (define-for-syntax (make-struct-names name fields stx)
(apply (lambda (struct: constructor predicate . rest) (apply (lambda (struct: constructor predicate . rest)
(let loop ([rest rest] (let loop ([rest rest]
[getters '()] [getters '()]
@ -135,11 +144,11 @@
(cons (cadr rest) setters))))) (cons (cadr rest) setters)))))
(build-struct-names name fields #f #f stx))) (build-struct-names name fields #f #f stx)))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; syntax implementations ;; syntax implementations
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-syntax define-syntax-set/provide (define-syntax define-syntax-set/provide
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ (id ...) defn ...) [(_ (id ...) defn ...)
@ -159,14 +168,14 @@
defn ...))))]))) defn ...))))])))
;; The implementation of form X is defined below as X/proc. The ;; The implementation of form X is defined below as X/proc. The
;; reason for this is to allow the implementation of Y to re-use the ;; reason for this is to allow the implementation of Y to re-use the
;; implementation of X (expanding to a use of X would mangle syntax ;; implementation of X (expanding to a use of X would mangle syntax
;; error messages), while preserving the binding of X as the one for ;; error messages), while preserving the binding of X as the one for
;; the syntax definition (so that quasiquote can recognize unquote, ;; the syntax definition (so that quasiquote can recognize unquote,
;; etc.). ;; etc.).
(define-syntax-set/provide (beginner-define (define-syntax-set/provide (beginner-define
beginner-define-struct beginner-define-struct
beginner-lambda beginner-lambda
beginner-app beginner-app-continue beginner-app beginner-app-continue
@ -329,7 +338,8 @@
assign)] assign)]
[made-up (gensym)] [made-up (gensym)]
[defn defn]) [defn defn])
(with-syntax ([made-up-defn (stepper-syntax-property (with-syntax ([made-up-defn
(stepper-syntax-property
(syntax (define made-up (lambda () (advanced-set! name 10) ...))) (syntax (define made-up (lambda () (advanced-set! name 10) ...)))
'stepper-skip-completely 'stepper-skip-completely
#t)]) #t)])
@ -635,7 +645,7 @@
'define 'define
stx stx
(syntax non-name) (syntax non-name)
"expected a variable name, or a function name and its variables (in parentheses), but found ~a" EXPECTED-HEADER
(something-else/kw (syntax non-name)))] (something-else/kw (syntax non-name)))]
;; Missing name: ;; Missing name:
[(_) [(_)
@ -657,7 +667,8 @@
#`(define (#,#'name x) #`(define (#,#'name x)
(begin (begin
(send (send (get-test-engine) get-info) add-wish-call (quote #,#'name)) (send (send (get-test-engine) get-info) add-wish-call (quote #,#'name))
(raise (exn:fail:wish (format "wished for function ~a not implemented" (quote #,#'name)) (raise (exn:fail:wish
(format "wished for function ~a not implemented" (quote #,#'name))
(current-continuation-marks) (quote #,#'name) x)))) #'lambda)] (current-continuation-marks) (quote #,#'name) x)))) #'lambda)]
[(_ name default-value) [(_ name default-value)
(define/proc #t #f (define/proc #t #f
@ -951,7 +962,85 @@
(values #,signature-name #,parametric-signature-name proc-name ...))) (values #,signature-name #,parametric-signature-name proc-name ...)))
'stepper-black-box-expr 'stepper-black-box-expr
stx))))]) stx))))])
(let ([defn ;; --------------------------------------------------------------------------------
(define struct-name-size (string-length (symbol->string (syntax-e #'name_))))
(define struct-name/locally-introduced (syntax-local-introduce #'name_))
(define struct-name-to-maker-directive
(vector (syntax-local-introduce constructor-name)
5
struct-name-size
struct-name/locally-introduced
0
struct-name-size))
(define struct-name-to-predicate-directive
(vector (syntax-local-introduce predicate-name)
0
struct-name-size
struct-name/locally-introduced
0
struct-name-size))
(define (struct->selector-directive selector)
(define selector-name/locally-introduced (syntax-local-introduce selector))
(vector selector-name/locally-introduced
0
struct-name-size
struct-name/locally-introduced
0
struct-name-size))
(define (field->selector-directive field selector)
(define field-name/locally-introduced (syntax-local-introduce field))
(define field-name-size (string-length (symbol->string (syntax-e field))))
(define selector-name/locally-introduced (syntax-local-introduce selector))
(vector selector-name/locally-introduced
(+ struct-name-size 1)
field-name-size
field-name/locally-introduced
0
field-name-size))
(define (struct->setter-directive setter)
(define setter-name/locally-introduced (syntax-local-introduce setter))
(vector setter-name/locally-introduced
;; set-name_-field!
;; 012|--->|
(string-length "set-")
struct-name-size
struct-name/locally-introduced
0
struct-name-size))
(define (field->setter-directive field setter)
(define field-name/locally-introduced (syntax-local-introduce field))
(define field-name-size (string-length (symbol->string (syntax-e field))))
(define setter-name/locally-introduced (syntax-local-introduce setter))
(vector setter-name/locally-introduced
;; set-name_-field!
;; 012|4...X|--->
(+ (string-length "set-") struct-name-size 1)
field-name-size
field-name/locally-introduced
0
field-name-size))
(define signature-name-directive #f)
(define parametric-signature-name-directive #f)
(define all-directives
(list* signature-name-directive
parametric-signature-name-directive
struct-name-to-maker-directive
struct-name-to-predicate-directive
(map field->selector-directive fields getter-names)
(map struct->selector-directive getter-names)
(map field->setter-directive fields setter-names)
(map struct->setter-directive setter-names)))
;; --------------------------------------------------------------------------------
(let* ([defn
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
#,(stepper-syntax-property #,(stepper-syntax-property
@ -967,7 +1056,7 @@
[(self . args) [(self . args)
(raise-syntax-error (raise-syntax-error
#f #f
"expected a function after the open parenthesis, but found a structure name" EXPECTED-FUNCTION-NAME
stx stx
#'self)] #'self)]
[_ #'#,signature-name]))) [_ #'#,signature-name])))
@ -975,12 +1064,15 @@
(make-info (lambda () compile-info)))) (make-info (lambda () compile-info))))
'stepper-skip-completely 'stepper-skip-completely
#t) #t)
#,defn0))]) #,defn0))]
(check-definitions-new 'define-struct [defn (check-definitions-new 'define-struct
stx stx
(list* name parametric-signature-name to-define-names) (list* name parametric-signature-name to-define-names)
defn defn
(and setters? bind-names))))))))] (and setters? bind-names))]
[defn (syntax-property defn 'disappeared-use (list (syntax-local-introduce #'name_)))]
[defn (syntax-property defn 'sub-range-binders all-directives)])
defn))))))]
[(_ name_ something . rest) [(_ name_ something . rest)
(teach-syntax-error (teach-syntax-error
'define-struct 'define-struct
@ -2631,7 +2723,7 @@
'match 'match
stx stx
#f #f
"expected a pattern--answer clause after the expression following `match', but nothing's there")] EXPECTED-MATCH-PATTERN)]
[(_ v-expr clause ...) [(_ v-expr clause ...)
(let ([clauses (syntax->list (syntax (clause ...)))]) (let ([clauses (syntax->list (syntax (clause ...)))])
(for-each (for-each
@ -2677,7 +2769,18 @@
qqp]))] qqp]))]
[check-and-translate-p [check-and-translate-p
(λ (p) (λ (p)
(syntax-case p (struct posn beginner-true beginner-false empty intermediate-quote intermediate-quasiquote advanced-cons list advanced-list* vector box) (syntax-case p (struct
posn
beginner-true
beginner-false
empty
intermediate-quote
intermediate-quasiquote
advanced-cons
list
advanced-list*
vector
box)
[beginner-true [beginner-true
(syntax/loc p (syntax/loc p
#t)] #t)]
@ -2854,10 +2957,10 @@
;; The main implementation ;; The main implementation
(shared/proc stx make-check-cdr)))))) (shared/proc stx make-check-cdr))))))
;; ---------------------------------------- ;; ----------------------------------------
;; Utilities for `define-struct': ;; Utilities for `define-struct':
(define (make-equal-hash generic-access field-count) (define (make-equal-hash generic-access field-count)
(lambda (r recur) (lambda (r recur)
(let loop ((i 0) (let loop ((i 0)
(factor 1) (factor 1)
@ -2868,7 +2971,7 @@
(* factor 33) (* factor 33)
(+ hash (* factor (recur (generic-access r i))))))))) (+ hash (* factor (recur (generic-access r i)))))))))
(define (make-equal2-hash generic-access field-count) (define (make-equal2-hash generic-access field-count)
(lambda (r recur) (lambda (r recur)
(let loop ((i 0) (let loop ((i 0)
(factor 1) (factor 1)
@ -2880,22 +2983,22 @@
(+ hash (* factor (+ hash (* factor
(recur (generic-access r (- field-count i 1)))))))))) (recur (generic-access r (- field-count i 1))))))))))
;; ---------------------------------------- ;; ----------------------------------------
;; Extend quote forms to work with `match': ;; Extend quote forms to work with `match':
(provide beginner-quote (provide beginner-quote
intermediate-quote intermediate-quote
intermediate-quasiquote) intermediate-quasiquote)
(define-match-expander beginner-quote (define-match-expander beginner-quote
(syntax-local-value #'beginner-quote/expr) (syntax-local-value #'beginner-quote/expr)
(syntax-local-value #'beginner-quote/expr)) (syntax-local-value #'beginner-quote/expr))
(define-match-expander intermediate-quote (define-match-expander intermediate-quote
(syntax-local-value #'intermediate-quote/expr) (syntax-local-value #'intermediate-quote/expr)
(syntax-local-value #'intermediate-quote/expr)) (syntax-local-value #'intermediate-quote/expr))
(define-match-expander intermediate-quasiquote (define-match-expander intermediate-quasiquote
;; Match expander: ;; Match expander:
(let ([qq (syntax-local-value #'intermediate-quasiquote/expr)]) (let ([qq (syntax-local-value #'intermediate-quasiquote/expr)])
(lambda (stx) (lambda (stx)
@ -2932,7 +3035,7 @@
;; Expression expander: ;; Expression expander:
(syntax-local-value #'intermediate-quasiquote/expr)) (syntax-local-value #'intermediate-quasiquote/expr))
(define-match-expander the-cons/matchable (define-match-expander the-cons/matchable
;; For match (no cdr check needed for deconstruction): ;; For match (no cdr check needed for deconstruction):
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
@ -3095,4 +3198,4 @@
(or (boolean? x) (or (boolean? x)
(property? x)))))) (property? x))))))
)