From fcc1c1063205853084e642a5e98fb89fbb64dd48 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Mon, 3 Oct 2011 16:31:23 -0400 Subject: [PATCH] working on the namespace errors due to the structure values coming from another module. --- cs019/cs019-pre-base.rkt | 6 +- cs019/cs019.rkt | 6 +- cs019/firstorder.rkt | 23 ++++ cs019/rewrite-error-message.rkt | 99 ++++++++++++++++ cs019/teach-runtime.rkt | 14 +++ cs019/teach.rkt | 190 +++++++++++++++++++++++++++++- lang/kernel.rkt | 7 +- tests/more-tests/basics-cs019.rkt | 160 +++++++++++++++++++++++++ 8 files changed, 499 insertions(+), 6 deletions(-) create mode 100644 cs019/firstorder.rkt create mode 100755 cs019/rewrite-error-message.rkt create mode 100644 cs019/teach-runtime.rkt create mode 100755 tests/more-tests/basics-cs019.rkt diff --git a/cs019/cs019-pre-base.rkt b/cs019/cs019-pre-base.rkt index 1ae534b..a46646e 100644 --- a/cs019/cs019-pre-base.rkt +++ b/cs019/cs019-pre-base.rkt @@ -9,10 +9,12 @@ cs019-when cs019-unless cs019-set! - cs019-case) + cs019-case + cs019-local) (define-syntax cs019-define advanced-define/proc) (define-syntax cs019-lambda advanced-lambda/proc) (define-syntaxes (cs019-when cs019-unless) (values advanced-when/proc advanced-unless/proc)) (define-syntax cs019-set! advanced-set!/proc) -(define-syntax cs019-case advanced-case/proc) \ No newline at end of file +(define-syntax cs019-case advanced-case/proc) +(define-syntax cs019-local intermediate-local/proc) diff --git a/cs019/cs019.rkt b/cs019/cs019.rkt index 59dcde5..4d47a2a 100644 --- a/cs019/cs019.rkt +++ b/cs019/cs019.rkt @@ -13,7 +13,8 @@ [cs019-define define] [cs019-when when] [cs019-unless unless] - [cs019-case case])) + [cs019-case case] + [cs019-local local])) (require "private/sigs-patched.rkt") (provide [all-from-out "private/sigs-patched.rkt"]) @@ -44,7 +45,8 @@ define lambda unless - when) + when + local) string-ith replicate diff --git a/cs019/firstorder.rkt b/cs019/firstorder.rkt new file mode 100644 index 0000000..e8eb8de --- /dev/null +++ b/cs019/firstorder.rkt @@ -0,0 +1,23 @@ +(module firstorder mzscheme + + (provide make-first-order + first-order->higher-order) + + (define-values (struct:fo make-first-order fo? fo-get fo-set!) + (make-struct-type 'procedure #f 2 0 #f null (current-inspector) 0)) + + (define fo-proc-id (make-struct-field-accessor fo-get 1)) + + (define (first-order->higher-order id) + (let ([v (syntax-local-value id (lambda () #f))]) + (if (or (fo? v) + (and (set!-transformer? v) + (fo? (set!-transformer-procedure v)))) + (syntax-property + (syntax-local-introduce + (fo-proc-id (if (fo? v) v (set!-transformer-procedure v)))) + 'disappeared-use + (syntax-local-introduce id)) + id)))) + + diff --git a/cs019/rewrite-error-message.rkt b/cs019/rewrite-error-message.rkt new file mode 100755 index 0000000..1083fdc --- /dev/null +++ b/cs019/rewrite-error-message.rkt @@ -0,0 +1,99 @@ +#lang scheme/base + +(require mzlib/etc + mzlib/list + (for-syntax "firstorder.rkt" + scheme/base)) + +(provide rewrite-contract-error-message + reraise-rewriten-lookup-error-message + get-rewriten-error-message + plural + raise-not-bound-error + argcount-error-message) + +(define (reraise-rewriten-lookup-error-message e id was-in-app-position) + (let ([var-or-function (if was-in-app-position "function" "variable")]) + (raise-syntax-error + #f + (format "this ~a is not defined" var-or-function) + id))) + +(define (exn-needs-rewriting? exn) + (exn:fail:contract? exn)) + +(define (ensure-number n-or-str) + (if (string? n-or-str) (string->number n-or-str) n-or-str)) + +(define (plural n) + (if (> (ensure-number n) 1) "s" "")) + +(define (raise-not-bound-error id) + (if (syntax-property id 'was-in-app-position) + (raise-syntax-error + #f + "this function is not defined" + id) + (raise-syntax-error + #f + "this variable is not defined" + id))) + +(define (argcount-error-message arity found [at-least #f]) + (define arity:n (ensure-number arity)) + (define found:n (ensure-number found)) + (define fn-is-large (> arity:n found:n)) + (format "expects ~a~a~a argument~a, but found ~a~a" + (if at-least "at least " "") + (if (or (= arity:n 0) fn-is-large) "" "only ") + (if (= arity:n 0) "no" arity:n) (plural arity:n) + (if (and (not (= found:n 0)) fn-is-large) "only " "") + (if (= found:n 0) "none" found:n))) + +(define (rewrite-contract-error-message msg) + (define replacements + (list (list #rx"procedure application: expected procedure, given: (.*) \\(no arguments\\)" + (lambda (all one) + (format "function call: expected a function after the open parenthesis, but received ~a" one))) + (list #rx"procedure application: expected procedure, given: (.*); arguments were:.*" + (lambda (all one) + (format "function call: expected a function after the open parenthesis, but received ~a" one))) + (list #rx"expects argument of type (<([^>]+)>)" + (lambda (all one two) (format "expects a ~a" two))) + (list #rx"expected argument of type (<([^>]+)>)" + (lambda (all one two) (format "expects a ~a" two))) + (list #rx"expects type (<([^>]+)>)" + (lambda (all one two) (format "expects a ~a" two))) + (list #px"expects at least (\\d+) argument.?, given (\\d+)(: .*)?" + (lambda (all one two three) (argcount-error-message one two #t))) + (list #px"expects (\\d+) argument.?, given (\\d+)(: .*)?" + (lambda (all one two three) (argcount-error-message one two))) + (list #rx"^procedure " + (lambda (all) "")) + (list #rx", given: " + (lambda (all) ", given ")) + (list #rx"; other arguments were:.*" + (lambda (all) "")) + (list #rx"expects a (struct:)" + (lambda (all one) "expects a ")) + (list #rx"list or cyclic list" + (lambda (all) "list")) + (list (regexp-quote "given #(struct:object:image% ...)") + (lambda (all) "given an image")) + (list (regexp-quote "given #(struct:object:image-snip% ...)") + (lambda (all) "given an image")) + (list (regexp-quote "given #(struct:object:cache-image-snip% ...)") + (lambda (all) "given an image")) + (list (regexp-quote "#(struct:object:image% ...)") + (lambda (all) "(image)")) + (list (regexp-quote "#(struct:object:image-snip% ...)") + (lambda (all) "(image)")) + (list (regexp-quote "#(struct:object:cache-image-snip% ...)") + (lambda (all) "(image)")))) + (for/fold ([msg msg]) ([repl. replacements]) + (regexp-replace* (first repl.) msg (second repl.)))) + +(define (get-rewriten-error-message exn) + (if (exn-needs-rewriting? exn) + (rewrite-contract-error-message (exn-message exn)) + (exn-message exn))) diff --git a/cs019/teach-runtime.rkt b/cs019/teach-runtime.rkt new file mode 100644 index 0000000..d367067 --- /dev/null +++ b/cs019/teach-runtime.rkt @@ -0,0 +1,14 @@ +#lang s-exp "../lang/base.rkt" + +(provide check-not-undefined) + +;; Wrapped around uses of local-bound variables: +(define (check-not-undefined name val) + (if (eq? val undefined) + (raise + (make-exn:fail:contract:variable + (format "local variable used before its definition: ~a" name) + (current-continuation-marks) + name)) + val)) +(define undefined (letrec ([x x]) x)) diff --git a/cs019/teach.rkt b/cs019/teach.rkt index 27fc69b..c64bc22 100644 --- a/cs019/teach.rkt +++ b/cs019/teach.rkt @@ -1,8 +1,12 @@ #lang racket/base (require (for-template "../lang/base.rkt") + (for-template "teach-runtime.rkt") + "teachhelp.rkt" stepper/private/shared racket/list + syntax/context + syntax/kerncase syntax/stx) @@ -11,7 +15,19 @@ advanced-when/proc advanced-unless/proc advanced-set!/proc advanced-set!-continue/proc - advanced-case/proc) + advanced-case/proc + intermediate-local/proc) + + + + ;; verify-boolean is inserted to check for boolean results: + (define (verify-boolean b where) + (if (or (eq? b #t) (eq? b #f)) + b + (raise + (make-exn:fail:contract + (format "~a: question result is not true or false: ~e" where b) + (current-continuation-marks))))) ;; A consistent pattern for stepper-skipto: @@ -269,6 +285,178 @@ + + + + + + + + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; local + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (define (intermediate-local/proc stx) + (ensure-expression + stx + (lambda () + (syntax-case stx () + [(_ (definition ...) . exprs) + (let ([defns (syntax->list (syntax (definition ...)))] + ;; The following context value lets teaching-language definition + ;; forms know that it's ok to expand in this internal + ;; definition context. + [int-def-ctx (build-expand-context (make-expanding-for-intermediate-local))]) + (let* ([partly-expand (lambda (d) + (local-expand + d + int-def-ctx + (kernel-form-identifier-list)))] + [partly-expanded-defns + (map partly-expand defns)] + [flattened-defns + (let loop ([l partly-expanded-defns][origs defns]) + (apply + append + (map (lambda (d orig) + (syntax-case d (begin define-values define-syntaxes) + ;; we don't have to check for ill-formed `define-values' + ;; or `define-syntaxes', because only macros can generate + ;; them + [(begin defn ...) + (let ([l (map partly-expand (syntax->list (syntax (defn ...))))]) + (loop l l))] + [(define-values . _) + (list d)] + [(define-syntaxes . _) + (list d)] + [_else + (teach-syntax-error + 'local + stx + orig + "expected a definition, but found ~a" + (something-else orig))])) + l origs)))] + [val-defns + (apply + append + (map (lambda (partly-expanded) + (syntax-case partly-expanded (define-values) + [(define-values (id ...) expr) + (list partly-expanded)] + [_else + null])) + flattened-defns))] + [stx-defns + (apply + append + (map (lambda (partly-expanded) + (syntax-case partly-expanded (define-syntaxes) + [(define-syntaxes (id ...) expr) + (list partly-expanded)] + [_else + null])) + flattened-defns))] + [get-ids (lambda (l) + (apply + append + (map (lambda (partly-expanded) + (syntax-case partly-expanded () + [(_ (id ...) expr) + (syntax->list (syntax (id ...)))])) + l)))] + [val-ids (get-ids val-defns)] + [stx-ids (get-ids stx-defns)]) + (let ([dup (check-duplicate-identifier (append val-ids stx-ids))]) + (when dup + (teach-syntax-error + 'local + stx + dup + "~a was defined locally more than once" + (syntax-e dup))) + (let ([exprs (syntax->list (syntax exprs))]) + (check-single-expression 'local + "after the local definitions" + stx + exprs + (append val-ids stx-ids))) + (with-syntax ([((d-v (def-id ...) def-expr) ...) val-defns] + [(stx-def ...) stx-defns]) + (with-syntax ([(((tmp-id def-id/prop) ...) ...) + ;; Generate tmp-ids that at least look like the defined + ;; ids, for the purposes of error reporting, etc.: + (map (lambda (def-ids) + (map (lambda (def-id) + (list + (stepper-syntax-property + (datum->syntax + #f + (string->uninterned-symbol + (symbol->string (syntax-e def-id)))) + 'stepper-orig-name + def-id) + (syntax-property + def-id + 'bind-as-variable + #t))) + (syntax->list def-ids))) + (syntax->list (syntax ((def-id ...) ...))))]) + (with-syntax ([(mapping ...) + (let ([mappers + (syntax->list + (syntax + ((define-syntaxes (def-id/prop ...) + (values + (make-undefined-check + (quote-syntax check-not-undefined) + (quote-syntax tmp-id)) + ...)) + ...)))]) + (map syntax-track-origin + mappers + val-defns + (syntax->list (syntax (d-v ...)))))]) + (stepper-syntax-property + (quasisyntax/loc stx + (let () + (#%stratified-body + (define #,(gensym) 1) ; this ensures that the expansion of 'local' looks + ; roughly the same, even if the local has no defs. + mapping ... + stx-def ... + (define-values (tmp-id ...) def-expr) + ... + . exprs))) + 'stepper-hint + 'comes-from-local)))))))] + [(_ def-non-seq . __) + (teach-syntax-error + 'local + stx + (syntax def-non-seq) + "expected at least one definition (in square brackets) after local, but found ~a" + (something-else (syntax def-non-seq)))] + [(_) + (teach-syntax-error + 'local + stx + #f + "expected at least one definition (in square brackets) after local, but nothing's there")] + [_else (bad-use-error 'local stx)])))) + + + + + + + + + + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; define (beginner) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/lang/kernel.rkt b/lang/kernel.rkt index c160022..e96ea65 100644 --- a/lang/kernel.rkt +++ b/lang/kernel.rkt @@ -201,7 +201,12 @@ exn:fail struct:exn:fail - prop:exn:srclocs) + prop:exn:srclocs + + + ;; needed for cs019-local + #%stratified-body + ) (define (-identity x) x) diff --git a/tests/more-tests/basics-cs019.rkt b/tests/more-tests/basics-cs019.rkt new file mode 100755 index 0000000..cb6f8df --- /dev/null +++ b/tests/more-tests/basics-cs019.rkt @@ -0,0 +1,160 @@ +#lang planet dyoo/whalesong/cs019 + +(define-struct f (x)) +(define-struct g (a b)) +(check-expect (build-list 5 add1) (list 1 2 3 4 5)) +(check-expect (make-g 1 2) (make-g 1 2)) +(check-expect (make-g 'b empty) (make-g 'b empty)) + +(define i (open-image-url "http://racket-lang.org/logo.png")) +(check-expect (image-height i) 85) +(check-expect (image-width i) 88) + +;; Whalesong currently has no support for hashes. +;(define ht (hash)) +;(define ht2 (hash-set ht "x" 10)) +;(check-expect(hash-ref ht2 "x") 10) +;(check-error (hash-ref ht "x") "hash-ref: no value found for key: \"x\"") + +;; INSERTION SORT + +(define: (isort [l : (Listof: Number$)]) -> (Listof: Number$) + (cond + [(empty? l) l] + [(cons? l) (insert (first l) + (isort (rest l)))])) + +(define: (insert [e : Number$] [l : (Listof: Number$)]) -> (Listof: Number$) + (cond + [(empty? l) (cons e l)] + [(cons? l) (if (<= e (first l)) + (cons e l) + (cons (first l) + (insert e (rest l))))])) + +(check-expect (isort (list 3 1 2 4)) (list 1 2 3 4)) + +;; TREE ZIP + +;(struct: None ()) +;(struct: (a) Some ([v : a])) +;(define-type (Opt a) (U None (Some a))) +(define-struct: None ()) +(define-struct: Some ([v : Any$])) +(define Opt$ (or: None$ Some$)) + +;(struct: (a) Node ([value : a] [kids : (Listof (Tree a))]) #:transparent) +;(struct: MtNode () #:transparent) +;(define-type Tree (All (a) (U (Node a) MtNode))) +(define-struct: Node ([value : Any$] [kids : (Listof: Tree$)])) +(define-struct: MtNode ()) +(define Tree$ (or: Node$ MtNode$)) + +;(struct: (a) BackPtr ([n : (Node a)] [p : Integer]) #:transparent) +;(struct: (a) Cursor ([below : (Tree a)] [above : (Listof (BackPtr a))]) #:transparent) +(define-struct: BackPtr ([n : Node$] [p : (Sig: integer?)])) +(define-struct: Cursor ([below : Tree$] [above : (Listof: BackPtr$)])) + +(define Opt-Cursor$ (Sig: (lambda (v) + (or (None? v) + (and (Some? v) + (Cursor? (Some-v v))))))) + +;(: find (All (a) ((Tree a) (a -> Boolean) -> (Cursor a)))) +(define: (find [t : Tree$] [p : (Any$ -> Boolean$)]) -> Cursor$ + (local + [ + ;(: find-helper (All (a) ((Tree a) (Listof (BackPtr a)) -> (Opt (Cursor a))))) + (define: (find-helper [t : Tree$] [above : (Listof: BackPtr$)]) -> Opt-Cursor$ + (cond + [(MtNode? t) (make-None)] + [(Node? t) + (if (p (Node-value t)) + (make-Some (make-Cursor t above)) + (let ([v (search-kids (Node-kids t) 0 t above)]) + (if (Some? v) v (make-None))))])) + +; (: search-kids (All (a) ((Listof (Tree a)) +; Integer +; (Node a) +; (Listof (BackPtr a)) -> (Opt (Cursor a))))) + (define: (search-kids [kids : (Listof: Tree$)] + [n : (Sig: integer?)] + [first-above : Node$] + [rest-above : (Listof: BackPtr$)]) -> Opt-Cursor$ + (cond + [(empty? kids) (make-None)] + [(cons? kids) + (let ([v (find-helper (first kids) + (cons (make-BackPtr first-above n) rest-above))]) + (if (Some? v) + v + (search-kids (rest kids) (add1 n) first-above rest-above)))])) + ] + (let ([v (find-helper t empty)]) + (if (None? v) (error 'find "no such node") (Some-v v))))) + +;(: down (All (a) ((Cursor a) Integer -> (Cursor a)))) +(define: (down [c : Cursor$] [n : (Sig: integer?)]) -> Cursor$ + (let ([v (Cursor-below c)]) + (cond + [(MtNode? v) (error 'down "impossible to go down")] + [(Node? v) + (if (empty? (Node-kids v)) + (error 'down "impossible to go down") + (make-Cursor (list-ref (Node-kids v) n) + (cons (make-BackPtr v n) (Cursor-above c))))]))) + +;(: replace (All (a) ((Cursor a) (Tree a) -> (Cursor a)))) +(define: (replace [c : Any$] [t : Tree$]) -> Cursor$ + (make-Cursor t (Cursor-above c))) + +;(: reconstruct/1 (All (a) ((BackPtr a) (Tree a) -> (Node a)))) +(define: (reconstruct/1 [one-up : BackPtr$] [replace-with : Tree$]) -> Node$ + (let ([node (BackPtr-n one-up)] + [posn (BackPtr-p one-up)]) + (let ([val (Node-value node)] + [kids (Node-kids node)]) + (make-Node val + (build-list (length kids) + (lambda: ([i : (Sig: integer?)]) -> Tree$ + (if (= i posn) + replace-with + (list-ref kids i)))))))) + +;(: up (All (a) ((Cursor a) -> (Cursor a)))) +(define: (up [c : Cursor$]) -> Cursor$ + (if (empty? (Cursor-above c)) + (error 'up "impossible to go up") + (make-Cursor (reconstruct/1 (first (Cursor-above c)) + (Cursor-below c)) + (rest (Cursor-above c))))) + +;(: ->tree (All (a) ((Cursor a) -> (Tree a)))) +(define: (->tree [c : Cursor$]) -> Tree$ + (if (empty? (Cursor-above c)) + (Cursor-below c) + (->tree (up c)))) + +(define T (make-Node 7 (list (make-Node 3 empty) (make-MtNode) (make-Node 5 empty)))) +(define c0 (find T (lambda: ([n : (Sig: integer?)]) -> Boolean$ (= n 3)))) +(define c2 (find T (lambda: ([n : (Sig: integer?)]) -> Boolean$ (= n 5)))) +(define c3 (replace (down (up c0) 1) T) ) +(define c4 (replace (down (replace (down (up c0) 1) T) 0) (make-MtNode))) + +(check-expect T (->tree c0)) +(check-expect T (->tree c2)) +(check-expect (->tree c3) + (make-Node 7 + (list (make-Node 3 empty) + (make-Node 7 (list (make-Node 3 empty) + (make-MtNode) + (make-Node 5 empty))) + (make-Node 5 empty)))) +(check-expect (->tree c4) + (make-Node 7 + (list (make-Node 3 empty) + (make-Node 7 (list (make-MtNode) + (make-MtNode) + (make-Node 5 empty))) + (make-Node 5 empty))))