diff --git a/lib/Notification/XNobar/Internal/Notification.hs b/lib/Notification/XNobar/Internal/Notification.hs new file mode 100644 --- /dev/null +++ b/lib/Notification/XNobar/Internal/Notification.hs @@ -0,0 +1,88 @@ +module XNobar.Internal.Notification ( + CapId, + uncap, + Id, + makeId, + Notification(..), + urgency, + NotificationsById, + append, + parseNotif, + notifyInSig, + notifyOutSig +) where + +import DBus (Variant, fromVariant, Type(..)) +import Data.Int (Int32) +import Data.Map.Strict hiding (filter) +import Data.Maybe (fromJust, fromMaybe) +import Data.Semigroup (Max) +import Data.Word (Word8, Word32) +import Flow ((.>)) +import Prelude hiding (String, lookup) +import qualified Prelude as P (String) + +import XNobar.Internal.Positive32 + +type String = P.String -- in case I want to change type +type Id = Positive32 +makeId = positive32 + +newtype CapId = CapId { uncap :: Max Id } deriving (Eq, Ord, Bounded, Semigroup, Monoid) + +instance Enum CapId where + toEnum = error "Not meant to be used" + fromEnum = error "Not meant to be used" + pred = error "Not meant to be used" + succ c@(CapId i) + | i == maxBound = c + | otherwise = CapId $ succ i + +notifyInSig = [ + TypeString, + TypeWord32, + TypeString, + TypeString, + TypeString, + TypeArray TypeString, + TypeDictionary TypeString TypeString, + TypeInt32 + ] + +notifyOutSig = [TypeWord32] + +data Notification = Notification { + appName :: !String, + appIcon :: !String, + summary :: !String, + body :: !String, + actions :: ![String], + hints :: !(Map String Variant), + expireTout :: !Int32 +} + +urgency :: Notification -> Word8 +urgency n = let u = lookup "urgency" (hints n) + in case u of + Nothing -> 0 + (Just x) -> fromMaybe 0 (fromVariant x) + +parseNotif :: [Variant] -> (Word32, Notification) +parseNotif [name, rid, icon, summary, body, actions, hints, expire] + = (fromJust $ fromVariant rid, + Notification (fromJust $ fromVariant name) + (fromJust $ fromVariant icon) + (fromJust $ fromVariant summary) + (fromJust $ fromVariant body) + (fromJust $ fromVariant actions) + (fromJust $ fromVariant hints) + (fromJust $ fromVariant expire)) +parseNotif _ = error "WTF, something went wrong with DBus?" + +type NotificationsById = [(Id, Notification)] + +append :: Eq i => [(i, n)] -> (i, n) -> [(i, n)] +ns `append` n = let ns' = filter (theId .> (/= theId n)) ns + in ns' <> [n] + where + theId = fst diff --git a/lib/Positive32/XNobar/Internal/Positive32.hs b/lib/Positive32/XNobar/Internal/Positive32.hs new file mode 100644 --- /dev/null +++ b/lib/Positive32/XNobar/Internal/Positive32.hs @@ -0,0 +1,33 @@ +module XNobar.Internal.Positive32 (Positive32, positive32, toWord32) where + +import Data.Char (isDigit) +import Data.Word (Word32) +import Data.Semigroup (Max(Max)) +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. +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 + 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" + 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 +positive32 0 = error "Attempt to create `Positive32` from `0`" +positive32 i = Positive32 $ Max i diff --git a/lib/Scroller/XNobar/Internal/Scroller.hs b/lib/Scroller/XNobar/Internal/Scroller.hs new file mode 100644 --- /dev/null +++ b/lib/Scroller/XNobar/Internal/Scroller.hs @@ -0,0 +1,114 @@ +module XNobar.Internal.Scroller where + +import Control.Arrow ((&&&)) +import Data.Function ((&)) +import Data.List (genericLength) +import Data.List.Extra (groupOn) +import Data.Semigroup (Max(Max)) +import Data.Tuple.Extra (first, second, third3) +import Flow ((.>)) + +import XNobar.Internal.Notification (Notification(..), urgency, Id) +import XNobar.Internal.Positive32 (toWord32) + +type Offset = Int + +-- |Configuration. In fact, this is the way to instantiate and customize the plugin, +-- but it's just more practical to use 'xNobar', as it sets some decent default values. +data Config = Config { + idleText :: !String -- ^ Default string (to be shown steady) when no notification is left. + , marqueeLength :: !Int -- ^ Width (in number of characters) of the scrolling marquee (this is unrelated ot the length of the first argument). + , fontNumber :: !Int -- ^ Number of the font used for notifications, as per xmobar config (it's not applied to the idleText). + , scrollPeriod :: !Int -- ^ Scrolling rate (in tenths of seconds per character). + , noNewsPrefix :: !String -- ^ Prefix to the idleText. + , newsPrefix :: !String -- ^ Prefix to the scrolling marquee. + , criticalPrefix :: !String -- ^ Prefix to the critical nontification. + , nonCriticalPrefix :: !String -- ^ Prefix to the non-critical nontification. + , lineBreak :: !String -- ^ String to render a line break. + } deriving (Read, -- ^ For integration with [XMobar](https://codeberg.org/xmobar/xmobar). + Show) -- ^ For integration with [XMobar](https://codeberg.org/xmobar/xmobar). + +theId = fst + +scroll :: (Show n) => Maybe (Id, Offset, [(Id, n)]) -> Maybe (Id, Offset, [(Id, n)]) +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)) + +enableClick p ((Max i, u), s) = attachAction ("echo " ++ show i ++ " > " ++ p) + 1 + ((if u == 2 then red else id) s) + where + red = wrap "" "" + +attachAction a b = wrap ("") + "" + +wrap a c b = a ++ b ++ c + +-- TODO: probably Offset should be a class +merge :: [(Id, n)] -> Maybe (Id, Offset, [(Id, n)]) -> Maybe (Id, Offset, [(Id, n)]) +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' + 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 + 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 + where + suchThat = flip filter + +onlyIf b a = if b then a else id + +showNotifs :: Config -> [Char] -> (Id, Int, [(Id, Notification)]) -> [Char] +showNotifs (Config { fontNumber = fontNumber + , lineBreak = lineBreak + , newsPrefix = newsPrefix + , marqueeLength = marqueeLength + , criticalPrefix = criticalPrefix + , nonCriticalPrefix = nonCriticalPrefix + }) + 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 + +instance Show Notification where + show n = summary n ++ maybeBody ++ " " + where + maybeBody = if not $ null $ body n + then " | " ++ body n + else "" diff --git a/lib/Scroller/XNobar/Scroller.hs b/lib/Scroller/XNobar/Scroller.hs new file mode 100644 --- /dev/null +++ b/lib/Scroller/XNobar/Scroller.hs @@ -0,0 +1,78 @@ +module XNobar.Scroller (scroller, Config(..)) where + +import Control.Concurrent.Async (withAsync) +import Control.Exception (finally) +import Control.Monad (when) +import Control.Monad.State.Strict (evalStateT, forever, get, liftIO, modify') +import Data.IORef (atomicModifyIORef', newIORef, readIORef, IORef) +import Data.Maybe (fromJust, isJust, maybe) +import Flow ((.>)) +import System.Directory (removeFile) +import System.Exit (ExitCode(..)) +import System.Process (readProcessWithExitCode) +import Xmobar (tenthSeconds) + +import XNobar.Internal.Notification (makeId) +import XNobar.Internal.Scroller (onlyIf, remove, merge, scroll, showNotifs, Config(..)) +import XNobar.Server (NotificationsRef, fetch) +import Control.Monad.IO.Class (MonadIO) + +scroller :: Config -> (String -> IO ()) -> NotificationsRef -> IO () +scroller config@(Config { idleText = idleText + , marqueeLength = marqueeLength + , fontNumber = fontNumber + , scrollPeriod = scrollPeriod + , noNewsPrefix = noNewsPrefix + , newsPrefix = newsPrefix + , lineBreak = lineBreak }) + callback + notifs = withIOState + (\clicked pipe -> const $ evalStateT (forever (update clicked pipe)) Nothing) + where + removeLinebreak = init + update clicked pipe = do + + newNotifs <- liftIO $ fetch notifs + + clicked' <- readIOState clicked + + when (isJust clicked') $ clearIOState clicked + + modify' $ onlyIf (isJust clicked') + (remove (getId $ fromJust clicked')) + .> onlyIf (not $ null newNotifs) + (merge newNotifs) + .> scroll + + get >>= maybe (noNewsPrefix ++ idleText) (showNotifs config pipe) + .> (liftIO . callback) + + liftIO $ tenthSeconds scrollPeriod + where + clear = (`atomicModifyIORef'` const (Nothing, ())) + getId = makeId . read + + +newtype IOState a = IOState (IORef a) + +readIOState :: MonadIO m => IOState a -> m a +readIOState (IOState ref) = liftIO $ readIORef ref + +clearIOState :: (MonadIO m, Monoid a) => IOState a -> m () +clearIOState (IOState ref) = liftIO $ clear ref + where + clear = (`atomicModifyIORef'` const (mempty, ())) + +withIOState f = do + clicked <- newIORef Nothing + (_, n, _) <- readProcessWithExitCode "uuidgen" [] "" + let pipe = "/tmp/xnobar-" ++ removeLinebreak n + (_, _, _) <- readProcessWithExitCode "mkfifo" [pipe] "" + withAsync (forever $ do (ret, out, _) <- readProcessWithExitCode "cat" [pipe] "" + case ret of + ExitSuccess -> atomicModifyIORef' clicked (const (Just (removeLinebreak out), ())) + ExitFailure _ -> error "how is this possible?") + (f (IOState clicked) pipe) + `finally` removeFile pipe + where + removeLinebreak = init diff --git a/lib/Server/XNobar/Server.hs b/lib/Server/XNobar/Server.hs new file mode 100644 --- /dev/null +++ b/lib/Server/XNobar/Server.hs @@ -0,0 +1,139 @@ +-- | +-- = Back-end of the notification server +-- +-- 'XNobar' can be thought of the front-end of an XMobar-specific notification +-- server. The back-end, instead, is factored out in its own module, exposed as +-- the present 'XNobar.Server' library, which implements the notification sever +-- interface according to the [Desktop Notification +-- Specification](https://specifications.freedesktop.org/notification-spec/notification-spec-latest.html). +-- +-- This 'XNobar.Server' is not a notification server by itself, because it +-- does't take care of showing the notifications; instead, it dumps the +-- notifications in mutable reference that it returns when started. Howver, I +-- call it server, because here is where I implement the aforementioned +-- [DNS](https://specifications.freedesktop.org/notification-spec/notification-spec-latest.html). +-- +-- The caller can therefore start the "server back-end", get a hold on the +-- returned reference, inspect it periodically, and take action accordingly for +-- showing it, dismissing it, and so on. +-- +-- Another consequence of the fact that this server doesn't really show the +-- notifications is that it doesn't really make sense to talk of of some of the +-- capabilities as defined by the aforementioned +-- [DNS](https://specifications.freedesktop.org/notification-spec/notification-spec-latest.html), +-- for it. I've set as defined just 2 capabilities: +-- +-- - "body", because I'm not stripping away any part of the notification +-- when putting it in the mutable storage, so not even the body, +-- - "persistence", because, again, expiring the notifications is up to the client. +-- +-- The reason why the server is implemented this way is that it was always +-- meant to be the backbone of 'XNobar', which shows notifications in a +-- text-based scrolling marquee that scrolls character-by-character, that is, +-- something that needs to update every so often (say 10 times a second) +-- regardless of whether new notifications come or not, and doesn't really care +-- about the time of arrival of each notification. +{-# LANGUAGE OverloadedStrings #-} +module XNobar.Server (startServer, NotificationsRef, fetch) where + +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Reader (ReaderT) +import Control.Monad.Trans.State.Lazy (StateT, get, modify', runStateT) +import DBus +import DBus.Client +import Data.Bifunctor (bimap) +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) +import Data.Semigroup (Max(getMax)) +import Data.Tuple.Extra ((&&&)) +import Data.Word (Word32) +import Flow ((.>)) + +import XNobar.Internal.Notification (parseNotif, notifyInSig, notifyOutSig, Id, makeId, CapId, uncap, NotificationsById, Notification) +import XNobar.Internal.Positive32 (toWord32) +import qualified XNobar.Internal.Notification as N (append) + +-- |Mutable reference to the notifications. +-- +-- This is basically a 2-ends 1-way communication channel: +-- +-- - at one end, the notification server started by the caller via 'startServer' will insert new notifications +-- as it receives them, +-- - at the other end, the owner of the value returned by 'startServer' in the IO monad can extract the notifications +-- via 'fetch', atomically emptying the reference at the same time. +newtype NotificationsRef = NotificationsRef { notifs :: IORef NotificationsById } + +-- |Action that starts a notification server and returns maybe a mutable +-- reference to the notifications (or nothing if the server could not start for +-- any reason). +-- +-- @ +-- maybeNotifs <- startServer +-- case of maybeNotifs +-- Just notifs -> -- server has started and notitifcations will be pushed on notifs as they come +-- Nothing -> -- some error occurred and the server could not start +-- @ +-- +-- The caller can interact with the notitications only via 'fetch'. +startServer :: IO (Maybe NotificationsRef) +startServer = do + client <- connectSession + reply <- requestName client "org.freedesktop.Notifications" [nameDoNotQueue] + notifications <- initNotifs + notify <- state2IORef + export client "/org/freedesktop/Notifications" defaultInterface { + interfaceName = "org.freedesktop.Notifications", + interfaceMethods = [ + autoMethod "GetServerInformation" getServerInformation, + autoMethod "GetCapabilities" getCapabilities, + makeMethod "Notify" (signature_ notifyInSig) (signature_ notifyOutSig) (notify notifications) + ] + } + return $ if reply == NamePrimaryOwner + then Just notifications + else Nothing + where + initNotifs :: IO NotificationsRef + initNotifs = NotificationsRef <$> newIORef mempty + +-- |Extracts the notifications from the 'NotificationsRef' returned by +-- 'startServer', and empties the reference atomically. +fetch :: NotificationsRef -- ^ The 'IORef' extracted from the IO monad value returned by 'startServer' + -> IO NotificationsById -- ^ The notifications extracted from the first argument +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 + (currId, maxId) <- get + let (reqId, notif) = parseNotif $ methodCallBody mCall + when (reqId >= unwrap maxId) + $ error "Requested id of non-existent notification" + (assignedId, _) <- if reqId == 0 + then get + else return (makeId reqId, error "This should not be used") + when (reqId == 0) $ modify' (bimap succ succ) + liftIO $ append ns (assignedId, notif) + return $ ReplyReturn [toVariant $ getMax $ toWord32 assignedId] + where + append :: NotificationsRef -> (Id, Notification) -> IO () + append ns n = atomicModifyIORef' (notifs ns) + ((`N.append` n) .> (,())) + unwrap :: CapId -> Word32 + unwrap = uncap .> getMax .> toWord32 .> getMax + +getServerInformation :: IO (String, String, String, String) +getServerInformation = return ("xnobar", "enrico", "0", "1.2") + +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' + pure r diff --git a/lib/XNobar/XNobar.hs b/lib/XNobar/XNobar.hs new file mode 100644 --- /dev/null +++ b/lib/XNobar/XNobar.hs @@ -0,0 +1,61 @@ +-- | +-- = Notification server plugin for [XMobar](https://codeberg.org/xmobar/xmobar) +-- +-- This module exposes the 'xNobar' smart value ctor to be used for +-- instantiating the plugin for [XMobar](https://codeberg.org/xmobar/xmobar), +-- together with the selectors of its fields to allow providing some options as +-- well. +-- +-- That plugin will start a notification server, and show the notifications in +-- 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. +-- +-- The present module can be thought of as the front-end part of the notifications server, +-- 'XNobar.Server' being the back-end. +{-# LANGUAGE LambdaCase #-} +module XNobar (xNobar, Config(..)) where + +import Control.Monad (when) +import Xmobar (Exec (..)) +import XNobar.Server (startServer) +import XNobar.Scroller (scroller, Config(..)) + +-- |XNobar plugin smart ctor. You would use it like this in your @xmobar.hs@ +-- (__note__: the non-library usage of +-- [XMobar](https://codeberg.org/xmobar/xmobar) is not supported, or at least I +-- haven't tried using xnobar in that context): +-- +-- @ +-- main :: IO () +-- main = xmobar defaultConfig { +-- , commands = [ +-- Run $ xNobar { idleText = "All quiet here" +-- , newsPrefix = "news: " +-- , marqueeLength = 20 +-- , scrollPeriod = 1 +-- -- ... +-- } +-- -- ... +-- @ +xNobar = Config { + idleText = "No notifications" + , marqueeLength = 16 + , fontNumber = 0 + , scrollPeriod = 1 + , noNewsPrefix = "" + , newsPrefix = "news: " + , lineBreak = "\\n" + , criticalPrefix = " ! " + , nonCriticalPrefix = "" +} + +-- |This instance, required by [XMobar](https://codeberg.org/xmobar/xmobar), +-- is the core of the plugin. +instance Exec Config where + alias _ = "XNobar" + start config cb + = startServer >>= \case Just notifs -> do scroller config cb notifs + error "What? scroller returned. Has it been killed?!" + Nothing -> cb "Server could not start" diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,143 @@ +module Main where + +import Control.Monad (unless, join, replicateM) +import Data.List (nubBy) +import Data.Function (on, (&)) +import Data.Word (Word32) +import System.Exit (exitFailure) +import Test.QuickCheck + +import XNobar.Internal.Notification +import XNobar.Internal.Positive32 +import XNobar.Internal.Scroller +import Data.Maybe (isNothing, isJust, fromJust) +import Data.Tuple.Extra (snd3) +import Data.Semigroup (Max(..)) + +main :: IO () +main = do + + result <- mapM quickCheckResult [ + tAppendExisting + , tAppendNew + ] + + unless (all isSuccess result) exitFailure + + result <- quickCheckResult tRemove + unless (isSuccess result) exitFailure + + result <- quickCheckResult tRemoveCurrent + unless (isSuccess result) exitFailure + + result <- quickCheckResult tCombine + unless (isSuccess result) exitFailure + + result <- mapM quickCheckResult [ + tScrollPeriod + , tExactScrolls + ] + unless (all isSuccess result) exitFailure + +instance Arbitrary Positive32 where + arbitrary = positive32 <$> elements [1..10] + +tAppendExisting :: Word32 -> [(Id, ())] -> Bool +tAppendExisting _ [] = True +tAppendExisting i ns + | i > 100 = True + | otherwise = let ns'nodups = nubBy ((==) `on` theId) ns + n = cycle ns'nodups !! read (show i) + ns' = ns'nodups `append` n + in theId (last ns') == theId n + && length ns'nodups == length ns' + +tAppendNew :: Word32 -> [(Id, ())] -> Bool +tAppendNew _ [] = True +tAppendNew i ns + | i > 100 = True + | otherwise = let (n:ns'nodups) = nubBy ((==) `on` theId) ns + ns' = ns'nodups `append` n + in theId (last ns') == theId n + && length ns'nodups + 1 == length ns' + +instance {-# Overlapping #-} (Foldable f, Num o, Enum o, Arbitrary (f c), Arbitrary o) + => Arbitrary (Maybe (Id, o, [(Id, f c)])) where + arbitrary = do + size <- elements [1..9] + indexedNotifs <- zip <$> shuffle (map makeId [1..(fromIntegral size)]) + <*> replicateM size arbitrary + (currId, notif) <- elements indexedNotifs + currOffset <- elements $ take (length notif) [0..] + elements [Nothing, + Just (currId, currOffset, indexedNotifs)] + +tRemove :: (Id, Maybe (Id, Int, [(Id, String)])) -> Bool +tRemove = uncurry removeImpl + +-- TODO: fix this test +removeImpl :: Id -> Maybe (Id, Int, [(Id, String)]) -> Bool +removeImpl _ Nothing = True +removeImpl _ (Just (_, _, [])) = error "This should not happen" +removeImpl i p@(Just (_, _, [(i', _)])) = (i /= i') || null (remove i p) +removeImpl i p@(Just (i', _, l)) + | i == i' = tRemoveCurrent p + | otherwise = case remove i p of + Nothing -> error "This should not happen" + Just (_, _, l') -> length l' == length l - 1 + +-- TODO: String seems unnecessary +tRemoveCurrent :: Maybe (Id, Int, [(Id, String)]) -> Bool +tRemoveCurrent Nothing = True +tRemoveCurrent (Just (_, _, [])) = error "This should not happen" +tRemoveCurrent ns@(Just (curr, o, _)) = case remove curr ns of + Nothing -> True + (Just (curr', _, _)) -> curr' /= curr + +instance {-# Overlapping #-} Arbitrary [Id] where + arbitrary = do + size <- elements [1..10] + shuffle $ map makeId [1..size] + +tCombine :: [Id] -> [Id] -> Bool +tCombine olds news = let olds' = map (, "old") olds + news' = map (, "new") news + new'news = olds' `combine` news' + renewed = filter (`elem` news) olds + older = filter (`notElem` news) olds + in all (`elem` new'news) news' + && all ((`elem` new'news) . (, "new")) renewed + && all ((`elem` new'news) . (, "old")) older + +instance {-# Overlapping #-} Arbitrary String where + arbitrary = do + size <- elements [1..10] + return $ take size $ cycle $ concatMap show [0..9] + +tScrollPeriod :: Maybe (Id, Int, [(Id, String)]) -> Bool +tScrollPeriod Nothing = True +tScrollPeriod ns@(Just (_, _, is)) = let totLen = sum $ map (length . show . snd) is + in ns == applyN totLen scroll ns + +instance {-# Overlapping #-} Show String where + show = id -- This is because `scroll` uses `show` on the notification, + -- and if I'm using a `String` here for simplicity, that would + -- result in wrapping the string within `"`, which alters their + -- length. + +tExactScrolls :: Maybe (Id, Int, [(Id, String)]) -> Bool +tExactScrolls Nothing = True +tExactScrolls (Just (i, _, indexedNotifs)) + = let ns = Just (i, 0, indexedNotifs) + beforeCurr = takeWhile ((/= i) . theId) indexedNotifs + lengths = rotate (length beforeCurr) indexedNotifs + & map (length . snd) + scrolledNotifs = map (iterate scroll ns !!) (sums lengths) + in all ((== 0) . snd3 . fromJust) scrolledNotifs + +applyN :: Int -> (a -> a) -> a -> a +applyN n = ((!! n) .) . iterate + +sums = scanl (+) 0 + +rotate n l = take (length l) $ drop n $ cycle l diff --git a/xnobar.cabal b/xnobar.cabal new file mode 100644 --- /dev/null +++ b/xnobar.cabal @@ -0,0 +1,78 @@ +cabal-version: 3.0 +name: xnobar +version: 0.0.0.0 +maintainer: Enrico Maria De Angelis +homepage: https://codeberg.org/Aster89/xnobar +synopsis: Text-based notification server for XMobar +description: Text-based notification server for XMobar. It also exposes just the back-end, to be used as a library. +category: System +license: BSD-3-Clause + +source-repository head + type: git + location: git://codeberg.org/Aster89/xnobar.git + branch: master + +common common + default-language: GHC2021 + build-depends: base >= 4.17.2 && < 4.18 + +library + import: common + exposed-modules: XNobar + build-depends: xmobar >= 0.48.1 && <= 0.49 + , xnobar:Server + , xnobar:Scroller + hs-source-dirs: lib/XNobar + +library Server + import: common + visibility: public + exposed-modules: XNobar.Server + build-depends: dbus >= 1.3.5 && < 1.4 + , extra >= 1.7.16 && < 1.8 + , flow >= 2.0.0 && < 2.1 + , transformers >= 0.5.6 && < 0.6 + , xnobar:Notification + , xnobar:Positive32 + hs-source-dirs: lib/Server + +library Notification + import: common + exposed-modules: XNobar.Internal.Notification + build-depends: containers >= 0.6.7 && < 0.7 + , dbus + , flow + , xnobar:Positive32 + hs-source-dirs: lib/Notification + +library Scroller + import: common + exposed-modules: XNobar.Scroller, XNobar.Internal.Scroller + build-depends: async >= 2.2.5 && < 2.3 + , directory >= 1.3.7 && < 1.4 + , extra + , flow + , mtl >= 2.2.2 && < 2.3 + , process >= 1.6.18 && < 1.7 + , xmobar + , xnobar:Notification + , xnobar:Positive32 + , xnobar:Server + hs-source-dirs: lib/Scroller + +library Positive32 + import: common + exposed-modules: XNobar.Internal.Positive32 + hs-source-dirs: lib/Positive32 + +test-suite Test + import: common + type: exitcode-stdio-1.0 + main-is: Main.hs + build-depends: QuickCheck + , extra + , xnobar:Notification + , xnobar:Positive32 + , xnobar:Scroller + hs-source-dirs: test