rktplayer/play/playlist-gui.rkt

#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"))