140 lines
3.9 KiB
Racket
140 lines
3.9 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/gui
|
|
xml
|
|
xml/xexpr
|
|
simple-log
|
|
)
|
|
|
|
(provide ww-connect
|
|
make-delayed-reactor
|
|
mktable
|
|
simple-row-formatter
|
|
while
|
|
open-file-manager
|
|
basedir
|
|
dbg-rktplayer
|
|
err-rktplayer
|
|
info-rktplayer
|
|
warn-rktplayer
|
|
fatal-rktplayer
|
|
(all-from-out simple-log)
|
|
list-drop!
|
|
path-equal?
|
|
)
|
|
|
|
|
|
(sl-def-log rktplayer)
|
|
|
|
(define-syntax while
|
|
(syntax-rules ()
|
|
((_ cond body ...)
|
|
(letrec ((while-f (lambda (last-result)
|
|
(if cond
|
|
(let ((last-result (begin
|
|
body
|
|
...)))
|
|
(while-f last-result))
|
|
last-result))))
|
|
(while-f #f))
|
|
)
|
|
))
|
|
|
|
(define-syntax ww-connect
|
|
(syntax-rules (this)
|
|
((_ id method)
|
|
(begin
|
|
(send this bind! id 'click
|
|
(λ (el evt data)
|
|
(send this method)))
|
|
(send this element id))
|
|
)
|
|
)
|
|
)
|
|
|
|
(define (list-drop! l idx)
|
|
(if (null? l)
|
|
l
|
|
(if (= idx 0)
|
|
(cdr l)
|
|
(cons (car l) (list-drop! (cdr l) (- idx 1))))))
|
|
|
|
(define (make-delayed-reactor seconds closure)
|
|
(let* ((last-val #f)
|
|
(last-time -1)
|
|
(interval-ms (* seconds 1000))
|
|
(timeout-check (λ ()
|
|
(let ((ms (current-milliseconds)))
|
|
(unless (= last-time -1)
|
|
(when (> ms (+ last-time interval-ms))
|
|
(set! last-time -1)
|
|
(closure last-val))))))
|
|
(timer (new timer% [notify-callback timeout-check] [interval 100]))
|
|
)
|
|
(λ (val)
|
|
(dbg-rktplayer "delayed reactor: ~a" val)
|
|
(set! last-val val)
|
|
(set! last-time (current-milliseconds))
|
|
)))
|
|
|
|
|
|
(define (simple-row-formatter row)
|
|
(map (λ (e) (list 'td (format "~a" e))) row))
|
|
|
|
(define (mktable l table-class row-formatter)
|
|
(xexpr->string
|
|
(append
|
|
(list 'table (list (list 'class (format "~a" table-class))))
|
|
(map (λ (row)
|
|
(let ((row-id (car row)))
|
|
(append (list 'tr (list (list 'id (format "~a" row-id))))
|
|
(row-formatter (cdr row)))))
|
|
l)
|
|
; Add one empty tr
|
|
(list (list 'tr (list (list 'class "unresponsive"))))
|
|
)
|
|
)
|
|
)
|
|
|
|
(define (open-file-manager path*)
|
|
(let* ((path (normal-case-path path*))
|
|
(folder (if (path? path) (path->string path) path))
|
|
(do-open (λ (prg arg)
|
|
(let ((exe (find-executable-path prg)))
|
|
(dbg-rktplayer "(process* ~a ~a)" exe arg)
|
|
(process* exe arg))))
|
|
)
|
|
(dbg-rktplayer "open-file-manager ~a" folder)
|
|
(case (system-type 'os)
|
|
[(windows) (do-open "explorer.exe" folder)]
|
|
[(macosx) (do-open "open" folder)]
|
|
[else (do-open "xdg-open" folder)]))
|
|
)
|
|
|
|
(define (basedir file)
|
|
(if (string? file)
|
|
(basedir (string->path file))
|
|
(if (or (eq? (file-or-directory-type file) 'file)
|
|
(eq? (file-or-directory-type file) 'link))
|
|
(call-with-values (λ () (split-path file))
|
|
(λ (dir file d) dir))
|
|
file)))
|
|
|
|
(define (path-equal? p1 p2)
|
|
(let ((p1* (build-path p1))
|
|
(p2* (build-path p2))
|
|
)
|
|
(let ((e1 (explode-path (normal-case-path p1)))
|
|
(e2 (explode-path (normal-case-path p2))))
|
|
(if (= (length e1) (length e2))
|
|
(letrec ((f (λ (l1 l2)
|
|
(if (null? l1)
|
|
#t
|
|
(if (string=? (format "~a" (car l1)) (format "~a" (car l2)))
|
|
(f (cdr l1) (cdr l2))
|
|
#f)))))
|
|
(f e1 e2))
|
|
#f)
|
|
)
|
|
)
|
|
) |