#lang racket/base (require racket/class racket-sprintf racket/string racket-webview xml "../misc/utils.rkt") (provide playlist-gui%) (define (track-length->string length-seconds) (let* ((whole-seconds (inexact->exact (round length-seconds))) (hours (quotient whole-seconds 3600)) (minutes (quotient (remainder whole-seconds 3600) 60)) (seconds (remainder (remainder whole-seconds 3600) 60))) (sprintf "%02d:%02d:%02d" hours minutes seconds))) (define (entry-tooltip entry) (let* ((track (send entry get-track)) (uri (and track (send (send track get-resource) get-uri)))) (string-join (filter (lambda (value) (and (string? value) (not (string=? value "")))) (list (send entry get-title) (send entry get-artist) (send entry get-album) uri (and (eq? (send entry get-cache-status) 'failed) (send entry get-cache-error)))) "\n"))) (define (track-row playlist track-idx current-track-nr) (let* ((entry (send playlist entry track-idx)) (track-id (send playlist track-id track-idx)) (row-class (cond ((not (send entry is-valid?)) "track invalid") ((not (send entry is-available?)) (format "track unavailable ~a" (send entry get-cache-status))) ((equal? track-idx current-track-nr) "track current") (else "track")))) (list 'tr (list (list 'id (format "~a" track-id)) (list 'class row-class) (list 'title (entry-tooltip entry)) (list 'draggable "true")) (list 'td '((class "number")) (format "~a." (send entry get-number))) (list 'td '((class "title")) (send entry get-title)) (list 'td '((class "album")) (send entry get-album)) (list 'td '((class "length")) (track-length->string (send entry get-length)))))) (define (playlist->html playlist current-track-nr) (xexpr->string (append (list 'table '((class "tracks"))) (for/list ((track-idx (in-range (send playlist length)))) (track-row playlist track-idx current-track-nr)) (list (list 'tr '((class "unresponsive"))))))) (define playlist-gui% (class object% (init-field window element play-track-callback playlist-changed-callback) (check/c* playlist-gui% (window object?) (element object?) (play-track-callback procedure?) (playlist-changed-callback procedure?)) (define dragged-from-idx #f) (define/private (row-index playlist element) (send playlist index (send element attr/symbol 'id))) (define/private (bind-row-events! playlist) (send window bind! "table.tracks tr.track" '(click contextmenu) (lambda (row event data) (case event ((click) (let ((track-idx (row-index playlist row))) (when (send (send playlist entry track-idx) is-available?) (play-track-callback track-idx)))) ((contextmenu) (let* ((track-id (send row id)) (menu (wv-menu 'track-menu (wv-menu-item 'm-drop-track "Drop track" #:callback (lambda () (send playlist drop-id track-id) (playlist-changed-callback))))) (client-x (hash-ref data 'clientX 60)) (client-y (hash-ref data 'clientY 60))) (send window popup-menu! menu client-x client-y)))))) (send window bind! "table.tracks tr.track" 'dragstart (lambda (row event data) (set! dragged-from-idx (row-index playlist row))) #t) (send window bind! "table.tracks tr.track" '(dragover drop) (lambda (row event data) (when (eq? event 'drop) (let ((drop-at-idx (row-index playlist row))) (when (and (integer? dragged-from-idx) (integer? drop-at-idx) (not (= dragged-from-idx drop-at-idx))) (send playlist move-track dragged-from-idx drop-at-idx) (set! dragged-from-idx #f) (playlist-changed-callback))))))) (define/public (update! playlist current-track-nr) (let ((html (playlist->html playlist current-track-nr))) (send element set-innerHTML! html) (bind-row-events! playlist) (void))) (super-new))) (module+ test (require rackunit) (define test-entry% (class object% (define/public (is-valid?) #t) (define/public (get-number) 3) (define/public (get-title) "Title") (define/public (get-artist) "Artist") (define/public (get-album) "Album") (define/public (get-length) 65) (define/public (get-track) #f) (define/public (get-cache-status) 'available) (define/public (get-cache-error) #f) (define/public (is-available?) #t) (super-new))) (define test-playlist% (class object% (define/public (length) 1) (define/public (entry idx) (new test-entry%)) (define/public (track-id idx) 'track-1) (super-new))) (define html (playlist->html (new test-playlist%) 0)) (check-true (string-contains? html "track current")) (check-true (string-contains? html "draggable")) (check-true (string-contains? html "00:01:05")) (check-equal? (track-length->string 1365.797) "00:22:46"))