rktplayer/misc/utils.rkt

#lang racket/base

(require racket/gui
         racket/contract
         xml
         xml/xexpr
         simple-log
         )

(provide ww-connect
         make-delayed-reactor
         mktable
         simple-row-formatter
         while
         open-file-manager
         dbg-rktplayer
         err-rktplayer
         info-rktplayer
         warn-rktplayer
         fatal-rktplayer
         sync-log-rktplayer
         (all-from-out simple-log)
         list-drop!
         path-equal?
         make-select-list
         new-id
         check/c
         check/c*
         (all-from-out racket/contract)
         )


(sl-def-log rktplayer)

(define-syntax check/c
  (syntax-rules ()
    ((_ for-cl for-func name contract-expr)
     (unless (contract-first-order-passes? contract-expr name)
       (raise-argument-error
        (string->symbol (format "~a:~a" 'for-cl 'for-func))
        (format "~s" 'contract-expr)
        name)))
    ((_ for-cl name contract-expr)
     (unless (contract-first-order-passes? contract-expr name)
       (raise-argument-error
        'for-cl
        (format "~s" 'contract-expr)
        name)))
    ((_ name contract-expr)
     (unless (contract-first-order-passes? contract-expr name)
       (error
        (format "~a: expected ~a, got ~a"
                'name
                'contract-expr
                name))))))

(define-syntax check/c*-internal
  (syntax-rules ()
    ((_ for-cl (for-func name type?))
     (check/c for-cl for-func name type?))
    ((_ for-cl (name type?))
     (check/c for-cl name type?))))

(define-syntax check/c*-internal-func
  (syntax-rules ()
    ((_ for-cl for-func (name type?))
     (check/c for-cl for-func name type?))))

(define-syntax check/c*
  (syntax-rules ()
    ((_ (for-cl for-func) check ...)
     (begin
       (check/c*-internal-func for-cl for-func check)
       ...))
    ((_ for-cl check ...)
     (begin
       (check/c*-internal for-cl check)
       ...))))

 (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 (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)
      )
    )
  )

(define (make-select-list id items selected)
  (let ((slct (list 'select (list (list 'id (format "~a" id))))))
    (for-each
     (λ (item)
       (let ((value (car item))
             (label (cadr item)))
         (set! slct
               (append slct
                       (list
                        (if (equal? value selected)
                            (list 'option
                                  (list (list 'value (format "~a" value)) (list 'selected "selected"))
                                  label)
                            (list 'option
                                  (list (list 'value (format "~a" value)))
                                  label))))))
       )
     items)
    slct))


(define (new-id)
  (let* ((s (current-milliseconds))
         (r (random 1000000))
         (id (string->symbol (format "id-~a-~a" s r))))
    id))

(module+ test
  (require rackunit)

  (define (multiply a b c)
    (check/c* (my-class multiply)
              (a number?)
              (b number?)
              (c symbol?))
    (format "symbol ~a = ~a" c (* a b)))

  (check-equal? (multiply 2 3 'answer)
                "symbol answer = 6")

  (check-not-exn
   (lambda ()
     (define value 1)
     (check/c my-class value number?)))

  (check-exn
   exn:fail:contract?
   (lambda ()
     (multiply 2 "3" 'answer)))

  (check-exn
   #rx"my-class:multiply"
   (lambda ()
     (multiply 2 3 "answer")))

  (check-not-exn
   (lambda ()
     (define value "root")
     (check/c value (or/c path? string?))))

  (check-exn
   #rx"or/c"
   (lambda ()
     (define value 42)
     (check/c my-class value (or/c path? string?)))))