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

avoid resolving module-path-index (current-directory may not be set right)

Browse Source
This commit is contained in:
Ryan Culpepper 2011-12-12 17:39:18 -07:00
parent 1ec2f9ca82
commit 32c5e3c9d2
1 changed files with 15 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
collects/unstable/wrapc.rkt
View File

@ -4,6 +4,7 @@
racket/contract/base
syntax/location)
syntax/srcloc
syntax/modcollapse
racket/syntax)
(provide/contract
@ -71,17 +72,20 @@
(if (syntax? ctx)
(get-source-expr (extract-source ctx) #f)
(get-source-expr 'unknown #f))]
[else
(let ([source-string
(cond [(string? source) source]
[(syntax? source) (source-location->string source)]
[(module-path-index? source)
;; FIXME: share with syntax/location ??
(let ([name (resolved-module-path-name
(module-path-index-resolve source))])
(cond [(path? name) (format "(file ~s)" (path->string name))]
[(symbol? name) (format "(quote ~s)" name)]))])])
#`(quote #,source-string))]))
[(string? source) #`(quote #,source)]
[(syntax? source) #`(quote #,(source-location->string source))]
[(module-path-index? source)
;; FIXME: extend collapse-module-path-index to accept #f, return rel mod path
(let* ([here (current-load-relative-directory)]
[collapsed
(collapse-module-path-index source (or here (build-path 'same)))])
(cond [(and (path? collapsed) here)
#`(quote #,(path->string collapsed))]
[(path? collapsed)
(let-values ([(rel base) (module-path-index-split source)])
#`(quote #,rel))]
[else
#`(quote #,(format "~s" collapsed))]))]))
(define (extract-source stx)
(let ([id (syntax-case stx ()