Allow configuration of blocks from cli

This reverses the control flow between 'Cli' and 'Server'

app/Main.hs

 module Main where
 
 import QBar.Cli
-import QBar.DefaultConfig
-import QBar.Server
 
 main :: IO ()
-main = parseOptions >>= runQBar generateDefaultBarConfig
+main = runQBar
\ No newline at end of file

src/QBar/Cli.hs

@@ -2,47 +2,55 @@
 
 module QBar.Cli where
 
+import QBar.ControlSocket
+import QBar.Core
+import QBar.DefaultConfig
+import QBar.Server
 import QBar.Theme
 
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as TL
+import Control.Monad (join, sequence_)
+import qualified Data.Text.Lazy as T
 import Options.Applicative
 
-data BarCommand = BarServerCommand | SetThemeCommand Text | ConnectSocket
+-- |Entry point.
+runQBar :: IO ()
+runQBar = join parseMain
 
-barCommandParser :: Parser BarCommand
-barCommandParser = hsubparser (
-    command "server" (info (pure BarServerCommand) (progDesc "Start a new qbar server. Should be called by swaybar, i3bar or or another i3bar-protocol compatible host process.")) <>
-    command "connect" (info (pure ConnectSocket) (progDesc "Run blocks on this process but display them on the qbar server.")) <>
-    command "theme" (info themeCommandParser (progDesc "Change the theme of the running qbar server.")) <>
-    command "default" (info (pure $ SetThemeCommand "default") (progDesc "Shortcut for 'qbar theme default'.")) <>
-    command "rainbow" (info (pure $ SetThemeCommand "rainbow") (progDesc "Shortcut for 'qbar theme rainbow'."))
-  )
-
-themeCommandParser :: Parser BarCommand
-themeCommandParser = SetThemeCommand <$> strArgument (metavar "THEME" <> completeWith (map TL.unpack themeNames))
+parseMain :: IO (IO ())
+parseMain = customExecParser parserPrefs parser
+  where
+    parser :: ParserInfo (IO ())
+    parser = info (mainParser <**> helper)
+      (fullDesc <> header "qbar - queezles {i3,sway}bar infrastructure")
 
-data MainOptions = MainOptions {
-  verbose :: Bool,
-  indicator :: Bool,
-  socketLocation :: Maybe T.Text,
-  barCommand :: BarCommand
-}
+    parserPrefs :: ParserPrefs
+    parserPrefs = prefs showHelpOnEmpty
 
-mainOptionsParser :: Parser MainOptions
-mainOptionsParser = do
+mainParser :: Parser (IO ())
+mainParser = do
   verbose <- switch $ long "verbose" <> short 'v' <> help "Print more diagnostic output to stderr (including a copy of every bar update)."
   indicator <- switch $ long "indicator" <> short 'i' <> help "Show render indicator."
   socketLocation <- optional $ strOption $ long "socket" <> short 's' <> metavar "SOCKET" <> help "Control socket location. By default determined by WAYLAND_SOCKET location."
   barCommand <- barCommandParser
-  return MainOptions {verbose, indicator, socketLocation, barCommand}
+  return (barCommand MainOptions {verbose, indicator, socketLocation})
 
-parser :: ParserInfo MainOptions
-parser = info (mainOptionsParser <**> helper)
-  (fullDesc <> header "qbar - queezles {i3,sway}bar infrastructure")
-
-parserPrefs :: ParserPrefs
-parserPrefs = prefs showHelpOnEmpty
+barCommandParser :: Parser (MainOptions -> IO ())
+barCommandParser = hsubparser (
+    command "server" (info (runBarServer <$> barConfigurationParser) (progDesc "Start a new qbar server. Should be called by swaybar, i3bar or or another i3bar-protocol compatible host process.")) <>
+    command "connect" (info (sendBlockStream <$> barConfigurationParser) (progDesc "Run blocks on this process but display them on the qbar server.")) <>
+    command "theme" (info themeCommandParser (progDesc "Change the theme of the running qbar server.")) <>
+    command "default" (info (pure $ sendIpc . SetTheme $ "default") (progDesc "Shortcut for 'qbar theme default'.")) <>
+    command "rainbow" (info (pure $ sendIpc . SetTheme $ "rainbow") (progDesc "Shortcut for 'qbar theme rainbow'."))
+  )
 
-parseOptions :: IO MainOptions
-parseOptions = customExecParser parserPrefs parser
+themeCommandParser :: Parser (MainOptions -> IO ())
+themeCommandParser = sendIpc . SetTheme <$> strArgument (metavar "THEME" <> completeWith (map T.unpack themeNames))
\ No newline at end of file
+
+barConfigurationParser :: Parser (BarIO ())
+barConfigurationParser = do
+  blocks <- many $ hsubparser (
+      command "default" (info (pure defaultBarConfig) (progDesc "Load default set of blocks."))
+    )
+  pure $ case blocks of
+    [] -> defaultBarConfig
+    l -> sequence_ l

src/QBar/ControlSocket.hs

@@ -9,7 +9,6 @@
 module QBar.ControlSocket where
 
 import QBar.BlockOutput
-import QBar.Cli (MainOptions(..))
 import QBar.Core
 import QBar.Host
 import QBar.Util
@@ -27,8 +26,7 @@ import System.IO
 import Data.Either (either)
 import Data.Maybe (maybe)
 import Data.Text.Lazy (Text, pack)
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy as T
 import Network.Socket
 import Pipes
 import Pipes.Concurrent as PC (Output, spawn', unbounded, fromInput, send, atomically)
@@ -110,12 +108,15 @@ instance IsStream BlockStream where
   type Down BlockStream = BlockEvent
   toStreamType = BlockStreamType
   streamHandler _ = do
-    (cache, updateC, seal) <- newCache'
+    (cache, updateCacheC, sealCache) <- newCache'
     (eventOutput, eventInput, eventSeal) <- liftIO $ spawn' unbounded
     bar <- askBar
     addBlock cache
     prefix <- liftIO $ (<> "_") <$> randomIdentifier
-    return (updateBarP bar >-> attachHandlerP eventOutput prefix >-> updateC, fromInput eventInput, seal >> atomically eventSeal)
+    let blockConsumer = updateBarP bar >-> attachHandlerP eventOutput prefix >-> updateCacheC
+    let eventProducer = fromInput eventInput
+    let seal = sealCache >> atomically eventSeal >> updateBar' bar
+    return (blockConsumer, eventProducer, seal)
     where
       attachHandlerP :: Output BlockEvent -> Text -> Pipe [BlockOutput] [BlockState] IO ()
       attachHandlerP eventOutput prefix = attachHandlerP'
@@ -145,7 +146,7 @@ instance IsStream BlockStream where
 
 data Request = Command Command | StartStream StreamType
 
-data Command = SetTheme TL.Text
+data Command = SetTheme T.Text
   deriving Show
 
 data CommandResult = Success | Error Text
@@ -189,8 +190,8 @@ $(deriveJSON defaultOptions ''CommandResult)
 $(deriveJSON defaultOptions ''StreamType)
 $(deriveJSON defaultOptions ''BlockStream)
 
-sendIpc :: MainOptions -> Command -> IO ()
-sendIpc options@MainOptions{verbose} command = do
+sendIpc :: Command -> MainOptions -> IO ()
+sendIpc command options@MainOptions{verbose} = do
   let request = Command command
   sock <- connectIpcSocket options
   runEffect $ encode request >-> toSocket sock
@@ -206,8 +207,8 @@ sendIpc options@MainOptions{verbose} command = do
     showResponse Success = when verbose $ hPutStrLn stderr "Success"
     showResponse (Error message) = hPrint stderr message
 
-sendBlockStream :: MainOptions -> BarIO () -> IO ()
-sendBlockStream = runBarHost . streamClient BlockStream
+sendBlockStream :: BarIO () -> MainOptions -> IO ()
+sendBlockStream loadBlocks options = runBarHost (streamClient BlockStream options) loadBlocks
 
 
 listenUnixSocketAsync :: MainOptions -> Bar -> CommandHandler -> IO (Async ())

src/QBar/Core.hs

@@ -33,6 +33,12 @@ import System.Process.Typed (Process, shell, setStdin, setStdout,
   getStdout, closed, createPipe, readProcessStdout, startProcess, stopProcess)
 
 
+data MainOptions = MainOptions {
+  verbose :: Bool,
+  indicator :: Bool,
+  socketLocation :: Maybe T.Text
+}
+
 data BlockEvent = Click {
   name :: T.Text,
   button :: Int

src/QBar/DefaultConfig.hs

@@ -11,8 +11,8 @@ import Control.Lens
 blockLocation :: String -> FilePath
 blockLocation name = "~/.config/qbar/blocks/" <> name
 
-generateDefaultBarConfig :: BarIO ()
-generateDefaultBarConfig = do
+defaultBarConfig :: BarIO ()
+defaultBarConfig = do
   systemInfoInterval <- sharedInterval 10
 
   let todo = systemInfoInterval (blockScript $ blockLocation "todo")

src/QBar/Server.hs

@@ -5,7 +5,6 @@ module QBar.Server where
 
 import QBar.BlockOutput
 import QBar.Core
-import QBar.Cli
 import QBar.ControlSocket
 import QBar.Host
 import QBar.Pango
@@ -117,8 +116,8 @@ swayBarOutput options@MainOptions{indicator} = do
       pangoBlockName = _blockName
     }
 
-runBarServer :: MainOptions -> BarIO () -> IO ()
-runBarServer options = runBarHost barServer
+runBarServer :: BarIO () -> MainOptions -> IO ()
+runBarServer loadBlocks options = runBarHost barServer loadBlocks
   where
     barServer :: BarIO (Consumer [BlockOutput] IO (), Producer BlockEvent IO ())
     barServer = do
@@ -190,12 +189,3 @@ runBarServer options = runBarHost barServer
         Right theme -> do
           setTheme' theme
           return Success
-
-
--- |Entry point.
-runQBar :: BarIO () -> MainOptions -> IO ()
-runQBar barConfiguration options@MainOptions{barCommand} = runCommand barCommand
-  where
-    runCommand BarServerCommand = runBarServer options barConfiguration
-    runCommand ConnectSocket = sendBlockStream options barConfiguration
-    runCommand (SetThemeCommand themeName) = sendIpc options $ SetTheme themeName