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