dzen-dhall 1.0.1 → 1.0.2
raw patch · 17 files changed
+263/−204 lines, 17 filesdep ~dhall
Dependency ranges changed: dhall
Files
- CHANGELOG.md +10/−2
- README.md +8/−8
- dzen-dhall.cabal +6/−6
- src/DzenDhall.hs +11/−6
- src/DzenDhall/App.hs +12/−5
- src/DzenDhall/App/Forked.hs +14/−1
- src/DzenDhall/App/Run.hs +18/−8
- src/DzenDhall/App/StartingUp.hs +52/−36
- src/DzenDhall/Arguments.hs +6/−0
- src/DzenDhall/Commands/Plug.hs +2/−2
- src/DzenDhall/Config.hs +86/−86
- src/DzenDhall/Event.hs +9/−12
- src/DzenDhall/Extra.hs +0/−8
- src/DzenDhall/Runtime.hs +6/−3
- src/DzenDhall/Runtime/Data.hs +5/−2
- src/DzenDhall/Validation.hs +2/−2
- test/DzenDhall/Test/Config.hs +16/−17
CHANGELOG.md view
@@ -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.
README.md view
@@ -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.
dzen-dhall.cabal view
@@ -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 <klntsky@gmail.com>-maintainer: Kalnitsky Vladimir <klntsky@gmail.com>+author: Vladimir Kalnitsky <klntsky@gmail.com>+maintainer: Vladimir Kalnitsky <klntsky@gmail.com> 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
src/DzenDhall.hs view
@@ -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
src/DzenDhall/App.hs view
@@ -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)
src/DzenDhall/App/Forked.hs view
@@ -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
src/DzenDhall/App/Run.hs view
@@ -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
src/DzenDhall/App/StartingUp.hs view
@@ -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
src/DzenDhall/Arguments.hs view
@@ -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" ) ) ) )
src/DzenDhall/Commands/Plug.hs view
@@ -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)
src/DzenDhall/Config.hs view
@@ -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)
src/DzenDhall/Event.hs view
@@ -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
src/DzenDhall/Extra.hs view
@@ -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
src/DzenDhall/Runtime.hs view
@@ -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)
src/DzenDhall/Runtime/Data.hs view
@@ -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
src/DzenDhall/Validation.hs view
@@ -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"
test/DzenDhall/Test/Config.hs view
@@ -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