diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,14 +1,22 @@ # Revision history for dzen-dhall -## 1.0.1 -- 2018-08-29 +## 1.0.2 -- 2020-18-02 ### Changes +- Updated Dhall version to 1.28.0 + +### Fixed +- stdout/stderr handles for spawned processes were not being closed, resulting in `too many open files` errors when using plugins that emit events a lot (#9) + +## 1.0.1 -- 2019-08-29 + +### Changes - Add a small delay between dzen2 startups to preserve the ordering of bars (#6) ### Fixed - Validation for `#XXXXXX`-formatted colors (#5) - Padding (#4) -## 1.0.0 -- 2018-08-26 +## 1.0.0 -- 2019-08-26 * First version. Released on an unsuspecting world. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -37,7 +37,7 @@ In effect, `dzen-dhall` introduces a new approach to desktop scripting/customization with Dzen. Basically, it provides solutions for all of the aforementioned problems. `dzen-dhall` is smart when formatting text, handles newlines gracefully, runs output sources in parallel, and its [plugin system](#installing-plugins) solves the problem of code reuse. -### Quick example +### A quick example The essence of the DSL can be illustrated by the following excerpt from [the default config file](dhall/config.dhall) (with additional comments): @@ -175,7 +175,7 @@ This chapter describes `dzen-dhall` DSL in depth. It's best to read the [Dhall wiki](https://github.com/dhall-lang/dhall-lang/wiki) to become familiar with Dhall syntax before you proceed. -### [Bars](dhall/src/Bar.dhall) +### [Bars](dhall/types/Bar.dhall) The most important concept of the DSL is `Bar`. Essentially, `Bar` is a tree data structure containing text, images, shapes, etc. in its leaves. [Default config file](dhall/config.dhall) exposes some functions for working with `Bar`s: @@ -630,7 +630,7 @@ (automaton address stateTransitionTable stateMap) ``` -#### [State maps](dhall/src/StateMap.dhall) +#### [State maps](dhall/types/StateMap.dhall) `StateMap`s are used to define mappings from states to bars, i.e. they determine what to show depending on the state. @@ -644,7 +644,7 @@ Also note that unlike in traditional reactive frameworks, current state of an automaton only determines which `Bar` is *shown*, not *present in the tree*. See [this section](#deduplication) for more context. -#### [Events](dhall/src/Event.dhall) +#### [Events](dhall/types/Event.dhall) Events can be emitted from within [hooks](#hooks), [sources](#sources) and [clickable areas](#clickable-areas). The only way to react to some event is to use an automaton. @@ -654,7 +654,7 @@ let emit : Event → Shell ``` -#### [Hooks](dhall/src/Hook.dhall) +#### [Hooks](dhall/types/Hook.dhall) Hooks allow to execute arbitrary commands before state transitions of automata. When a hook exits with non-zero code, it prevents its corresponding state transition from happening. So, generally, hooks should only contain commands that exit fast, to prevent excessive delays. @@ -816,9 +816,9 @@ Dhall does not support recursive ADTs (which are obviously required to construct tree-like statusbar configurations), but there is a [trick](https://github.com/dhall-lang/dhall-lang/wiki/How-to-translate-recursive-code-to-Dhall) to bypass that, called [Boehm-Berarducci encoding](http://okmij.org/ftp/tagless-final/course/Boehm-Berarducci.html). -We use this method in a slightly modified variant: [`Carrier`](dhall/src/Carrier.dhall) type is introduced to hide all the constructors in a huge record. +We use this method in a slightly modified variant: [`Carrier`](dhall/types/Carrier.dhall) type is introduced to hide all the constructors in a huge record. -Essentially, [our definition of `Bar`](dhall/src/Bar.dhall) is equivalent to something like the following, which is a direct Boehm-Berarducci encoding: +Essentially, [our definition of `Bar`](dhall/types/Bar.dhall) is equivalent to something like the following, which is a direct Boehm-Berarducci encoding: ```dhall let Bar = @@ -831,7 +831,7 @@ → Bar ``` -During the stage of [config](dhall/config.dhall) processing, `Bar`s are converted to a type called [Plugin](dhall/src/Plugin.dhall), which is a list of [Token](dhall/src/Token.dhall)s (in fact, `List` is the only recursive data type in Dhall). These tokens can be marshalled into Haskell, and then [parsed back](src/DzenDhall/Parser.hs) into a tree structure ([DzenDhall.Data.Bar](src/DzenDhall/Data.hs)). +During the stage of [config](dhall/config.dhall) processing, `Bar`s are converted to a type called [Plugin](dhall/types/Plugin.dhall), which is a list of [Token](dhall/types/Token.dhall)s (in fact, `List` is the only recursive data type in Dhall). These tokens can be marshalled into Haskell, and then [parsed back](src/DzenDhall/Parser.hs) into a tree structure ([DzenDhall.Data.Bar](src/DzenDhall/Data.hs)). After that, `dzen-dhall` [spawns some threads](src/DzenDhall/App/StartingUp.hs) for each output source and processes the outputs as specified in the configuration. diff --git a/dzen-dhall.cabal b/dzen-dhall.cabal --- a/dzen-dhall.cabal +++ b/dzen-dhall.cabal @@ -4,16 +4,16 @@ -- -- see: https://github.com/sol/hpack -- --- hash: b68721f6e4d0f2557c8dd8e71bbc259433931d8686268ad8fb851180c946fe4b +-- hash: 21bc22f735ad73a0a94259f0e1d3926c7d7c5ebde6487183bbb03e4b24b9261b name: dzen-dhall -version: 1.0.1 +version: 1.0.2 synopsis: Configure dzen2 bars in Dhall language description: Configure dzen2 bars in Dhall language homepage: https://github.com/dzen-dhall/dzen-dhall#readme bug-reports: https://github.com/dzen-dhall/dzen-dhall/issues -author: Kalnitsky Vladimir -maintainer: Kalnitsky Vladimir +author: Vladimir Kalnitsky +maintainer: Vladimir Kalnitsky license: BSD-3-Clause license-file: LICENSE build-type: Simple @@ -137,7 +137,7 @@ ansi-terminal , base >=4.12 && <5 , bytestring - , dhall ==1.25.0 + , dhall , directory , file-embed-lzma , filepath @@ -198,7 +198,7 @@ HUnit , QuickCheck , base - , dhall ==1.25.0 + , dhall , dzen-dhall , filepath , generic-random diff --git a/src/DzenDhall.hs b/src/DzenDhall.hs --- a/src/DzenDhall.hs +++ b/src/DzenDhall.hs @@ -7,40 +7,45 @@ import DzenDhall.Commands.Unplug import DzenDhall.Commands.Validate import DzenDhall.Runtime -import DzenDhall.Extra (waitForever) +import qualified Paths_dzen_dhall as Paths + +import Data.Version (showVersion) import Lens.Micro import Options.Applicative (execParser) import qualified GHC.IO.Encoding import qualified System.IO - main :: IO () main = do GHC.IO.Encoding.setLocaleEncoding System.IO.utf8 arguments <- execParser argumentsParser + case arguments ^. mbCommand of Nothing -> do runtime <- readRuntime arguments - runApp runtime () $ do + runApp runtime () do useConfigurations - liftIO waitForever + waitForExit Just Init -> do initCommand arguments Just (Plug commandArgs) -> do runtime <- readRuntime arguments - runApp runtime () $ + runApp runtime () do plugCommand commandArgs Just (Unplug commandArgs) -> do runtime <- readRuntime arguments - runApp runtime () $ + runApp runtime () do unplugCommand commandArgs Just (Validate commandArgs) -> do runtime <- readRuntime arguments runApp runtime () (validateCommand commandArgs) + + Just Version -> do + putStrLn $ "v" ++ showVersion Paths.version diff --git a/src/DzenDhall/App.hs b/src/DzenDhall/App.hs --- a/src/DzenDhall/App.hs +++ b/src/DzenDhall/App.hs @@ -56,11 +56,10 @@ newtype Forked = Forked Void -- | Maps app execution stages to app states. -type family StateOf a - -type instance StateOf Common = () -type instance StateOf StartingUp = StartupState -type instance StateOf Forked = BarRuntime +type family StateOf a where + StateOf Common = () + StateOf StartingUp = StartupState + StateOf Forked = BarRuntime -- | 'Runtime' is read-only; mutable state type depends on the current stage of execution of the 'App'. newtype App stage a = App { unApp :: StateT (StateOf stage) (ReaderT Runtime IO) a } @@ -171,6 +170,7 @@ else text +-- | Apply @Dhall.detailed@ settings. explained :: IO a -> App stage a explained io = do shouldExplain <- getRuntime <&> (\args -> args ^. rtArguments . explain) @@ -205,3 +205,10 @@ sec * 1000000 + nsec `div` 1000 liftIO $ threadDelay $ fromIntegral delay + + +waitForExit :: App a () +waitForExit = do + runtime <- getRuntime + liftIO do + takeMVar (runtime ^. rtExitMVar) diff --git a/src/DzenDhall/App/Forked.hs b/src/DzenDhall/App/Forked.hs --- a/src/DzenDhall/App/Forked.hs +++ b/src/DzenDhall/App/Forked.hs @@ -5,10 +5,14 @@ import DzenDhall.App.StartingUp import DzenDhall.Config import DzenDhall.Data +import DzenDhall.Extra import DzenDhall.Runtime.Data +import Control.Concurrent.MVar +import Control.Exception (try) import Lens.Micro import qualified Data.Text.IO +import qualified GHC.IO.Exception as G -- | Update a given 'Bar' forever, trying to do it in a timely manner. @@ -18,11 +22,20 @@ updateForever bar = do barRuntime <- get + runtime <- getRuntime let barSettings = barRuntime ^. brConfiguration ^. cfgBarSettings forkApp do timely (barSettings ^. bsUpdateInterval) do output <- runRender <$> collectSources bar - liftIO $ Data.Text.IO.hPutStrLn (barRuntime ^. brHandle) output + + + liftIO do + res <- try $ Data.Text.IO.hPutStrLn (barRuntime ^. brHandle) output + whenLeft res + \e@(G.IOError {}) -> do + putStrLn $ "IO error, exiting dzen-dhall: " <> show e + putMVar (runtime ^. rtExitMVar) () + modify $ brFrameCounter +~ 1 diff --git a/src/DzenDhall/App/Run.hs b/src/DzenDhall/App/Run.hs --- a/src/DzenDhall/App/Run.hs +++ b/src/DzenDhall/App/Run.hs @@ -15,6 +15,7 @@ import Lens.Micro import Lens.Micro.Extras import System.Exit +import System.Process (ProcessHandle, waitForProcess) import Control.Concurrent (threadDelay) @@ -28,15 +29,15 @@ forM_ (view rtConfigurations runtime) \cfg -> do - (errors, barTokens) <- liftIO $ + (errors, barTokens) <- liftIO do Validation.run $ cfg ^. cfgBarTokens - unless (null errors) $ + unless (null errors) do App.exit 3 $ Validation.report errors withEither (Parser.runBarParser barTokens) - (invalidTokens barTokens) $ + (invalidTokens barTokens) \(bar :: Bar Marshalled) -> do (bar', subscriptions, barRuntime, clickableAreas) <- @@ -46,6 +47,9 @@ runAppForked barRuntime (updateForever bar') + whenJust (barRuntime ^. brDzenHandle) + (runAppForked barRuntime . waitForDzen) + -- This delay is required to preserve the order of multiple dzen2 instances. -- We want them to overlap in exactly the same order as defined in `config.dhall`. -- 50ms is nearly unnoticeable for humans, but just enough for dzen2 to connect to @@ -56,16 +60,22 @@ checkDzen2Executable :: App stage () checkDzen2Executable = do runtime <- getRuntime - liftIO $ - checkExecutables [runtime ^. rtDzenBinary] >>= mapM_ - (\executable -> do + liftIO do + executables <- checkExecutables [runtime ^. rtDzenBinary] + forM_ executables + \executable -> do putStrLn $ "Executable not in PATH: " <> executable <> ". See --dzen-binary argument." - exitWith $ ExitFailure 1) + exitWith $ ExitFailure 1 -invalidTokens :: Show a => [Token] -> a -> App Common () +waitForDzen :: ProcessHandle -> App Forked () +waitForDzen handle = do + void $ liftIO $ waitForProcess handle + + +invalidTokens :: Show a => [Token] -> a -> App Common b invalidTokens barTokens err = do App.exit 3 $ fromLines [ "Internal error when parsing configuration, debug info: " <> showPack barTokens diff --git a/src/DzenDhall/App/StartingUp.hs b/src/DzenDhall/App/StartingUp.hs --- a/src/DzenDhall/App/StartingUp.hs +++ b/src/DzenDhall/App/StartingUp.hs @@ -25,9 +25,9 @@ import qualified Data.HashMap.Strict as H import qualified Data.Text as T import qualified Data.Text.IO as T -import qualified System.IO -import qualified Pipes.Prelude as P import qualified Pipes as P +import qualified Pipes.Prelude as P +import qualified System.IO startUp @@ -42,11 +42,11 @@ environment <- liftIO getEnvironment - forM_ (state ^. ssSourceQueue) $ + forM_ (state ^. ssSourceQueue) \(source, outputRef, cacheRef, scope) -> do mkThread environment barRuntime source outputRef cacheRef scope - forM_ (state ^. ssVariableDefinitions) $ + forM_ (state ^. ssVariableDefinitions) \(scope, name, value) -> do let fileName = @@ -55,7 +55,7 @@ "-v-" <> T.unpack name - liftIO $ do + liftIO do T.writeFile fileName value setFileMode fileName $ ownerReadMode `unionFileModes` @@ -63,8 +63,8 @@ ownerWriteMode `unionFileModes` groupWriteMode - forM_ (H.toList $ state ^. ssImages) $ - \(imageContents, imageId) -> liftIO $ do + forM_ (H.toList $ state ^. ssImages) + \(imageContents, imageId) -> liftIO do T.writeFile (state ^. ssImagePathPrefix <> T.unpack imageId <> ".xbm") imageContents @@ -91,10 +91,10 @@ setterFile = state ^. ssSetterFile variableFilePrefix = state ^. ssVariableFilePrefix - liftIO $ + liftIO do createNamedPipe namedPipe (ownerReadMode `unionFileModes` ownerWriteMode) - liftIO $ do + liftIO do forM_ [ ( [ "#!/usr/bin/env bash" , "SCOPE=\"$1\"" , "EVENT=\"$2\"" @@ -121,7 +121,7 @@ ] , setterFile ) - ] $ + ] \(codeLines, file) -> do @@ -132,29 +132,39 @@ ownerReadMode `unionFileModes` groupReadMode - handle <- case runtime ^. rtArguments ^. stdoutFlag of + (handle, mbProcessHandle) <- + case runtime ^. rtArguments ^. stdoutFlag of - ToStdout -> pure System.IO.stdout + ToStdout -> pure (System.IO.stdout, Nothing) - ToDzen -> do - (mb_stdin, _, _, _) <- liftIO $ - createProcess $ - (proc (runtime ^. rtDzenBinary) args) - { std_out = CreatePipe - , std_in = CreatePipe } + ToDzen -> do + (mb_stdin, _, _, ph) <- liftIO $ + createProcess $ + (proc (runtime ^. rtDzenBinary) args) + { std_in = CreatePipe } -- we never close it - case mb_stdin of - (Just stdin) -> liftIO $ do - hSetEncoding stdin System.IO.utf8 - hSetBuffering stdin LineBuffering - pure stdin - _ -> App.exit 4 $ - "Couldn't open IO handles for dzen binary " <> - showPack dzenBinary + case mb_stdin of - pure $ BarRuntime cfg 0 namedPipe emitterFile getterFile setterFile handle + (Just stdin) -> liftIO do + hSetEncoding stdin System.IO.utf8 + hSetBuffering stdin LineBuffering + pure (stdin, Just ph) + _ -> App.exit 4 $ + "Couldn't open IO handles for dzen binary " <> showPack dzenBinary + pure $ + BarRuntime + cfg + 0 + namedPipe + emitterFile + getterFile + setterFile + handle + mbProcessHandle + + -- | During initialization, IORefs for source outputs and caches are created. -- Also, new threads for each unique source is created. These threads then -- update the outputs. @@ -176,10 +186,10 @@ createRefs :: App StartingUp (IORef Text, Cache) createRefs = do - (outputRef, cacheRef) <- liftIO $ + (outputRef, cacheRef) <- liftIO do liftA2 (,) (newIORef "") (newIORef Nothing) - modify $ ssSourceQueue <>~ - [(source, outputRef, cacheRef, state ^. ssScopeName)] + modify $ ssSourceQueue %~ + ((source, outputRef, cacheRef, state ^. ssScopeName) :) pure (outputRef, cacheRef) (outputRef, cacheRef) <- maybe createRefs pure mbCached @@ -193,7 +203,8 @@ -- Convert delay of a slider from microseconds to frames. let updateInterval = barSettings ^. bsUpdateInterval - slider' = slider & sliderDelay %~ (\x -> x * 1000 `div` positive updateInterval) + slider' = slider & sliderDelay %~ + (\delay -> delay * 1000 `div` positive updateInterval) BarSlider slider' <$> mapM initialize children @@ -223,7 +234,7 @@ -- Create a reference to the current Bar (so that collectSources will not need to -- look up the correct Bar in stateMap). - barRef :: IORef (Bar Initialized) <- liftIO $ + barRef :: IORef (Bar Initialized) <- liftIO do newIORef $ fromMaybe mempty (H.lookup initialState stateMap) let subscription = [ AutomatonSubscription address stt stateMap stateRef barRef ] @@ -329,7 +340,7 @@ -> App StartingUp () mkThread _ _ Source { command = [] } outputRef cacheRef _scope = do let message = "dzen-dhall error: no command specified" - liftIO $ do + liftIO do writeIORef cacheRef $ Just message writeIORef outputRef message mkThread @@ -371,7 +382,7 @@ -- If update interval is not specified, run the source once. Nothing -> - liftIO $ + liftIO do runSourceProcess sourceProcess outputRef cacheRef input @@ -386,7 +397,7 @@ (mb_stdin_hdl, mb_stdout_hdl, mb_stderr_hdl, ph) <- createProcess cp case (mb_stdin_hdl, mb_stdout_hdl, mb_stderr_hdl) of - (Just stdin, Just stdout, _) -> do + (Just stdin, Just stdout, Just stderr) -> do hSetEncoding stdin System.IO.utf8 hSetEncoding stdout System.IO.utf8 hSetBuffering stdin LineBuffering @@ -400,14 +411,18 @@ -- Drop cache writeIORef cacheRef Nothing + writeIORef outputRef (T.pack line) - void $ waitForProcess ph + hClose stdout + hClose stderr _ -> do putStrLn "dzen-dhall error: Couldn't open IO handle(s)" + void $ waitForProcess ph + -- | Reads outputs of 'SourceHandle's and puts them into an AST. collectSources :: Bar Initialized @@ -453,6 +468,7 @@ collectSources (BarTrim width direction child) = do ast <- collectSources child + case direction of DRight -> pure $ fst $ split width ast diff --git a/src/DzenDhall/Arguments.hs b/src/DzenDhall/Arguments.hs --- a/src/DzenDhall/Arguments.hs +++ b/src/DzenDhall/Arguments.hs @@ -47,6 +47,7 @@ | Plug PlugCommand | Unplug UnplugCommand | Validate ValidateCommand + | Version deriving (Show, Eq) data Arguments @@ -104,6 +105,11 @@ ( info ( Validate <$> validateCommandParser ) ( progDesc "Validate the configuration without running it." ) + ) + <> command "version" + ( info + ( pure Version ) + ( progDesc "Print version info" ) ) ) ) diff --git a/src/DzenDhall/Commands/Plug.hs b/src/DzenDhall/Commands/Plug.hs --- a/src/DzenDhall/Commands/Plug.hs +++ b/src/DzenDhall/Commands/Plug.hs @@ -13,7 +13,7 @@ import Data.Either import Data.Maybe import Data.Text (Text) -import Dhall +import Dhall hiding (void) import Dhall.Core import Lens.Micro import Network.HTTP.Client.Conduit @@ -285,7 +285,7 @@ -- TODO: convert exception to `NoParse` - meta <- explained $ inputWithSettings inputSettings pluginMetaType metaBody + meta <- explained $ inputWithSettings inputSettings pluginMetaDecoder metaBody let name = meta ^. pmName parseResult = P.runParser saneIdentifier () "Plugin name" (T.unpack name) diff --git a/src/DzenDhall/Config.hs b/src/DzenDhall/Config.hs --- a/src/DzenDhall/Config.hs +++ b/src/DzenDhall/Config.hs @@ -14,13 +14,13 @@ type AutomatonState = Text -stateType :: Type AutomatonState -stateType = union $ constructor "State" strictText +stateDecoder :: Decoder AutomatonState +stateDecoder = union $ constructor "State" strictText type AutomatonAddress = Text -automatonAddressType :: Type AutomatonAddress -automatonAddressType = union $ constructor "Address" strictText +automatonAddressDecoder :: Decoder AutomatonAddress +automatonAddressDecoder = union $ constructor "Address" strictText type Scope = Text type VariableName = Text @@ -38,8 +38,8 @@ makeLenses ''Marquee -marqueeType :: Type Marquee -marqueeType = record $ +marqueeDecoder :: Decoder Marquee +marqueeDecoder = record $ Marquee <$> field "framesPerCharacter" (positive . fromIntegral <$> natural) <*> field "width" (nonNegative . fromIntegral <$> natural) <*> field "shouldWrap" bool @@ -48,8 +48,8 @@ = DLeft | DRight deriving (Show, Eq, Generic) -directionType :: Type Direction -directionType = union +directionDecoder :: Decoder Direction +directionDecoder = union $ (DLeft <$ constructor "Left" unit) <> (DRight <$ constructor "Right" unit) @@ -57,8 +57,8 @@ = VUp | VDown deriving (Show, Eq, Generic) -verticalDirectionType :: Type VerticalDirection -verticalDirectionType = union +verticalDirectionDecoder :: Decoder VerticalDirection +verticalDirectionDecoder = union $ (VUp <$ constructor "Up" unit) <> (VDown <$ constructor "Down" unit) @@ -67,8 +67,8 @@ | SuccessfulExit Text deriving (Show, Eq, Generic) -assertionType :: Type Assertion -assertionType = union +assertionDecoder :: Decoder Assertion +assertionDecoder = union $ (BinaryInPath <$> constructor "BinaryInPath" strictText) <> (SuccessfulExit <$> constructor "SuccessfulExit" strictText) @@ -80,10 +80,10 @@ makeLenses ''Check -checkType :: Type Check -checkType = record $ +checkDecoder :: Decoder Check +checkDecoder = record $ Check <$> field "message" strictText - <*> field "assertion" assertionType + <*> field "assertion" assertionDecoder data Button = MouseLeft @@ -97,8 +97,8 @@ instance Hashable Button -buttonType :: Type Button -buttonType = union +buttonDecoder :: Decoder Button +buttonDecoder = union $ (MouseLeft <$ constructor "Left" unit) <> (MouseMiddle <$ constructor "Middle" unit) <> (MouseRight <$ constructor "Right" unit) @@ -113,8 +113,8 @@ instance Hashable Event -eventType :: Type Event -eventType = union $ (Event <$> constructor "Event" strictText) +eventDecoder :: Decoder Event +eventDecoder = union $ (Event <$> constructor "Event" strictText) data Fade = Fade @@ -126,9 +126,9 @@ makeLenses ''Fade -fadeType :: Type Fade -fadeType = record $ - Fade <$> field "direction" verticalDirectionType +fadeDecoder :: Decoder Fade +fadeDecoder = record $ + Fade <$> field "direction" verticalDirectionDecoder <*> field "frameCount" (fromIntegral <$> natural) <*> field "height" (fromIntegral <$> natural) @@ -143,10 +143,10 @@ makeLenses ''Slider -sliderType :: Type Slider -sliderType = record $ - Slider <$> field "fadeIn" fadeType - <*> field "fadeOut" fadeType +sliderDecoder :: Decoder Slider +sliderDecoder = record $ + Slider <$> field "fadeIn" fadeDecoder + <*> field "fadeOut" fadeDecoder <*> field "delay" (fromIntegral <$> natural) data Hook @@ -158,8 +158,8 @@ makeLenses ''Hook -hookType :: Type Hook -hookType = record $ +hookDecoder :: Decoder Hook +hookDecoder = record $ Hook <$> field "command" (list strictText) <*> field "input" strictText @@ -168,13 +168,13 @@ } deriving (Show, Eq, Generic) -stateTransitionTableType :: Type StateTransitionTable -stateTransitionTableType = STT . H.fromList . concatMap collect <$> list +stateTransitionTableDecoder :: Decoder StateTransitionTable +stateTransitionTableDecoder = STT . H.fromList . concatMap collect <$> list ( record - ( pack5 <$> field "events" (list eventType) - <*> field "from" (list stateType) - <*> field "to" stateType - <*> field "hooks" (list hookType) + ( pack5 <$> field "events" (list eventDecoder) + <*> field "from" (list stateDecoder) + <*> field "to" stateDecoder + <*> field "hooks" (list hookDecoder) ) ) where @@ -194,8 +194,8 @@ newtype Color = Color Text deriving (Show, Eq, Generic) -colorType :: Type Color -colorType = Color <$> strictText +colorDecoder :: Decoder Color +colorDecoder = Color <$> strictText data AbsolutePosition = AbsolutePosition { _apX :: Int, _apY :: Int } @@ -203,8 +203,8 @@ makeLenses ''AbsolutePosition -absolutePositionType :: Type AbsolutePosition -absolutePositionType = record $ +absolutePositionDecoder :: Decoder AbsolutePosition +absolutePositionDecoder = record $ AbsolutePosition <$> field "x" (fromIntegral <$> integer) <*> field "y" (fromIntegral <$> integer) @@ -232,8 +232,8 @@ P_BOTTOM deriving (Show, Eq, Generic) -positionType :: Type Position -positionType = union +positionDecoder :: Decoder Position +positionDecoder = union $ (XY <$> constructor "XY" xy) <> (P_RESET_Y <$ constructor "_RESET_Y" unit) <> (P_LOCK_X <$ constructor "_LOCK_X" unit) @@ -254,9 +254,9 @@ makeLenses ''ClickableArea -clickableAreaType :: Type ClickableArea -clickableAreaType = record $ - ClickableArea <$> field "button" buttonType +clickableAreaDecoder :: Decoder ClickableArea +clickableAreaDecoder = record $ + ClickableArea <$> field "button" buttonDecoder <*> field "command" strictText data Padding @@ -265,8 +265,8 @@ | PSides deriving (Show, Eq, Generic) -paddingType :: Type Padding -paddingType = union +paddingDecoder :: Decoder Padding +paddingDecoder = union $ (PLeft <$ constructor "Left" unit) <> (PRight <$ constructor "Right" unit) <> (PSides <$ constructor "Sides" unit) @@ -287,36 +287,36 @@ | OScope deriving (Show, Eq, Generic) -openingTagType :: Type OpeningTag -openingTagType = union - $ (OMarquee <$> constructor "Marquee" marqueeType) - <> (OSlider <$> constructor "Slider" sliderType) - <> (OFG <$> constructor "FG" colorType) - <> (OBG <$> constructor "BG" colorType) - <> (OP <$> constructor "P" positionType) - <> (OPA <$> constructor "PA" absolutePositionType) - <> (OCA <$> constructor "CA" clickableAreaType) +openingTagDecoder :: Decoder OpeningTag +openingTagDecoder = union + $ (OMarquee <$> constructor "Marquee" marqueeDecoder) + <> (OSlider <$> constructor "Slider" sliderDecoder) + <> (OFG <$> constructor "FG" colorDecoder) + <> (OBG <$> constructor "BG" colorDecoder) + <> (OP <$> constructor "P" positionDecoder) + <> (OPA <$> constructor "PA" absolutePositionDecoder) + <> (OCA <$> constructor "CA" clickableAreaDecoder) <> (OIB <$ constructor "IB" unit) - <> (uncurry OPadding <$> constructor "Padding" + <> (uncurry OPadding <$> constructor "Padding" ( record $ (,) <$> field "width" (fromIntegral <$> natural) - <*> field "padding" paddingType + <*> field "padding" paddingDecoder ) ) - <> (uncurry OTrim <$> constructor "Trim" + <> (uncurry OTrim <$> constructor "Trim" ( record $ (,) <$> field "width" (fromIntegral <$> natural) - <*> field "direction" directionType + <*> field "direction" directionDecoder ) ) <> (uncurry OAutomaton <$> constructor "Automaton" - ( record $ (,) <$> field "address" automatonAddressType - <*> field "stt" stateTransitionTableType + ( record $ (,) <$> field "address" automatonAddressDecoder + <*> field "stt" stateTransitionTableDecoder ) ) - <> (OStateMapKey <$> constructor "StateMapKey" stateType) + <> (OStateMapKey <$> constructor "StateMapKey" stateDecoder) <> (OScope <$ constructor "Scope" unit) data BarSettings @@ -335,8 +335,8 @@ makeLenses ''BarSettings -barSettingsType :: Type BarSettings -barSettingsType = record $ +barSettingsDecoder :: Decoder BarSettings +barSettingsDecoder = record $ BarSettings <$> field "monitor" (fromIntegral <$> natural) <*> field "extraArgs" (list string) <*> field "updateInterval" ((* 1000) . fromIntegral <$> natural) @@ -350,8 +350,8 @@ makeLenses ''ShapeSize -shapeSizeType :: Type ShapeSize -shapeSizeType = record $ +shapeSizeDecoder :: Decoder ShapeSize +shapeSizeDecoder = record $ ShapeSize <$> field "w" (fromIntegral <$> natural) <*> field "h" (fromIntegral <$> natural) @@ -363,8 +363,8 @@ makeLenses ''Variable -variableType :: Type Variable -variableType = record $ +variableDecoder :: Decoder Variable +variableDecoder = record $ Variable <$> field "name" strictText <*> field "value" strictText @@ -384,27 +384,27 @@ | TokDefine Variable deriving (Show, Eq, Generic) -tokenType :: Type Token -tokenType = union - $ (TokOpen <$> constructor "Open" openingTagType) +tokenDecoder :: Decoder Token +tokenDecoder = union + $ (TokOpen <$> constructor "Open" openingTagDecoder) <> (TokClose <$ constructor "Close" unit) <> (TokSeparator <$ constructor "Separator" unit) <> (TokTxt <$> constructor "Txt" strictText) - <> (TokSource <$> constructor "Source" sourceSettingsType) + <> (TokSource <$> constructor "Source" sourceSettingsDecoder) <> (TokMarkup <$> constructor "Markup" strictText) <> (TokI <$> constructor "I" strictText) - <> (TokR <$> constructor "R" shapeSizeType) - <> (TokRO <$> constructor "RO" shapeSizeType) + <> (TokR <$> constructor "R" shapeSizeDecoder) + <> (TokRO <$> constructor "RO" shapeSizeDecoder) <> (TokC <$> constructor "C" (fromIntegral <$> natural)) <> (TokCO <$> constructor "CO" (fromIntegral <$> natural)) - <> (TokCheck <$> constructor "Check" checkType) - <> (TokDefine <$> constructor "Define" variableType) + <> (TokCheck <$> constructor "Check" checkDecoder) + <> (TokDefine <$> constructor "Define" variableDecoder) -stateMapType :: Type (H.HashMap Text [Token]) -stateMapType = H.fromList <$> +stateMapDecoder :: Decoder (H.HashMap Text [Token]) +stateMapDecoder = H.fromList <$> list (record $ (,) <$> field "state" strictText - <*> field "bar" (list tokenType)) + <*> field "bar" (list tokenDecoder)) data Source = Source @@ -417,8 +417,8 @@ instance Hashable Source -sourceSettingsType :: Type Source -sourceSettingsType = record $ +sourceSettingsDecoder :: Decoder Source +sourceSettingsDecoder = record $ Source <$> field "updateInterval" (Dhall.maybe $ (* 1000) . fromIntegral <$> natural) <*> field "command" (list string) <*> field "input" strictText @@ -432,10 +432,10 @@ makeLenses ''Configuration -configurationType :: Type Configuration -configurationType = record $ - Configuration <$> field "bar" (list tokenType) - <*> field "settings" barSettingsType +configurationDecoder :: Decoder Configuration +configurationDecoder = record $ + Configuration <$> field "bar" (list tokenDecoder) + <*> field "settings" barSettingsDecoder data PluginMeta = PluginMeta { _pmName :: Text @@ -451,8 +451,8 @@ makeLenses ''PluginMeta -pluginMetaType :: Type PluginMeta -pluginMetaType = record $ +pluginMetaDecoder :: Decoder PluginMeta +pluginMetaDecoder = record $ PluginMeta <$> field "name" strictText <*> field "author" strictText <*> field "email" (Dhall.maybe strictText) diff --git a/src/DzenDhall/Event.hs b/src/DzenDhall/Event.hs --- a/src/DzenDhall/Event.hs +++ b/src/DzenDhall/Event.hs @@ -51,15 +51,15 @@ environment <- liftIO getEnvironment - liftIO $ runEffect $ do + liftIO $ runEffect do - fh <- lift $ handle handler $ do + fh <- lift $ handle handler do fh <- openFile namedPipe ReadWriteMode hSetBuffering fh LineBuffering pure fh for (P.fromHandle fh) \line -> do - lift $ do + lift do case parsePipeCommand line of @@ -75,7 +75,7 @@ Just (Click scope identifier) -> do whenJust (H.lookup identifier clickableAreas) $ \command -> do - void $ forkIO $ do + void $ forkIO do let emitter = barRuntime ^. brEmitterScript <> " " <> T.unpack scope @@ -119,7 +119,7 @@ -- Match "any" event. H.lookup (scope, Event "*", currentState) transitions - whenJust mbNext \(nextState, hooks) -> void $ forkIO $ do + whenJust mbNext \(nextState, hooks) -> void $ forkIO do let environment' = [ ( "EVENT" , T.unpack $ runRender event) @@ -142,7 +142,7 @@ -- Somethimes a transition is only added for its outside-world effects, -- and we can't distinguish between such a transition and a normal one. - when (isJust mbUnit) $ do + when (isJust mbUnit) do writeIORef barRef nextBar writeIORef stateRef nextState runStateVariableSetter barRuntime scope address nextState @@ -172,7 +172,7 @@ let binary = T.unpack $ head $ hook ^. hookCommand - -- ^ this is safe, because we checked the list for emptiness + -- this is safe, because we have checked the list for emptiness -- during validation. args = map T.unpack $ tail $ hook ^. hookCommand @@ -186,17 +186,14 @@ barRuntime ^. brSetterScript <> " " <> T.unpack scope process = - (proc binary args) { std_out = CreatePipe - , std_in = CreatePipe - , std_err = CreatePipe - , env = Just $ + (proc binary args) { env = Just $ [ ("EMIT", emitter) , ("SET", setter) , ("GET", getter) ] <> environment } - (exitCode, _stdOut, _stdErr) <- lift $ + (exitCode, _stdout, _stderr) <- lift $ readCreateProcessWithExitCode process (T.unpack input) when (exitCode /= ExitSuccess) $ throwMaybe diff --git a/src/DzenDhall/Extra.hs b/src/DzenDhall/Extra.hs --- a/src/DzenDhall/Extra.hs +++ b/src/DzenDhall/Extra.hs @@ -9,8 +9,6 @@ import Data.Text (Text) import Time.Types import System.Directory (findExecutable) -import Control.Concurrent.MVar -import Foreign.StablePtr nonNegative :: (Num a, Ord a) => a -> a @@ -84,9 +82,3 @@ isYes :: String -> Bool isYes response = response `elem` ["Y", "y", "Yes", "yes", ""] - -waitForever :: IO () -waitForever = do - m <- newEmptyMVar - _ <- newStablePtr m - takeMVar m diff --git a/src/DzenDhall/Runtime.hs b/src/DzenDhall/Runtime.hs --- a/src/DzenDhall/Runtime.hs +++ b/src/DzenDhall/Runtime.hs @@ -7,6 +7,7 @@ import Control.Monad import Control.Arrow +import Control.Concurrent.MVar import Data.Maybe import Dhall hiding (maybe) import Lens.Micro @@ -24,10 +25,11 @@ readRuntime args = do let dzenBinary = fromMaybe "dzen2" (args ^. mbDzenBinary) + exitMVar <- newEmptyMVar configDir <- maybe (getXdgDirectory XdgConfig "dzen-dhall") pure (args ^. mbConfigDir) exists <- doesDirectoryExist configDir - unless exists $ do + unless exists do putStrLn "Configuration directory does not exist, you should create it first by running `dzen-dhall init`." exitWith $ ExitFailure 2 @@ -38,7 +40,7 @@ configurations :: [Configuration] <- do (if args ^. explain == Explain then detailed - else id) $ inputFile (list configurationType) configFile + else id) $ inputFile (list configurationDecoder) configFile supportsANSI <- System.Console.ANSI.hSupportsANSI System.IO.stdout @@ -48,6 +50,7 @@ dzenBinary args supportsANSI + exitMVar -- | Create config directory and set file permissions. @@ -59,7 +62,7 @@ exists <- doesDirectoryExist configDir - when exists $ do + when exists do putStrLn $ "Configuration directory already exists: " <> configDir exitWith (ExitFailure 1) diff --git a/src/DzenDhall/Runtime/Data.hs b/src/DzenDhall/Runtime/Data.hs --- a/src/DzenDhall/Runtime/Data.hs +++ b/src/DzenDhall/Runtime/Data.hs @@ -5,10 +5,12 @@ import DzenDhall.Data import DzenDhall.Config hiding (Hook) +import Control.Concurrent.MVar import Data.IORef import Dhall hiding (maybe) import Lens.Micro.TH import System.IO +import System.Process (ProcessHandle) import qualified Data.HashMap.Strict as H apiVersion :: Int @@ -20,8 +22,9 @@ , _rtDzenBinary :: String , _rtArguments :: Arguments , _rtSupportsANSI :: Bool + , _rtExitMVar :: MVar () } - deriving (Eq, Show) + deriving (Eq) makeLenses ''Runtime @@ -90,7 +93,7 @@ , _brHandle :: Handle -- ^ A handle to write to. The value is either stdin of a @dzen2@ process or -- 'System.IO.stdout', if @--stdout@ flag is passed. + , _brDzenHandle :: Maybe ProcessHandle } - deriving (Eq, Show) makeLenses ''BarRuntime diff --git a/src/DzenDhall/Validation.hs b/src/DzenDhall/Validation.hs --- a/src/DzenDhall/Validation.hs +++ b/src/DzenDhall/Validation.hs @@ -38,7 +38,7 @@ filterOutAssertions :: [Token] -> [Token] -filterOutAssertions = filter $ \case +filterOutAssertions = filter \case TokCheck _ -> False _ -> True @@ -107,7 +107,7 @@ -- | Pretty-print errors. report :: [Error] -> Text report [] = "No errors." -report errors = mappend header $ foldMap ((<> "\n\n") . reportError) errors +report errors = header <> (foldMap ((<> "\n\n") . reportError) errors) where header = "Some errors encountered while trying to read the configuration:\n\n\n" diff --git a/test/DzenDhall/Test/Config.hs b/test/DzenDhall/Test/Config.hs --- a/test/DzenDhall/Test/Config.hs +++ b/test/DzenDhall/Test/Config.hs @@ -3,7 +3,7 @@ import DzenDhall.Config import Control.Monad -import Dhall +import Dhall hiding (void) import Lens.Micro import System.IO (FilePath) import Test.Tasty (TestTree, testGroup) @@ -47,8 +47,7 @@ ] ] -testFile :: (Eq a, Show a) => - Type a -> FilePath -> a -> TestTree +testFile :: (Eq a, Show a) => Decoder a -> FilePath -> a -> TestTree testFile ty file expected = Test.Tasty.HUnit.testCase (file <> " marshalling") $ do program <- Data.Text.IO.readFile file @@ -59,12 +58,12 @@ testOpeningTag :: TestTree testOpeningTag = - testFile (list openingTagType) "test/dhall/OpeningTag.dhall" + testFile (list openingTagDecoder) "test/dhall/OpeningTag.dhall" [ OMarquee (Marquee 2 3 False), OFG (Color "red"), OTrim 3 DRight ] testToken :: TestTree testToken = - testFile (list tokenType) "test/dhall/Token.dhall" + testFile (list tokenDecoder) "test/dhall/Token.dhall" [ TokOpen (OMarquee (Marquee 2 3 False)) , TokMarkup "raw" , TokSource (Source { updateInterval = Just 1000 @@ -77,7 +76,7 @@ testSource :: TestTree testSource = - testFile sourceSettingsType "test/dhall/Source.dhall" + testFile sourceSettingsDecoder "test/dhall/Source.dhall" Source { updateInterval = Just 1000 , command = [ "bash" ] , input = "echo hi" @@ -86,7 +85,7 @@ testMarquee :: TestTree testMarquee = - testFile marqueeType "test/dhall/Marquee.dhall" + testFile marqueeDecoder "test/dhall/Marquee.dhall" Marquee { _mqFramesPerChar = 2 , _mqWidth = 3 , _mqShouldWrap = False @@ -94,7 +93,7 @@ testButton :: TestTree testButton = - testFile (list buttonType) "test/dhall/Button.dhall" + testFile (list buttonDecoder) "test/dhall/Button.dhall" [ MouseLeft , MouseMiddle , MouseRight @@ -106,29 +105,29 @@ testPadding :: TestTree testPadding = - testFile (list paddingType) "test/dhall/Padding.dhall" + testFile (list paddingDecoder) "test/dhall/Padding.dhall" [ PLeft, PRight, PSides ] testEvent :: TestTree testEvent = - testFile (list eventType) "test/dhall/Event.dhall" + testFile (list eventDecoder) "test/dhall/Event.dhall" [ Event "some text" ] testCheck :: TestTree testCheck = - testFile (list checkType) "test/dhall/Check.dhall" + testFile (list checkDecoder) "test/dhall/Check.dhall" [ Check "" $ SuccessfulExit "" , Check "" $ BinaryInPath "" ] testFade :: TestTree testFade = - testFile fadeType "test/dhall/Fade.dhall" (Fade VUp 3 4) + testFile fadeDecoder "test/dhall/Fade.dhall" (Fade VUp 3 4) testBarSettings :: TestTree testBarSettings = - testFile barSettingsType "test/dhall/Settings.dhall" + testFile barSettingsDecoder "test/dhall/Settings.dhall" BarSettings { _bsMonitor = 1 , _bsExtraArgs = [ "-l", "10" ] , _bsUpdateInterval = 250000 @@ -138,7 +137,7 @@ testConfiguration :: TestTree testConfiguration = - testFile (list configurationType) "test/dhall/Configuration.dhall" + testFile (list configurationDecoder) "test/dhall/Configuration.dhall" [ Configuration { _cfgBarTokens = [ TokClose ] , _cfgBarSettings = BarSettings { _bsMonitor = 1 , _bsExtraArgs = [ "-l", "10" ] @@ -151,7 +150,7 @@ testStateTransitionTable :: TestTree testStateTransitionTable = - testFile stateTransitionTableType "test/dhall/StateTransitionTable.dhall" $ + testFile stateTransitionTableDecoder "test/dhall/StateTransitionTable.dhall" $ STT ( H.fromList [ (("", Event "A", "" ), ("1", [])) , (("", Event "B", "" ), ("1", [])) , (("", Event "A", "1"), ("2", [])) @@ -163,7 +162,7 @@ testPluginMeta :: TestTree testPluginMeta = - testFile pluginMetaType "test/dhall/PluginMeta.dhall" $ + testFile pluginMetaDecoder "test/dhall/PluginMeta.dhall" $ PluginMeta "1" "2" (Just "3") (Just "4") (Just "5") "6" "7" 8 -- These tests assert succesful input reading (i.e. that "contracts" (in dhall terminology) @@ -175,4 +174,4 @@ program <- Data.Text.IO.readFile file void $ inputWithSettings (defaultInputSettings & rootDirectory .~ dhallDir) - (list configurationType) program + (list configurationDecoder) program