xnobar 1.0.0.0 → 1.0.0.1
raw patch · 7 files changed
+134/−93 lines, 7 filesdep ~dbusdep ~extradep ~flownew-component:exe:echo
Dependency ranges changed: dbus, extra, flow, xmobar
Files
- exe/Echo.hs +5/−2
- lib/Positive32/XNobar/Internal/Positive32.hs +4/−6
- lib/Scroller/XNobar/Internal/Scroller.hs +76/−45
- lib/Scroller/XNobar/Scroller.hs +8/−4
- lib/Server/XNobar/Server.hs +14/−13
- lib/XNobar/XNobar.hs +5/−2
- xnobar.cabal +22/−21
exe/Echo.hs view
@@ -1,8 +1,11 @@+import Control.Concurrent (threadDelay) import Control.Exception (finally) import Control.Monad (forever)+import Data.Bifunctor (first)+import Data.Semigroup (Max(getMax))+import XNobar.Internal.Positive32 (Positive32(toWord32)) import XNobar.Internal.Scroller () -- import Show instance for XNobar.Internal.Notification.Notification import XNobar.Server (fetch, startServer)-import Control.Concurrent (threadDelay) main :: IO () main = do@@ -13,4 +16,4 @@ forever $ do ns <- fetch notifs threadDelay 100000- print $ show . snd <$> ns+ print $ first (getMax . toWord32) <$> ns
lib/Positive32/XNobar/Internal/Positive32.hs view
@@ -6,26 +6,24 @@ import Text.ParserCombinators.ReadP -- |Bare-bone non-zero version of [Data.Word.Word32](https://hackage.haskell.org/package/base-4.20.0.1/docs/Data-Word.html#t:Word32)--- that implements the [Data.Semigroup.Max](https://hackage.haskell.org/package/base-4.19.1.0/docs/Data-Semigroup.html#t:Max)--- typeclass.+-- that wraps around back to 1 after `maxBound` and implements the+-- [Data.Semigroup.Max](https://hackage.haskell.org/package/base-4.19.1.0/docs/Data-Semigroup.html#t:Max) typeclass. newtype Positive32 = Positive32 { toWord32 :: Max Word32 } deriving (Eq, Ord, Semigroup, Show) instance Monoid Positive32 where mempty = Positive32 1 instance Bounded Positive32 where- minBound = Positive32 1+ minBound = mempty maxBound = Positive32 (maxBound :: Max Word32) instance Enum Positive32 where toEnum = error "toEnum is not meant to be used" fromEnum = error "fromEnum is not meant to be used"+ pred = error "pred is not meant to be used" succ p@(Positive32 i) | p == maxBound = Positive32 1 | otherwise = Positive32 $ succ i- pred p@(Positive32 i) -- Not really meant to be used, but let's define it...- | p == minBound = maxBound- | otherwise = Positive32 $ pred i -- |Smart ctor from [Data.Word.Word32](https://hackage.haskell.org/package/base-4.20.0.1/docs/Data-Word.html#t:Word32). positive32 :: Word32 -> Positive32
lib/Scroller/XNobar/Internal/Scroller.hs view
@@ -3,10 +3,10 @@ import Control.Arrow ((&&&)) import Data.Function ((&))-import Data.List (genericLength)+import Data.List (genericLength, partition) import Data.List.Extra (groupOn) import Data.Semigroup (Max(Max))-import Data.Tuple.Extra (first, second, third3)+import Data.Tuple.Extra (both, first, second, third3) import Flow ((.>)) import XNobar.Internal.Notification (Notification(..), urgency, Id)@@ -35,71 +35,102 @@ scroll Nothing = Nothing scroll (Just (i, o, notifs)) = let notifs' = cycle notifs & dropWhile (theId .> (/= i)) (i', n') = head notifs'- (i'', n'') = notifs' !! 1- in Just (if o < genericLength (show n') - 1- then (i', o + 1, notifs)- else (i'', 0, notifs))+ (i'', _) = notifs' !! 1+ in Just $ if o < genericLength (show n') - 1+ then (i', o + 1, notifs)+ else (i'', 0, notifs) -enableClick p ((Max i, u), s) = attachAction ("echo -n " ++ show i ++ " > " ++ p)- 1+enableClick p ((Max i, u), s) = attachAction ("echo -n 0 > " ++ p) 3+ $ attachAction ("echo -n " ++ show i ++ " > " ++ p) 1 ((if u == 2 then red else id) s)- where- red = wrap "<fc=#ff0000>" "</fc>" +red :: String -> String+red = wrap "<fc=#ff0000>" "</fc>"+ attachAction a b = wrap ("<action=`" ++ a ++ "` button=" ++ show b ++ ">") "</action>" wrap a c b = a ++ b ++ c -- TODO: probably Offset should be a class+-- TODO: The first arugment could be a `NonEmpty` list merge :: [(Id, n)] -> Maybe (Id, Offset, [(Id, n)]) -> Maybe (Id, Offset, [(Id, n)])+merge [] _ = error "This should not be possible!" merge news Nothing = Just (theId $ head news, 0, news) merge news (Just olds) = Just $ third3 (`combine` news) olds -remove :: Num offset => Id -> Maybe (Id, offset, [(Id, n)]) -> Maybe (Id, offset, [(Id, n)])-remove _ Nothing = error "This should not be possible!"-remove _ (Just (_, _, [])) = error "This should not be possible!"-remove i (Just (i', _, [_])) = if i /= i'+remove :: Num offset+ => Maybe Id -> Maybe (Id, offset, [(Id, Notification)])+ -> Maybe (Id, offset, [(Id, Notification)])+remove Nothing Nothing = error "This should not be possible!"+remove Nothing (Just (_, _, [])) = error "This should not be possible!"+remove Nothing (Just (_, _, ns)) = let (u:us) = map (urgency . snd) ns+ in case partition ((== 2) . urgency . snd) ns of+ (urgent@((i, _):_), _:_) -> Just (i, 0, urgent)+ _ -> Nothing+remove (Just _) Nothing = error "This should not be possible!"+remove (Just _) (Just (_, _, [])) = error "This should not be possible!"+remove (Just i) (Just (i', _, [_])) = if i /= i' then error "This should not be possible!" else Nothing-remove i (Just (i', o, ns)) = let l = length ns- (b, a) = second tail $ break ((== i) . theId) $ cycle ns- ns' = take (l - 1) $ b ++ a- newCurr = head $ if null a then b else a+remove (Just i) (Just (i', o, ns)) = let l = length ns+ (b, a) = second tail $ break ((== i) . theId) $ cycle ns+ ns' = take (l - 1) $ b ++ a+ newCurr = head $ if null a then b else a in Just (if i == i' then (theId newCurr, 0, ns') else (i', o, ns')) combine :: [(Id, n)] -> [(Id, n)] -> [(Id, n)]-combine olds news = let olds' = olds `suchThat` (theId .> (not . (`elem` (theId <$> news))))- in olds' <> news+combine olds news = olds' <> news where- suchThat = flip filter--onlyIf b a = if b then a else id+ olds' = filter (theId .> (not . (`elem` (theId <$> news)))) olds -showNotifs :: Config -> [Char] -> (Id, Int, [(Id, Notification)]) -> [Char]-showNotifs (Config{..})- pipe- (curId, curOffset, oldNotifs') =- oldNotifs' & cycle- & dropWhile (theId .> (/= curId))- & concatMap (((theId &&& getNotif .> urgency) &&& getNotif .> showNotif) .> spreadChars)- & drop curOffset- & take marqueeLength- & groupOn theId- & concatMap (joinChars .> toWord32' .> enableClick pipe .> niceLineBreak)- & (newsPrefix ++)- & (`withFont` fontNumber)- where- t `withFont` f = wrap ("<fn=" ++ show f ++ ">") "</fn>" t- getNotif = snd- toWord32' = first (first toWord32)- spreadChars = sequence- joinChars l = (theId (head l), map getNotif l)- niceLineBreak = (=<<) (\c -> if c `elem` ['\r', '\n'] then lineBreak else pure c)- showNotif n = let emoji = if urgency n /= 2 then nonCriticalPrefix else criticalPrefix- in emoji ++ show n+showNotifs :: Config -> String -> (Id, Offset, [(Id, Notification)]) -> String+showNotifs (Config{..}) pipe (curId, curOffset, oldNotifs) =+ oldNotifs+ -- repeat notifications indefinitely+ & cycle+ -- drop until current notification+ & dropWhile (theId .> (/= curId))+ -- decompose notifications in individual characters (keeping id and urgency attached)+ & (>>= ((theId &&& getUrgency) &&& showNotif) .> sequence)+ -- drop characters that have already flowed beyond the left border+ & drop curOffset+ --- retain only as many characters as required+ & take marqueeLength+ -- re-group according to ID+ & groupOn theId+ -- re-join characters into notifications+ & fmap (joinChars .> toWord32')+ -- encode the click+ & (>>= enableClick pipe)+ -- render line breaks nicely+ & (>>= niceLineBreak)+ -- prepend number of notifications (if ≥ 2)+ & case both length (partition ((== 2) . urgency . snd) oldNotifs) of+ (n1, n2) | n1 + n2 == 1 -> id+ | n1 == 0 -> (wrap "(" ") " (show n2) ++)+ | n2 == 0 -> (wrap "(" ") " (red $ show n1) ++)+ | otherwise -> (wrap "(" ") " (red (show n1) ++ '+':show n2) ++)+ -- prepend prefix for news+ & (newsPrefix ++)+ -- apply font+ & (`withFont` fontNumber)+ where+ t `withFont` f = wrap ("<fn=" ++ show f ++ ">") "</fn>" t+ getNotif = snd+ getUrgency = getNotif .> urgency+ toWord32' = first (first toWord32)+ joinChars l = (theId (head l), map getNotif l)+ niceLineBreak c = if c `elem` ['\r', '\n']+ then lineBreak+ else pure c+ showNotif n = let notif = getNotif n+ emoji = if urgency notif == 2+ then criticalPrefix+ else nonCriticalPrefix+ in emoji ++ show notif instance Show Notification where show n = summary n ++ maybeBody ++ " "
lib/Scroller/XNobar/Scroller.hs view
@@ -14,19 +14,19 @@ import System.Process (readProcessWithExitCode) import XNobar.Internal.Notification (makeId)-import XNobar.Internal.Scroller (onlyIf, remove, merge, scroll, showNotifs, Config(..))+import XNobar.Internal.Scroller (remove, merge, scroll, showNotifs, Config(..)) import XNobar.Server (NotificationsRef, fetch) import Control.Concurrent (threadDelay) scroller :: Config -> (String -> IO ()) -> NotificationsRef -> IO () scroller config@(Config{..}) callback notifs = do- clicked <- newIORef Nothing (_, n, _) <- readProcessWithExitCode "uuidgen" [] "" let pipe = "/tmp/xnobar-" ++ removeLinebreak n where removeLinebreak = init (_, _, _) <- readProcessWithExitCode "mkfifo" [pipe] ""+ clicked <- newIORef Nothing withAsync (forever $ do out <- withFileBlocking pipe ReadMode hGetContents' atomicModifyIORef' clicked (const (Just out, ())))- (const $ evalStateT (forever (update clicked pipe)) Nothing)+ (const $ evalStateT (forever $ update clicked pipe) Nothing) `finally` removeFile pipe where update clicked pipe = do@@ -49,5 +49,9 @@ liftIO $ tenthSeconds scrollPeriod where clear = (`atomicModifyIORef'` const (Nothing, ()))- getId = makeId . read+ getId i = let i' = read i+ in if i' == 0+ then Nothing+ else Just $ makeId i' tenthSeconds = threadDelay . (100000*)+ onlyIf b a = if b then a else id
lib/Server/XNobar/Server.hs view
@@ -37,7 +37,7 @@ module XNobar.Server (startServer, NotificationsRef, fetch) where import Control.Monad (when)-import Control.Monad.IO.Class (liftIO)+import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.Trans.Reader (ReaderT) import Control.Monad.Trans.State.Lazy (StateT, get, modify', runStateT) import DBus@@ -81,14 +81,14 @@ let busName = "org.freedesktop.Notifications" reply <- requestName client busName [nameDoNotQueue] notifications <- initNotifs- notify <- state2IORef+ notify <- evalStateInIO (statefulNotify notifications) mempty let objPath = "/org/freedesktop/Notifications" export client objPath defaultInterface { interfaceName = "org.freedesktop.Notifications", interfaceMethods = [ autoMethod "GetServerInformation" getServerInformation, autoMethod "GetCapabilities" getCapabilities,- makeMethod "Notify" (signature_ notifyInSig) (signature_ notifyOutSig) (notify notifications)+ makeMethod "Notify" (signature_ notifyInSig) (signature_ notifyOutSig) notify ] } return $ if reply == NamePrimaryOwner@@ -105,8 +105,9 @@ fetch ns = atomicModifyIORef' (notifs ns) (const mempty &&& id) {- Server's interface functions -}-notify :: NotificationsRef -> MethodCall -> StateT (Id, CapId) (ReaderT Client IO) Reply-notify ns mCall = do+statefulNotify :: MonadIO m+ => NotificationsRef -> MethodCall -> StateT (Id, CapId) (ReaderT Client m) Reply+statefulNotify ns mCall = do (currId, maxId) <- get let (reqId, notif) = parseNotif $ methodCallBody mCall when (reqId >= unwrap maxId)@@ -130,12 +131,12 @@ getCapabilities :: IO [String] getCapabilities = return [ "body", "persistence" ] --- TODO: See if this can be generalized-state2IORef :: IO (NotificationsRef -> MethodCall -> ReaderT Client IO Reply)-state2IORef = do- sref <- newIORef mempty- return $ \ns m -> do- s <- liftIO $ readIORef sref- (r, s') <- runStateT (notify ns m) s- liftIO $ writeIORef sref s'+-- Convert a StateT computation to the underlaying IO-powered monadic stack,+-- using an IORef to manage the state.+evalStateInIO :: MonadIO m => (a -> StateT s m c) -> s -> IO (a -> m c)+evalStateInIO statefulComp s0 = do+ s0ref <- liftIO $ newIORef s0+ return $ \a -> do+ (r, s) <- runStateT (statefulComp a) =<< liftIO (readIORef s0ref)+ liftIO $ writeIORef s0ref s pure r
lib/XNobar/XNobar.hs view
@@ -10,7 +10,10 @@ -- a [marquee](https://en.wikipedia.org/wiki/Marquee_element) as they come, -- with a default text if there's no notification to show. ----- A single click on the marquee will dismiss the notification on which the click happened.+-- Left clicking on the marquee will dismiss the notification on which the+-- click happened. Right clicking will dismiss all notifications if they are+-- all urgent or all non-urgent, otherwise it will dismiss all the non-urgent,+-- leaving all the urgent ones be. -- -- The present module can be thought of as the front-end part of the notifications server, -- 'XNobar.Server' being the back-end.@@ -57,7 +60,7 @@ instance Exec Config where alias _ = "XNobar" start config cb- = startServer >>= \case Right notifs -> do scroller config cb notifs+ = startServer >>= \case Right notifs -> scroller config cb notifs Left reply -> cb $ unwords ["<action=`xdg-open ", docUrl, "`>", "<fc=#FF0000>", "<box type=Bottom width=3 color=red>",
xnobar.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.4 name: xnobar-version: 1.0.0.0+version: 1.0.0.1 maintainer: Enrico Maria De Angelis homepage: https://codeberg.org/Aster89/xnobar synopsis: Text-based notification server for XMobar@@ -10,7 +10,7 @@ source-repository head type: git- location: git://codeberg.org/Aster89/xnobar.git+ location: https://codeberg.org/Aster89/xnobar.git branch: master common common@@ -21,19 +21,20 @@ import: common exposed-modules: XNobar build-depends: xmobar >= 0.48.1 && <= 0.51- , xnobar:Server- , xnobar:Scroller+ , xnobar:server+ , xnobar:scroller hs-source-dirs: lib/XNobar -executable Echo+executable echo import: common- build-depends: xnobar:Server- , xnobar:Scroller+ build-depends: xnobar:positive32+ , xnobar:scroller+ , xnobar:server , xmobar >= 0.48.1 && <= 0.51 hs-source-dirs: exe main-is: Echo.hs -library Server+library server import: common visibility: public exposed-modules: XNobar.Server@@ -41,20 +42,20 @@ , extra >= 1.7.16 && <= 1.8 , flow >= 2.0.0 && < 2.1 , transformers >= 0.6.1 && < 0.7- , xnobar:Notification- , xnobar:Positive32+ , xnobar:notification+ , xnobar:positive32 hs-source-dirs: lib/Server -library Notification+library notification import: common exposed-modules: XNobar.Internal.Notification build-depends: containers >= 0.6.8 && < 0.9 , dbus >= 1.3.6 && < 1.5 , flow >= 2.0.0 && < 2.1- , xnobar:Positive32+ , xnobar:positive32 hs-source-dirs: lib/Notification -library Scroller+library scroller import: common exposed-modules: XNobar.Scroller, XNobar.Internal.Scroller build-depends: async >= 2.2.5 && < 2.3@@ -64,23 +65,23 @@ , mtl >= 2.3.1 && < 2.4 , process >= 1.6.18 && < 1.7 , xmobar >= 0.48.1 && <= 0.51- , xnobar:Notification- , xnobar:Positive32- , xnobar:Server+ , xnobar:notification+ , xnobar:positive32+ , xnobar:server hs-source-dirs: lib/Scroller -library Positive32+library positive32 import: common exposed-modules: XNobar.Internal.Positive32 hs-source-dirs: lib/Positive32 -test-suite Test+test-suite test import: common type: exitcode-stdio-1.0 main-is: Main.hs build-depends: QuickCheck , extra >= 1.7.16 && <= 1.8- , xnobar:Notification- , xnobar:Positive32- , xnobar:Scroller+ , xnobar:notification+ , xnobar:positive32+ , xnobar:scroller hs-source-dirs: test