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

Avoid having hard-wired paths in contract error messages.

Browse Source 
These will use "<collects>/..." 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
This commit is contained in:
Eli Barzilay 2007-09-10 02:26:59 +00:00
parent aaf50c4fa1
commit 449d9097c7
1 changed files with 16 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
collects/mzlib/private/contract-helpers.ss
View File

@ -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 #"<collects>/" (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)]