From 449d9097c7feb2ffe20c70b891932c66978ccb06 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 10 Sep 2007 02:26:59 +0000 Subject: [PATCH] Avoid having hard-wired paths in contract error messages. These will use "/..." now. (A perhaps better solution is to do what "mzlib/etc.ss" does and insert code that expands to the file on the client machine.) svn: r7306 --- collects/mzlib/private/contract-helpers.ss | 22 ++++++++++++++++------ 1 file changed, 16 insertions(+), 6 deletions(-) diff --git a/collects/mzlib/private/contract-helpers.ss b/collects/mzlib/private/contract-helpers.ss index 3329a2bf6a..2e2d3a6bbe 100644 --- a/collects/mzlib/private/contract-helpers.ss +++ b/collects/mzlib/private/contract-helpers.ss @@ -7,6 +7,8 @@ add-name-prop all-but-last) + (require (lib "main-collects.ss" "setup")) + (define (add-name-prop name stx) (cond [(identifier? name) @@ -64,14 +66,22 @@ [(null? (cdr l)) null] [(pair? (cdr l)) (cons (car l) (all-but-last (cdr l)))] [else (list (car l))])) - + + ;; helper for build-src-loc-string + (define (source->name src) + (let* ([bs (cond [(bytes? src) src] + [(path? src) (path->bytes src)] + [(string? src) (string->bytes/locale src)] + [else #f])] + [r (and bs (path->main-collects-relative bs))]) + (and bs + (bytes->string/locale (if (and (pair? r) (eq? 'collects (car r))) + (bytes-append #"/" (cdr r)) + bs))))) + ;; build-src-loc-string : syntax -> (union #f string) (define (build-src-loc-string stx) - (let* ([source (syntax-source stx)] - [source (cond [(path? source) (path->string source)] - [(string? source) source] - [(bytes? source) (bytes->string/utf-8 source)] - [else #f])] + (let* ([source (source->name (syntax-source stx))] [line (syntax-line stx)] [col (syntax-column stx)] [pos (syntax-position stx)]