Turn the --monitor option to `Volume` into a new plugin `Alsa` instead

See #360.

6 files changed, 198 insertions, 137 deletions

diff --git a/readme.md b/readme.md
index b868091..3dc988a 100644
--- a/readme.md
+++ b/readme.md
@@ -1063,14 +1063,6 @@ more than one battery.
     - `--highd` _number_ High threshold for dB. Defaults to -5.0.
     - `--lowd` _number_ Low threshold for dB. Defaults to -30.0.
     - `--volume-icon-pattern` _string_ dynamic string for current volume in `volumeipat`.
-    - `--monitor[=/path/to/alsactl]`
-        - Use event-based refreshing via `alsactl monitor` instead of polling
-          (`RefreshRate` will be ignored).
-        - If no `/path/to/alsactl` is given, `alsactl` will be sought in your `PATH`
-          first, and failing that, at `/usr/sbin/alsactl` (this is its location on
-          Debian systems. `alsactl monitor` works as a non-root user despite living
-          in `/usr/sbin`.).
-        - `stdbuf` (from coreutils) must be (and most probably already is) in your `PATH`.
 - Variables that can be used with the `-t`/`--template` argument:
             `volume`, `volumebar`, `volumevbar`, `volumeipat`, `dB`, `status`
 - Note that `dB` might only return 0 on your system. This is known
@@ -1080,6 +1072,21 @@ more than one battery.
   system. In addition, to activate this plugin you must pass
   `--flags="with_alsa"` during compilation.
 
+### `Alsa Mixer Element Args`
+
+Like [Volume](#volume-mixer-element-args-refreshrate), but with the following differences:
+- Uses event-based refreshing via `alsactl monitor` instead of polling, so it will refresh
+  instantly when there's a volume change, and won't use CPU until a change happens.
+- Aliases to `alsa:` followed by the mixer name and element name separated by a colon. Thus,
+  `Alsa "default" "Master" []` can be used as `%alsa:default:Master%`.
+- Additional options (after the `--`):
+    - `--alsactl=/path/to/alsactl`
+        - If this option is not specified, `alsactl` will be sought in your `PATH`
+          first, and failing that, at `/usr/sbin/alsactl` (this is its location on
+          Debian systems. `alsactl monitor` works as a non-root user despite living
+          in `/usr/sbin`.).
+- `stdbuf` (from coreutils) must be (and most probably already is) in your `PATH`.
+
 ### `MPD Args RefreshRate`
 
 - This monitor will only be compiled if you ask for it using the
diff --git a/src/Plugins/Monitors.hs b/src/Plugins/Monitors.hs
index 2fe7cc2..08fd098 100644
--- a/src/Plugins/Monitors.hs
+++ b/src/Plugins/Monitors.hs
@@ -50,6 +50,7 @@ import Plugins.Monitors.Common (runMBD)
 #endif
 #ifdef ALSA
 import Plugins.Monitors.Volume
+import Plugins.Monitors.Alsa
 #endif
 #ifdef MPRIS
 import Plugins.Monitors.Mpris
@@ -90,6 +91,7 @@ data Monitors = Network      Interface   Args Rate
 #endif
 #ifdef ALSA
               | Volume   String     String Args Rate
+              | Alsa     String     String Args
 #endif
 #ifdef MPRIS
               | Mpris1   String     Args Rate
@@ -143,6 +145,7 @@ instance Exec Monitors where
 #endif
 #ifdef ALSA
     alias (Volume m c _ _) = m ++ ":" ++ c
+    alias (Alsa m c _) = "alsa:" ++ m ++ ":" ++ c
 #endif
 #ifdef MPRIS
     alias (Mpris1 _ _ _) = "mpris1"
@@ -183,7 +186,8 @@ instance Exec Monitors where
     start (AutoMPD a) = runMBD a mpdConfig runMPD mpdWait mpdReady
 #endif
 #ifdef ALSA
-    start (Volume m c a r) = startVolume m c a r
+    start (Volume m c a r) = runM a volumeConfig (runVolume m c) r
+    start (Alsa m c a) = startAlsaPlugin m c a
 #endif
 #ifdef MPRIS
     start (Mpris1 s a r) = runM a mprisConfig (runMPRIS1 s) r
diff --git a/src/Plugins/Monitors/Alsa.hs b/src/Plugins/Monitors/Alsa.hs
new file mode 100644
index 0000000..ba8e100
--- /dev/null
+++ b/src/Plugins/Monitors/Alsa.hs
@@ -0,0 +1,149 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Plugins.Monitors.Alsa
+-- Copyright   :  (c) 2018 Daniel Schüssler
+-- License     :  BSD-style (see LICENSE)
+--
+-- Maintainer  :  Jose A. Ortega Ruiz <jao@gnu.org>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+-- Event-based variant of the Volume plugin.
+--
+-----------------------------------------------------------------------------
+
+module Plugins.Monitors.Alsa
+  ( startAlsaPlugin
+  , getMonitorWaiter
+  , parseOptsIncludingMonitorArgs
+  , AlsaOpts(aoAlsaCtlPath)
+  ) where
+
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import Plugins.Monitors.Common
+import Plugins.Monitors.Volume(volumeConfig, VolumeOpts, runVolumeWith)
+import qualified Plugins.Monitors.Volume as Volume;
+import System.Console.GetOpt
+import System.Directory
+import System.Exit
+import System.IO
+import System.Process
+
+data AlsaOpts = AlsaOpts
+    { aoVolumeOpts :: VolumeOpts
+    , aoAlsaCtlPath :: Maybe FilePath
+    }
+
+defaultOpts :: AlsaOpts
+defaultOpts = AlsaOpts Volume.defaultOpts Nothing
+
+alsaCtlOptionName :: String
+alsaCtlOptionName = "alsactl"
+
+options :: [OptDescr (AlsaOpts -> AlsaOpts)]
+options =
+    Option "" [alsaCtlOptionName] (ReqArg (\x o ->
+       o { aoAlsaCtlPath = Just x }) "") ""
+    : fmap (fmap modifyVolumeOpts) Volume.options
+  where
+    modifyVolumeOpts f o = o { aoVolumeOpts = f (aoVolumeOpts o) }
+
+parseOpts :: [String] -> IO AlsaOpts
+parseOpts argv =
+    case getOpt Permute options argv of
+        (o, _, []) -> return $ foldr id defaultOpts o
+        (_, _, errs) -> ioError . userError $ concat errs
+
+parseOptsIncludingMonitorArgs :: [String] -> IO AlsaOpts
+parseOptsIncludingMonitorArgs args =
+    -- Drop generic Monitor args first
+    case getOpt Permute [] args of
+      (_, args', _) -> parseOpts args'
+
+startAlsaPlugin :: String -> String -> [String] -> (String -> IO ()) -> IO ()
+startAlsaPlugin mixerName controlName args cb = do
+  opts <- parseOptsIncludingMonitorArgs args
+
+  waitFunction <- getMonitorWaiter mixerName (aoAlsaCtlPath opts)
+
+  let run args2 = do
+        -- Replicating the reparsing logic used by other plugins for now,
+        -- but it seems the option parsing could be floated out (actually,
+        -- GHC could in principle do it already since getOpt is pure, but
+        -- it would have to inline 'runMBD', 'doArgs' and 'parseOpts' to see
+        -- it, which probably isn't going to happen with the default
+        -- optimization settings).
+        opts2 <- io $ parseOpts args2
+        runVolumeWith (aoVolumeOpts opts2) mixerName controlName
+
+  runMB args volumeConfig run waitFunction cb
+
+getMonitorWaiter :: String -> Maybe FilePath -> IO (IO ())
+getMonitorWaiter mixerName alsaCtlPath = do
+  mvar <- newMVar Nothing :: IO (MVar (Maybe SomeException))
+
+  forkFinally (readerThread mvar) (putMVar mvar . either Just (const Nothing))
+
+  pure $ do
+    ei <- takeMVar mvar
+    case ei of
+      -- Propagate exceptions from reader thread
+      Just (SomeException ex) -> throwIO ex
+      Nothing -> pure ()
+
+  where
+
+    readerThread mvar = do
+          path <- determineAlsaCtlPath
+          withCreateProcess
+            (proc "stdbuf" ["-oL", path, "monitor", mixerName]) {std_out = CreatePipe}
+            run
+
+      where
+
+        defaultPath = "/usr/sbin/alsactl"
+
+        determineAlsaCtlPath =
+          case alsaCtlPath of
+            Just path -> do
+              found <- doesFileExist path
+              if found
+                then pure path
+                else throwIO . ErrorCall $
+                     "Specified alsactl file " ++ path ++ " does not exist"
+
+            Nothing -> do
+              (ec, path, err) <- readProcessWithExitCode "which" ["alsactl"] ""
+              unless (null err) $ hPutStrLn stderr err
+              case ec of
+                ExitSuccess -> pure $ trimTrailingNewline path
+                ExitFailure _ -> do
+                  found <- doesFileExist defaultPath
+                  if found
+                    then pure defaultPath
+                    else throwIO . ErrorCall $
+                         "alsactl not found in PATH or at " ++
+                         show defaultPath ++
+                         "; please specify with --" ++
+                         alsaCtlOptionName ++ "=/path/to/alsactl"
+
+
+        run _ ~(Just out) _ _ = do
+          hSetBuffering out LineBuffering
+          forever $ do
+            c <- hGetChar out
+            when (c == '\n') $
+              -- This uses 'tryPutMVar' because 'putMVar' would make 'runVolume' run
+              -- once for each event. But we want it to run only once after a burst
+              -- of events.
+              void $ tryPutMVar mvar Nothing
+
+-- This is necessarily very inefficient on 'String's
+trimTrailingNewline :: String -> String
+trimTrailingNewline x =
+  case reverse x of
+    '\n' : '\r' : y -> reverse y
+    '\n' : y -> reverse y
+    _ -> x
diff --git a/src/Plugins/Monitors/Volume.hs b/src/Plugins/Monitors/Volume.hs
index 4974e5b..5702137 100644
--- a/src/Plugins/Monitors/Volume.hs
+++ b/src/Plugins/Monitors/Volume.hs
@@ -13,29 +13,21 @@
 -----------------------------------------------------------------------------
 
 module Plugins.Monitors.Volume
-  ( startVolume
-  , runVolume
+  ( runVolume
+  , runVolumeWith
   , volumeConfig
-  , getMonitorWaiter
-  , parseOptsIncludingMonitorArgs
-  , VolumeOpts(refreshMode)
-  , RefreshMode(..)
+  , options
+  , defaultOpts
+  , VolumeOpts
   ) where
 
-import Commands (tenthSeconds)
 import Control.Applicative ((<$>))
-import Control.Concurrent
-import Control.Exception
-import Control.Monad ( forever, liftM2, liftM3, mplus, void, when, unless )
+import Control.Monad ( liftM2, liftM3, mplus )
 import Data.Traversable (sequenceA)
 import Plugins.Monitors.Common
 import Sound.ALSA.Mixer
 import qualified Sound.ALSA.Exception as AE
 import System.Console.GetOpt
-import System.Directory
-import System.Exit
-import System.IO
-import System.Process
 
 volumeConfig :: IO MConfig
 volumeConfig = mkMConfig "Vol: <volume>% <status>"
@@ -50,13 +42,8 @@ data VolumeOpts = VolumeOpts
     , highDbThresh :: Float
     , lowDbThresh :: Float
     , volumeIconPattern :: Maybe IconPattern
-    , refreshMode :: RefreshMode
     }
 
-data RefreshMode = RefreshModePoll
-                 | RefreshModeMonitor (Maybe FilePath) -- alsactl path
-                 deriving(Eq,Show)
-
 defaultOpts :: VolumeOpts
 defaultOpts = VolumeOpts
     { onString = "[on] "
@@ -66,12 +53,8 @@ defaultOpts = VolumeOpts
     , highDbThresh = -5.0
     , lowDbThresh = -30.0
     , volumeIconPattern = Nothing
-    , refreshMode = RefreshModePoll
     }
 
-monitorOptionName :: String
-monitorOptionName = "monitor"
-
 options :: [OptDescr (VolumeOpts -> VolumeOpts)]
 options =
     [ Option "O" ["on"] (ReqArg (\x o -> o { onString = x }) "") ""
@@ -82,8 +65,6 @@ options =
     , Option "c" ["offc"] (ReqArg (\x o -> o { offColor = Just x }) "") ""
     , Option "" ["volume-icon-pattern"] (ReqArg (\x o ->
        o { volumeIconPattern = Just $ parseIconPattern x }) "") ""
-    , Option "" [monitorOptionName] (OptArg (\x o ->
-       o { refreshMode = RefreshModeMonitor x }) "") ""
     ]
 
 parseOpts :: [String] -> IO VolumeOpts
@@ -148,6 +129,10 @@ formatDb opts dbi = do
 runVolume :: String -> String -> [String] -> Monitor String
 runVolume mixerName controlName argv = do
     opts <- io $ parseOpts argv
+    runVolumeWith opts mixerName controlName
+
+runVolumeWith :: VolumeOpts -> String -> String -> Monitor String
+runVolumeWith opts mixerName controlName = do
     (lo, hi, val, db, sw) <- io readMixer
     p <- liftMonitor $ liftM3 formatVol lo hi val
     b <- liftMonitor $ liftM3 formatVolBar lo hi val
@@ -209,89 +194,3 @@ runVolume mixerName controlName argv = do
     getFormatSwitch opts (Just sw) = formatSwitch opts sw
 
     unavailable = getConfigValue naString
-
-parseOptsIncludingMonitorArgs :: [String] -> IO VolumeOpts
-parseOptsIncludingMonitorArgs args =
-    -- Drop generic Monitor args first
-    case getOpt Permute [] args of
-      (_, args', _) -> parseOpts args'
-
-startVolume :: String -> String -> [String] -> Int -> (String -> IO ()) -> IO ()
-startVolume mixerName controlName args rate cb = do
-  opts <- parseOptsIncludingMonitorArgs args
-
-  waitFunction <-
-    case refreshMode opts of
-      RefreshModePoll -> pure $ tenthSeconds rate
-      RefreshModeMonitor alsaCtlPath -> getMonitorWaiter mixerName alsaCtlPath
-
-  runMB args volumeConfig (runVolume mixerName controlName) waitFunction cb
-
-
-getMonitorWaiter :: String -> Maybe FilePath -> IO (IO ())
-getMonitorWaiter mixerName alsaCtlPath = do
-  mvar <- newMVar Nothing :: IO (MVar (Maybe SomeException))
-
-  forkFinally (readerThread mvar) (putMVar mvar . either Just (const Nothing))
-
-  pure $ do
-    ei <- takeMVar mvar
-    case ei of
-      -- Propagate exceptions from reader thread
-      Just (SomeException ex) -> throwIO ex
-      Nothing -> pure ()
-
-  where
-
-    readerThread mvar = do
-          path <- determineAlsaCtlPath
-          withCreateProcess
-            (proc "stdbuf" ["-oL", path, "monitor", mixerName]) {std_out = CreatePipe}
-            run
-
-      where
-
-        defaultPath = "/usr/sbin/alsactl"
-
-        determineAlsaCtlPath =
-          case alsaCtlPath of
-            Just path -> do
-              found <- doesFileExist path
-              if found
-                then pure path
-                else throwIO . ErrorCall $
-                     "Specified alsactl file " ++ path ++ " does not exist"
-
-            Nothing -> do
-              (ec, path, err) <- readProcessWithExitCode "which" ["alsactl"] ""
-              unless (null err) $ hPutStrLn stderr err
-              case ec of
-                ExitSuccess -> pure $ trimTrailingNewline path
-                ExitFailure _ -> do
-                  found <- doesFileExist defaultPath
-                  if found
-                    then pure defaultPath
-                    else throwIO . ErrorCall $
-                         "alsactl not found in PATH or at " ++
-                         show defaultPath ++
-                         "; please specify with --" ++
-                         monitorOptionName ++ "=/path/to/alsactl"
-
-
-        run _ ~(Just out) _ _ = do
-          hSetBuffering out LineBuffering
-          forever $ do
-            c <- hGetChar out
-            when (c == '\n') $
-              -- This uses 'tryPutMVar' because 'putMVar' would make 'runVolume' run
-              -- once for each event. But we want it to run only once after a burst
-              -- of events.
-              void $ tryPutMVar mvar Nothing
-
--- This is necessarily very inefficient on 'String's
-trimTrailingNewline :: String -> String
-trimTrailingNewline x =
-  case reverse x of
-    '\n' : '\r' : y -> reverse y
-    '\n' : y -> reverse y
-    _ -> x
diff --git a/test/Plugins/Monitors/VolumeSpec.hs b/test/Plugins/Monitors/AlsaSpec.hs
index d724c21..a813c1d 100644
--- a/test/Plugins/Monitors/VolumeSpec.hs
+++ b/test/Plugins/Monitors/AlsaSpec.hs
@@ -1,5 +1,5 @@
 {-# OPTIONS_GHC -Wall #-}
-module Plugins.Monitors.VolumeSpec
+module Plugins.Monitors.AlsaSpec
   ( main
   , spec
   ) where
@@ -7,7 +7,7 @@ module Plugins.Monitors.VolumeSpec
 import Control.Concurrent
 import Control.Concurrent.Async
 import Control.Monad
-import Plugins.Monitors.Volume
+import Plugins.Monitors.Alsa
 import System.FilePath
 import System.IO
 import System.IO.Temp
@@ -20,22 +20,18 @@ main = hspec spec
 
 spec :: Spec
 spec = do
-  describe "Volume.getWaitMonitor" $
-    it "produces the expected timeline (using a fake alsactl)" $
-      runFakeAlsactlTest
+  describe "Alsa.getWaitMonitor" $
+    it "produces the expected timeline (using a fake alsactl)"
+       runFakeAlsactlTest
 
-  describe "Volume.parseOptsIncludingMonitorArgs" $ do
+  describe "Alsa.parseOptsIncludingMonitorArgs" $ do
     it "works with empty args" $ do
       opts <- parseOptsIncludingMonitorArgs []
-      refreshMode opts `shouldBe` RefreshModePoll
+      aoAlsaCtlPath opts `shouldBe` Nothing
 
-    it "parses --monitor" $ do
-      opts <- parseOptsIncludingMonitorArgs ["--", "--monitor"]
-      refreshMode opts `shouldBe` RefreshModeMonitor Nothing
-
-    it "parses --monitor=foo" $ do
-      opts <- parseOptsIncludingMonitorArgs ["--", "--monitor=foo"]
-      refreshMode opts `shouldBe` RefreshModeMonitor (Just "foo")
+    it "parses --alsactl=foo" $ do
+      opts <- parseOptsIncludingMonitorArgs ["--", "--alsactl=foo"]
+      aoAlsaCtlPath opts `shouldBe` Just "foo"
 
 
 runFakeAlsactlTest :: Expectation
diff --git a/xmobar.cabal b/xmobar.cabal
index 6306677..1a3684c 100644
--- a/xmobar.cabal
+++ b/xmobar.cabal
@@ -45,7 +45,8 @@ test-suite XmobarTest
         Plugins.Monitors.ThermalZone, Plugins.Monitors.Top,
         Plugins.Monitors.Uptime,
         Plugins.Monitors.Bright, Plugins.Monitors.CatInt,
-        Plugins.Monitors.VolumeSpec
+        Plugins.Monitors.CommonSpec
+
   build-depends:
     base >= 4.9.1.0 && < 4.13,
     hspec == 2.*,
@@ -69,8 +70,11 @@ test-suite XmobarTest
 
   if flag(with_alsa) || flag(all_extensions)
       build-depends: alsa-mixer > 0.2.0.2
-      build-depends: alsa-core == 0.5.*
+      build-depends: alsa-core == 0.5.*,
+                     process >= 1.4.3.0
       other-modules: Plugins.Monitors.Volume
+                     Plugins.Monitors.Alsa
+                     Plugins.Monitors.AlsaSpec
       cpp-options: -DALSA
 
 source-repository head
@@ -229,8 +233,10 @@ executable xmobar
 
     if flag(with_alsa) || flag(all_extensions)
        build-depends: alsa-mixer > 0.2.0.2
-       build-depends: alsa-core == 0.5.*
+       build-depends: alsa-core == 0.5.*,
+                      process >= 1.4.3.0
        other-modules: Plugins.Monitors.Volume
+                      Plugins.Monitors.Alsa
        cpp-options: -DALSA
 
     if flag(with_datezone) || flag(all_extensions)