1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
|
#lang at-exp racket/base
(require (for-syntax racket/base
syntax/parse)
racket/contract/base
racket/contract/region
racket/format
racket/match
racket/string
syntax/location
"util.rkt")
(provide relative-module-path?
(struct-out mod)
->mod/existing
maybe-mod->dir/file/rmp
maybe-mod->prompt-string
maybe-warn-about-submodules)
(module+ test
(require rackunit))
;; The subset of module-path? with a relative filename
(define (relative-module-path? v)
(define (rel-path? v) ;real predicate taking any/c, unlike relative-path?
(and (path-string? v) (relative-path? v)))
(and (module-path? v)
(match v
[(? rel-path?) #t]
[(list 'submod (? rel-path?) (? symbol?) ..1) #t]
[_ #f])))
(module+ test
(check-true (relative-module-path? "f.rkt"))
(check-true (relative-module-path? '(submod "f.rkt" a b)))
(check-false (relative-module-path? "/path/to/f.rkt"))
(check-false (relative-module-path? '(submod "/path/to/f.rkt" a b)))
(check-false (relative-module-path? 'racket/base))
(check-false (relative-module-path? '(submod 'racket/base a b))))
(define-struct/contract mod
([dir absolute-path?] ;#<path:/path/to/>
[file relative-path?] ;#<path:foo.rkt>
[rmp relative-module-path?]) ;#<path:f.rkt> or '(submod <path:f.rkt> bar)
#:transparent)
(define/contract (->mod/simple v)
(-> any/c (or/c #f mod?))
(match v
[(? symbol? s) (->mod/simple (~a s))] ;treat 'file.rkt as "file.rkt"
[(or (? path? ap) (? path-string? ap))
(let*-values ([(dir file _) (split-path (simplify-path ap))]
[(dir) (match dir ['relative (current-directory)][dir dir])])
(mod dir file file))]
[_ #f]))
(define/contract (->mod v)
(-> any/c (or/c #f mod?))
(define-match-expander mm
(syntax-parser
[(_ dir:id file:id rmp:id)
#'(app ->mod/simple (mod dir file rmp))]))
(match v
[(list 'submod
(mm d f _) (? symbol? ss) ..1) (mod d f (list* 'submod f ss))]
[(list (mm d f _) (? symbol? ss) ..1) (mod d f (list* 'submod f ss))]
[(list (mm d f mp)) (mod d f mp)]
[(mm d f mp) (mod d f mp)]
[_ #f]))
(module+ test
(define-syntax-rule (= x y) (check-equal? x y))
(define f.rkt (string->path "f.rkt"))
;; rel path
(let ([dir (current-directory)])
(= (->mod "f.rkt") (mod dir f.rkt f.rkt))
(= (->mod 'f.rkt) (mod dir f.rkt f.rkt))
(= (->mod '(submod "f.rkt" a b)) (mod dir f.rkt `(submod ,f.rkt a b)))
(= (->mod '(submod f.rkt a b)) (mod dir f.rkt `(submod ,f.rkt a b)))
(= (->mod '("f.rkt" a b)) (mod dir f.rkt `(submod ,f.rkt a b)))
(= (->mod '(f.rkt a b)) (mod dir f.rkt `(submod ,f.rkt a b)))
(= (->mod '("f.rkt")) (mod dir f.rkt f.rkt))
(= (->mod '(f.rkt)) (mod dir f.rkt f.rkt)))
;; abs path
(let* ([top (case (system-type) [(windows) "\\"] [(unix macosx) "/"])]
[dir (path->directory-path (build-path top "p" "t"))])
(= (->mod (build-path "/" "p" "t" "f.rkt")) (mod dir f.rkt f.rkt))
(= (->mod '/p/t/f.rkt) (mod dir f.rkt f.rkt))
(= (->mod '(submod "/p/t/f.rkt" a b)) (mod dir f.rkt `(submod ,f.rkt a b)))
(= (->mod '(submod /p/t/f.rkt a b)) (mod dir f.rkt `(submod ,f.rkt a b)))
(= (->mod '("/p/t/f.rkt" a b)) (mod dir f.rkt `(submod ,f.rkt a b)))
(= (->mod '(/p/t/f.rkt a b)) (mod dir f.rkt `(submod ,f.rkt a b)))
(= (->mod '("/p/t/f.rkt")) (mod dir f.rkt f.rkt))
(= (->mod '(/p/t/f.rkt)) (mod dir f.rkt f.rkt)))
;; nonsense input => #f
(= (->mod 42) #f)
(= (->mod '(42 'bar)) #f)
(= (->mod '(submod 42 'bar)) #f)
(= (->mod '(submod (submod "f.rkt" foo) bar)) #f))
(define/contract (->mod/existing v)
(-> any/c (or/c #f mod?))
(match (->mod v)
[(and v (mod dir file mp))
(define path (build-path dir file))
(cond [(file-exists? path) v]
[else (display-commented (format "~a does not exist" path))
#f])]
[_ #f]))
(define/contract (maybe-mod->dir/file/rmp maybe-mod)
(-> (or/c #f mod?) (values absolute-path?
(or/c #f relative-path?)
(or/c #f relative-module-path?)))
(match maybe-mod
[(mod d f mp) (values d f mp)]
[#f (values (current-directory) #f #f)]))
(define/contract (maybe-mod->prompt-string m)
(-> (or/c #f mod?) string?)
(match m
[(mod _ _ (? path? file)) (~a file)]
[(mod _ _ (list* 'submod xs)) (string-join (map ~a xs) "/")]
[#f ""]))
;; Check whether Racket is new enough (newer than 6.2.1) that
;; module->namespace works with module+ and (module* _ #f __)
;; forms when errortrace is enabled.
(module+ check
(define x 42))
(define (can-enter-module+-namespace?)
(define mp (quote-module-path check))
(dynamic-require mp #f)
(with-handlers ([exn:fail? (λ _ #f)])
(eval 'x (module->namespace mp))
#t))
(define warned? #f)
(define/contract (maybe-warn-about-submodules mp context)
(-> (or/c #f module-path?) symbol? any)
(unless (or warned?
(not (pair? mp)) ;not submodule
(memq context '(low medium))
(can-enter-module+-namespace?))
(set! warned? #t)
(display-commented
@~a{Note: @~v[@mp] will be evaluated.
However your Racket version is old. You will be unable to
use the REPL to examine definitions in the body of a module+
or (module* _ #f ___) form when errortrace is enabled. Either
upgrade Racket, or, set the Emacs variable racket-error-context
to 'low or 'medium.})))
|
