diff --git a/pkgs/typed-racket-pkgs/source-syntax/info.rkt b/pkgs/typed-racket-pkgs/source-syntax/info.rkt new file mode 100644 index 00000000..a0eebe8d --- /dev/null +++ b/pkgs/typed-racket-pkgs/source-syntax/info.rkt @@ -0,0 +1,9 @@ +#lang info + +(define collection "syntax") + +(define deps '("base")) + +(define pkg-desc "find mappings from expanded to source syntax") + +(define pkg-authors '(samth stamourv eli)) diff --git a/pkgs/typed-racket-pkgs/source-syntax/source-syntax.rkt b/pkgs/typed-racket-pkgs/source-syntax/source-syntax.rkt new file mode 100644 index 00000000..199b4a94 --- /dev/null +++ b/pkgs/typed-racket-pkgs/source-syntax/source-syntax.rkt @@ -0,0 +1,87 @@ +#lang racket/base + +;; from Eli + +(provide recover-source-syntax) + +;; -------------------- utilities + +(define (syntax-loc stx) (list (syntax-source stx) (syntax-position stx) (syntax-span stx))) + + +;; -------------------- the real stuff + + + +;; Look for `lookfor' in `enclosing', return chain of syntaxes from +;; the innermost out of only syntaxes with the given src, returns #f +;; if it can't find it. +(define (enclosing-syntaxes-with-source enclosing lookfor src) + (let loop ([r '()] [stx enclosing]) + ;(printf "stx is ~a\n" (syntax->datum stx)) + ;(printf "source is ~a\n" (syntax-source stx)) + (let* ([r* (if (and (syntax? stx) (eq? src (syntax-source stx))) + (cons stx r) + r)]) + (if (eq? stx lookfor) + r* + (let ([stx (if (syntax? stx) (syntax-e stx) stx)]) + (and (pair? stx) + (or (loop r* (car stx)) (loop r* (cdr stx))))))))) + + + + +;; Look for (the outermost) syntax in `orig' that has the same +;; location as `lookfor' which is coming from the expanded `orig', +;; given in `expanded'. +(define (recover-source-syntax orig expanded) + (define src (syntax-source orig)) + + ;; this maps source locations that are from orig to their syntax + (define syntax-locs (make-hash)) + + ;; build `syntax-locs` + (let loop ([stx orig]) + (when (syntax? stx) (hash-set! syntax-locs (syntax-loc stx) stx)) + (let ([stx (if (syntax? stx) (syntax-e stx) stx)]) + (when (pair? stx) (loop (car stx)) (loop (cdr stx))))) + + ;; this maps syntax from expanded to the original + (define parent-table (make-hasheq)) + + ;; if `expanded` is mapped to something, then we'll start with it + (define initial-target + (hash-ref syntax-locs (syntax-loc expanded) #f)) + + ;; this searches for lookfor in orig, building up the table as we go + (define (add-to-table lookfor) + (let loop ([stx expanded] [target initial-target]) + (cond + [(syntax? stx) + (define new-target + ;; check if `stx` has the same srcloc as something in orig + ;; in which case it's a good target to use + ;; otherwise keep using the old target + (hash-ref syntax-locs (syntax-loc stx) target)) + ;; map `stx` to the best enclosing syntax we have, if it's not already there + (hash-ref! parent-table stx new-target) + (cond + ;; if we got what we came for, stop + [(eq? stx lookfor) new-target] + + ;; take apart stx and loop on the components + [else + (define stxe (syntax-e stx)) + (and (pair? stxe) + (or (loop (car stxe) stx) (loop (cdr stxe) stx)))])] + [else #f]))) + + (lambda (lookfor) + (or + ;; we just might get a lookfor that is already in the original + (and (eq? src (syntax-source lookfor)) + (hash-ref syntax-locs (syntax-loc lookfor) #f)) + (hash-ref parent-table lookfor (λ () + (add-to-table lookfor) + (hash-ref parent-table lookfor #f)))))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/info.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/info.rkt index 5dbe4aab..524f6c0f 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/info.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/info.rkt @@ -8,6 +8,7 @@ "pconvert-lib" "unstable-contract-lib" "unstable-list-lib" + "source-syntax" "compatibility-lib" ;; to assign types "string-constants-lib")) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt index 5b5eca9c..0a37babb 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/utils/tc-utils.rkt @@ -6,7 +6,7 @@ don't depend on any other portion of the system |# (provide (all-defined-out) (all-from-out "disappeared-use.rkt")) -(require "syntax-traversal.rkt" "disappeared-use.rkt" racket/promise +(require syntax/source-syntax "disappeared-use.rkt" racket/promise syntax/parse (for-syntax racket/base syntax/parse) racket/match) ;; a parameter representing the original location of the syntax being @@ -58,15 +58,18 @@ don't depend on any other portion of the system (locate-stx e)) e)))) -(define (locate-stx stx) - (define omodule (orig-module-stx)) - (define emodule (expanded-module-stx)) - ;(printf "orig: ~a\n" (syntax-object->datum omodule)) - ;(printf "exp: ~a\n" (syntax-object->datum emodule)) - ;(printf "stx (locate): ~a\n" (syntax-object->datum stx)) - (if (and (not (print-syntax?)) omodule emodule stx) - (or (look-for-in-orig omodule emodule stx) stx) - stx)) +(define locate-stx + ;; this hash handles using `locate-stx` even when orig/expand change + (let ([recover-table (make-hash)]) + (lambda (stx) + (define omodule (orig-module-stx)) + (define emodule (expanded-module-stx)) + (cond [(and (not (print-syntax?)) omodule emodule stx) + (define recover + (hash-ref! recover-table (cons omodule emodule) + (lambda () (recover-source-syntax omodule emodule)))) + (or (recover stx) stx)] + [else stx])))) (define (raise-typecheck-error msg stxs) (if (null? (cdr stxs)) @@ -93,7 +96,7 @@ don't depend on any other portion of the system [l (let ([stxs (for/list ([e (in-list l)]) - (with-handlers ([exn:fail:syntax? + (with-handlers ([exn:fail:syntax? (λ (e) ((error-display-handler) (exn-message e) e))]) (raise-typecheck-error (err-msg e) (err-stx e))) (err-stx e))])