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
|
#lang racket/base
(require (for-syntax racket/base)
syntax/stx
syntax/parse/define
racket/format
(only-in racket/path
filename-extension
some-system-path->string))
(provide fresh-line
zero-column!
display-commented
string->namespace-syntax
syntax-or-sexpr->syntax
syntax-or-sexpr->sexpr
nat/c
pos/c
inc!
memq?
in-syntax
log-racket-mode-debug
log-racket-mode-info
log-racket-mode-warning
log-racket-mode-error
log-racket-mode-fatal
time-apply/log
with-time/log
define-polyfill
path-has-extension?
path-replace-extension
some-system-path->string)
;; Issue a newline unless already in column zero. Assumes
;; port-count-lines! already applied to current-output-port.
(define (fresh-line)
(flush-output)
(define-values [_line col _pos] (port-next-location (current-output-port)))
(unless (eq? col 0) (newline)))
(define (zero-column!)
(define-values [line col pos] (port-next-location (current-output-port)))
(set-port-next-location! (current-output-port) line 0 (- pos col)))
(define (display-commented str)
(fresh-line)
(printf "; ~a\n"
(regexp-replace* "\n" str "\n; ")))
(define (string->namespace-syntax str)
(namespace-syntax-introduce
(read-syntax #f (open-input-string str))))
(define (syntax-or-sexpr->syntax v)
(if (syntax? v)
v
(namespace-syntax-introduce (datum->syntax #f v))))
(define (syntax-or-sexpr->sexpr v)
(if (syntax? v)
(syntax-e v)
v))
(define nat/c exact-nonnegative-integer?)
(define pos/c exact-positive-integer?)
(define-simple-macro (inc! v:id)
(set! v (add1 v)))
(define (memq? x xs)
(and (memq x xs) #t))
;;; in-syntax: Not defined until Racket 6.3
(define-sequence-syntax in-syntax
(λ () #'in-syntax/proc)
(λ (stx)
(syntax-case stx ()
[[(id) (_ arg)]
#'[(id) (in-list (in-syntax/proc arg))]])))
(define (in-syntax/proc stx)
(or (stx->list stx)
(raise-type-error 'in-syntax "stx-list" stx)))
;;; logger / timing
(define-logger racket-mode)
(define (time-apply/log what proc args)
(define-values (vs cpu real gc) (time-apply proc args))
(define (fmt n) (~v #:align 'right #:min-width 4 n))
(log-racket-mode-debug "~a cpu | ~a real | ~a gc <= ~a"
(fmt cpu) (fmt real) (fmt gc) what)
(apply values vs))
(define-simple-macro (with-time/log what e ...+)
(time-apply/log what (λ () e ...) '()))
;;; Path extension for Racket versions < 6.6
(define-simple-macro (define-polyfill (id:id arg:expr ...)
#:module mod:id
body:expr ...+)
(define id
(with-handlers ([exn:fail? (λ (_exn)
(λ (arg ...) body ...))])
(dynamic-require 'mod 'id))))
(define-polyfill (path-has-extension? path ext)
#:module racket/path
(let ([ext (if (string? ext) (string->bytes/utf-8 ext) ext)])
(equal? (filename-extension path) ext)))
(define-polyfill (path-replace-extension path ext)
#:module racket/path
(path-replace-suffix path ext))
(module+ test
(require rackunit)
(check-true (path-has-extension? "/path/to/foo.EXT" "EXT"))
(check-true (path-has-extension? (build-path "/path/to/foo.EXT") "EXT"))
(check-equal? (path-replace-extension "/path/to/foo.OLD" ".NEW")
(build-path "/path/to/foo.NEW"))
(check-equal? (path-replace-extension (build-path "/path/to/foo.OLD") ".NEW")
(build-path "/path/to/foo.NEW")))
|
