~pvsr/mpd-status

68e01332c717696d830d6983b8194a6f294b39dc — Peter Rice 1 year, 2 months ago a27ac16
format with brittany
6 files changed, 156 insertions(+), 116 deletions(-)

M I3blocks/Block.hs
M I3blocks/Click.hs
M I3blocks/Config.hs
M I3blocks/Main.hs
M Operation.hs
M Shuffle.hs
M I3blocks/Block.hs => I3blocks/Block.hs +36 -31
@@ 1,13 1,20 @@
{-# LANGUAGE OverloadedStrings #-}

module I3blocks.Block (block) where
module I3blocks.Block
  ( block
  )
where

import qualified Data.Map as M (lookup)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import qualified Data.Map                      as M
                                                ( lookup )
import           Data.Maybe                     ( fromMaybe )
import           Data.Semigroup                 ( (<>) )

import qualified Data.Text as T (Text, pack)
import Network.MPD
import qualified Data.Text                     as T
                                                ( Text
                                                , pack
                                                )
import           Network.MPD

-- TODO color
-- colors set in i3blocks config are available in environment


@@ 17,31 24,29 @@ block = maybe "mpd stopped" . mappend <$> extractSong <*> statusInfo

statusInfo :: MPD (Maybe T.Text)
statusInfo = fmap statusInfo' status
  where statusInfo' Status { stState = state, stVolume = vol } =
          case (state, vol) of
            (Stopped, _) -> Nothing
            (Playing, Nothing) -> Just ""
            (Playing, Just 100) -> Just ""
            (Playing, Just v) -> Just $ " [" <> volIndicator v <> "%]"
            (Paused, Nothing) -> Just " [paused]"
            (Paused, Just 100) -> Just " [paused]"
            (Paused, Just v) -> Just $ " [paused | " <> volIndicator v <> "%]"
          where
            volIndicator v = symbol v <> " " <> T.pack (show v)
            symbol v
              | v > 49 = "\xf028"
              | v > 0 = "\xf027"
              | otherwise = "\xf026"
 where
  statusInfo' Status { stState = state, stVolume = vol } = case (state, vol) of
    (Stopped, _       ) -> Nothing
    (Playing, Nothing ) -> Just ""
    (Playing, Just 100) -> Just ""
    (Playing, Just v  ) -> Just $ " [" <> volIndicator v <> "%]"
    (Paused , Nothing ) -> Just " [paused]"
    (Paused , Just 100) -> Just " [paused]"
    (Paused , Just v  ) -> Just $ " [paused | " <> volIndicator v <> "%]"
  volIndicator v = symbol v <> " " <> T.pack (show v)
  symbol v | v > 49    = "\xf028"
           | v > 0     = "\xf027"
           | otherwise = "\xf026"

extractSong :: MPD T.Text
extractSong = fmap extractSong' currentSong
  where extractSong' song =
          fromMaybe "no song" $ do
            tags <- sgTags <$> song
            path <- fmap (toText . sgFilePath) song
            return . fromMaybe path $ do
              title <- extract =<< M.lookup Title tags
              artist <- extract =<< M.lookup Artist tags
              return $ artist <> " - " <> title
        extract [] = Nothing
        extract (b:_) = Just $ toText b
 where
  extractSong' song = fromMaybe "no song" $ do
    tags <- sgTags <$> song
    path <- fmap (toText . sgFilePath) song
    return . fromMaybe path $ do
      title  <- extract =<< M.lookup Title tags
      artist <- extract =<< M.lookup Artist tags
      return $ artist <> " - " <> title
  extract []      = Nothing
  extract (b : _) = Just $ toText b

M I3blocks/Click.hs => I3blocks/Click.hs +15 -12
@@ 1,9 1,12 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

module I3blocks.Click (Button(..)) where
module I3blocks.Click
  ( Button(..)
  )
where

import Data.Aeson
import           Data.Aeson

data Button = LeftClick
            | MiddleClick


@@ 18,13 21,13 @@ data Button = LeftClick

instance FromJSON Button where
  parseJSON = withScientific "Button" $ \case
      1 -> pure LeftClick
      2 -> pure MiddleClick
      3 -> pure RightClick
      4 -> pure ScrollUp
      5 -> pure ScrollDown
      6 -> pure ScrollLeft
      7 -> pure ScrollRight
      8 -> pure Back
      9 -> pure Forward
      _ -> fail "expected an integer in [1, 9]"
    1 -> pure LeftClick
    2 -> pure MiddleClick
    3 -> pure RightClick
    4 -> pure ScrollUp
    5 -> pure ScrollDown
    6 -> pure ScrollLeft
    7 -> pure ScrollRight
    8 -> pure Back
    9 -> pure Forward
    _ -> fail "expected an integer in [1, 9]"

M I3blocks/Config.hs => I3blocks/Config.hs +14 -9
@@ 1,26 1,31 @@
{-# LANGUAGE OverloadedStrings #-}

module I3blocks.Config(buttonToOp, volStep) where
module I3blocks.Config
  ( buttonToOp
  , volStep
  )
where

import Operation
import I3blocks.Click
import           Operation
import           I3blocks.Click

import Network.MPD (PlaylistName(..))
import           Network.MPD                    ( PlaylistName(..) )

volStep :: Int
volStep = 5

buttonToOp :: Button -> Maybe Operation
buttonToOp LeftClick = Just Toggle
buttonToOp LeftClick  = Just Toggle
--buttonToOp MiddleClick = Just AllRandom
buttonToOp RightClick = Just Stop
buttonToOp ScrollUp = Just $ VolumeUp volStep
buttonToOp ScrollUp   = Just $ VolumeUp volStep
buttonToOp ScrollDown = Just $ VolumeDown volStep
buttonToOp Back = Just Previous
buttonToOp Back       = Just Previous
--buttonToOp Forward = Just Next

-- TODO maybe there should be some notion of album mode vs single mode
buttonToOp MiddleClick = Just $ AlbumShuffle (Just $ PlaylistName "album-shuffle")
buttonToOp MiddleClick =
  Just $ AlbumShuffle (Just $ PlaylistName "album-shuffle")
buttonToOp Forward = Just NextAlbum

buttonToOp _ = Nothing
buttonToOp _       = Nothing

M I3blocks/Main.hs => I3blocks/Main.hs +22 -12
@@ 1,16 1,26 @@
import Control.Concurrent (forkIO, killThread)
import Control.Monad (forever, (>=>))
import System.IO (stdout, hSetBuffering, BufferMode(LineBuffering))
import           Control.Concurrent             ( forkIO
                                                , killThread
                                                )
import           Control.Monad                  ( forever
                                                , (>=>)
                                                )
import           System.IO                      ( stdout
                                                , hSetBuffering
                                                , BufferMode(LineBuffering)
                                                )

import Data.Aeson (decodeStrict)
import qualified Data.ByteString as B (getLine)
import qualified Data.Text as T (Text)
import qualified Data.Text.IO as T (putStrLn)
import Network.MPD
import           Data.Aeson                     ( decodeStrict )
import qualified Data.ByteString               as B
                                                ( getLine )
import qualified Data.Text                     as T
                                                ( Text )
import qualified Data.Text.IO                  as T
                                                ( putStrLn )
import           Network.MPD

import Operation
import I3blocks.Block
import I3blocks.Config
import           Operation
import           I3blocks.Block
import           I3blocks.Config

main :: IO ()
main = do


@@ 18,7 28,7 @@ main = do
  forever $ do
    run block
    tid <- forkIO . forever . run $ idle [PlayerS] >> block
    b <- decodeStrict <$> B.getLine
    b   <- decodeStrict <$> B.getLine
    killThread tid
    withMPD . maybe (return ()) op $ b >>= buttonToOp


M Operation.hs => Operation.hs +55 -38
@@ 1,16 1,25 @@
{-# LANGUAGE OverloadedStrings #-}

module Operation(Operation(..), op) where
module Operation
  ( Operation(..)
  , op
  )
where

import qualified Data.Map as M
import Data.Maybe (isJust, mapMaybe)
import qualified Data.List as L (find, nub)
import qualified Data.Map                      as M
import           Data.Maybe                     ( isJust
                                                , mapMaybe
                                                )
import qualified Data.List                     as L
                                                ( find
                                                , nub
                                                )

import Control.Monad.Trans (liftIO)
import Network.MPD
import Network.MPD.Commands.Extensions
import           Control.Monad.Trans            ( liftIO )
import           Network.MPD
import           Network.MPD.Commands.Extensions

import Shuffle
import           Shuffle

data Operation = Toggle
               | Stop


@@ 25,48 34,56 @@ data Operation = Toggle
               | AlbumShuffle (Maybe PlaylistName)

op :: Operation -> MPD ()
op Toggle = toggle
op Toggle    = toggle
op AllRandom = clear >> add "" >> random True >> play Nothing
op Stop = stop
op (VolumeUp volStep) = status >>= maybe (return ()) (setVolume . inc volStep) . stVolume
op (VolumeDown volStep) = status >>= maybe (return ()) (setVolume . dec volStep) . stVolume
op Stop      = stop
op (VolumeUp volStep) =
  status >>= maybe (return ()) (setVolume . inc volStep) . stVolume
op (VolumeDown volStep) =
  status >>= maybe (return ()) (setVolume . dec volStep) . stVolume
-- TODO it would be nice to be able to toggle mute. is that info stored?
op Mute = setVolume 0
op Previous = previous
op Next = next
op PreviousAlbum = previous
op NextAlbum = nextAlbum
op Mute                     = setVolume 0
op Previous                 = previous
op Next                     = next
op PreviousAlbum            = previous
op NextAlbum                = nextAlbum
-- TODO handle bad playlist argument
op (AlbumShuffle (Just pl)) = listPlaylistInfo pl >>= albumShuffle
op (AlbumShuffle Nothing) = (filterSongs <$> listAllInfo "") >>= albumShuffle
  where filterSongs :: [LsResult] -> [Song]
        filterSongs ls = [song | (LsSong song) <- ls]
op (AlbumShuffle Nothing  ) = (filterSongs <$> listAllInfo "") >>= albumShuffle
 where
  filterSongs :: [LsResult] -> [Song]
  filterSongs ls = [ song | (LsSong song) <- ls ]

-- really pining for the elegance of `mpc playlist -f %album% album-shuffle | uniq | sort -R` here
albumShuffle :: [Song] -> MPD ()
albumShuffle songs = clear >> random False >> (liftIO . Shuffle.shuffle . queries $ uniqAlbums songs) >>= mapM_ findAdd >> play Nothing
  where uniqAlbums = L.nub . concat . mapMaybe (M.lookup Album . sgTags)
        queries = map (Album =?)
albumShuffle songs =
  clear
    >>  random False
    >>  (liftIO . Shuffle.shuffle . queries $ uniqAlbums songs)
    >>= mapM_ findAdd
    >>  play Nothing
 where
  uniqAlbums = L.nub . concat . mapMaybe (M.lookup Album . sgTags)
  queries    = map (Album =?)

nextAlbum :: MPD ()
nextAlbum = let album = M.lookup Album . sgTags
                whenJust m f = maybe (return ()) f m
             in do
  st <- status
  let untilEnd pos = playlistInfoRange $ Just (pos, fromInteger $ stPlaylistLength st)
  maybePl <- maybe (return Nothing) (fmap Just . untilEnd) $ stSongPos st
  whenJust maybePl $ \pl -> do
    -- since position was not Nothing, pl is guaranteed nonempty
    let currentAlbum = album $ head pl
    let index = L.find (\s -> album s /= currentAlbum) pl >>= sgIndex
    if isJust index then play index else next
nextAlbum =
  let album = M.lookup Album . sgTags
      whenJust m f = maybe (return ()) f m
  in  do
        st <- status
        let untilEnd pos =
              playlistInfoRange $ Just (pos, fromInteger $ stPlaylistLength st)
        maybePl <- maybe (return Nothing) (fmap Just . untilEnd) $ stSongPos st
        whenJust maybePl $ \pl -> do
          -- since position was not Nothing, pl is guaranteed nonempty
          let currentAlbum = album $ head pl
          let index = L.find (\s -> album s /= currentAlbum) pl >>= sgIndex
          if isJust index then play index else next

inc :: Int -> Int -> Int
inc step vol = min 100 $ (vol `div` step + 1) * step

dec :: Int -> Int -> Int
dec step vol = max 0 (baseN `div` step) * step
  where
    baseN = if vol `mod` step == 0
               then vol - 1
               else vol
  where baseN = if vol `mod` step == 0 then vol - 1 else vol

M Shuffle.hs => Shuffle.hs +14 -14
@@ 1,21 1,21 @@
module Shuffle where

import System.Random
import Data.Array.IO
import Control.Monad
import           System.Random
import           Data.Array.IO
import           Control.Monad

-- this is so stupid
-- copied from https://wiki.haskell.org/Random_shuffle
shuffle :: [a] -> IO [a]
shuffle xs = do
        ar <- newArray n xs
        forM [1..n] $ \i -> do
            j <- randomRIO (i,n)
            vi <- readArray ar i
            vj <- readArray ar j
            writeArray ar j vi
            return vj
  where
    n = length xs
    newArray :: Int -> [a] -> IO (IOArray Int a)
    newArray n xs =  newListArray (1, n) xs
  ar <- newArray n xs
  forM [1 .. n] $ \i -> do
    j  <- randomRIO (i, n)
    vi <- readArray ar i
    vj <- readArray ar j
    writeArray ar j vi
    return vj
 where
  n = length xs
  newArray :: Int -> [a] -> IO (IOArray Int a)
  newArray n xs = newListArray (1, n) xs