1#lang racket/base
2(require mred
3         mzlib/class
4         racket/format)
5
6(provide define-accessor
7         define/provide-struct
8         adjust-keyword-default
9         seconds->hhmmss)
10
11(define-syntax define-accessor
12  (syntax-rules ()
13    [(_ margin get-margin extra-arg ...)
14     (define-syntax margin
15       (syntax-id-rules ()
16         [(margin arg (... ...)) ((get-margin extra-arg ...) arg (... ...))]
17         [margin (get-margin extra-arg ...)]))]))
18
19(define-syntax define/provide-struct
20  (syntax-rules ()
21    [(_ id flds flags ...)
22     (begin
23       (define-struct id flds flags ...)
24       (provide (struct-out id)))]))
25
26
27(define (seconds->hhmmss s)
28  (define-values (hours left) (quotient/remainder s (* 60 60)))
29  (define-values (minutes seconds) (quotient/remainder left 60))
30  (string-append
31   (~r hours #:min-width 2 #:pad-string "0") ":"
32   (~r minutes #:min-width 2 #:pad-string "0") ":"
33   (~r seconds #:min-width 2 #:pad-string "0")))
34
35(define (adjust-keyword-default proc kw kw-val)
36  (define-values (req opt) (procedure-keywords proc))
37  (procedure-reduce-keyword-arity
38   (make-keyword-procedure
39    (lambda (kws kw-vals . args)
40      (if (memq kw kws)
41          (keyword-apply proc kws kw-vals args)
42          (keyword-apply-with-keyword proc kw kw-val kws kw-vals args))))
43   (procedure-arity proc)
44   req
45   opt))
46
47(define (keyword-apply-with-keyword proc kw kw-val kws kw-vals args)
48  (let loop ([kws kws] [kw-vals kw-vals] [rev-kws '()] [rev-kw-vals '()])
49    (cond
50      [(or (null? kws)
51           (keyword<? kw (car kws)))
52       (define new-kws (append (reverse rev-kws) (list kw) kws))
53       (define new-kw-vals (append (reverse rev-kw-vals) (list kw-val) kw-vals))
54       (keyword-apply proc new-kws new-kw-vals args)]
55      [else
56       (loop (cdr kws) (cdr kw-vals) (cons (car kws) rev-kws) (cons (car kw-vals) rev-kw-vals))])))
57