110 lines
3 KiB
Racket
110 lines
3 KiB
Racket
#lang racket/base
|
|
|
|
(require (for-syntax racket/base)
|
|
syntax/stx
|
|
syntax/parse/define
|
|
racket/format
|
|
(only-in racket/path
|
|
filename-extension))
|
|
|
|
(provide 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)
|
|
|
|
(define (display-commented str)
|
|
(eprintf "; ~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")))
|