diff --git a/exe/Echo.hs b/exe/Echo.hs --- a/exe/Echo.hs +++ b/exe/Echo.hs @@ -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 diff --git a/lib/Positive32/XNobar/Internal/Positive32.hs b/lib/Positive32/XNobar/Internal/Positive32.hs --- a/lib/Positive32/XNobar/Internal/Positive32.hs +++ b/lib/Positive32/XNobar/Internal/Positive32.hs @@ -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 diff --git a/lib/Scroller/XNobar/Internal/Scroller.hs b/lib/Scroller/XNobar/Internal/Scroller.hs --- a/lib/Scroller/XNobar/Internal/Scroller.hs +++ b/lib/Scroller/XNobar/Internal/Scroller.hs @@ -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 "" "" +red :: String -> String +red = wrap "" "" + attachAction a b = wrap ("") "" 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 ("") "" 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 ("") "" 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 ++ " " diff --git a/lib/Scroller/XNobar/Scroller.hs b/lib/Scroller/XNobar/Scroller.hs --- a/lib/Scroller/XNobar/Scroller.hs +++ b/lib/Scroller/XNobar/Scroller.hs @@ -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 diff --git a/lib/Server/XNobar/Server.hs b/lib/Server/XNobar/Server.hs --- a/lib/Server/XNobar/Server.hs +++ b/lib/Server/XNobar/Server.hs @@ -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 diff --git a/lib/XNobar/XNobar.hs b/lib/XNobar/XNobar.hs --- a/lib/XNobar/XNobar.hs +++ b/lib/XNobar/XNobar.hs @@ -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 ["", "", "", diff --git a/xnobar.cabal b/xnobar.cabal --- a/xnobar.cabal +++ b/xnobar.cabal @@ -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