xnobar (empty) → 0.0.0.0
raw patch · 8 files changed
+734/−0 lines, 8 filesdep +QuickCheckdep +asyncdep +base
Dependencies added: QuickCheck, async, base, containers, dbus, directory, extra, flow, mtl, process, transformers, xmobar, xnobar
Files
- lib/Notification/XNobar/Internal/Notification.hs +88/−0
- lib/Positive32/XNobar/Internal/Positive32.hs +33/−0
- lib/Scroller/XNobar/Internal/Scroller.hs +114/−0
- lib/Scroller/XNobar/Scroller.hs +78/−0
- lib/Server/XNobar/Server.hs +139/−0
- lib/XNobar/XNobar.hs +61/−0
- test/Main.hs +143/−0
- xnobar.cabal +78/−0
+ lib/Notification/XNobar/Internal/Notification.hs view
@@ -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
+ lib/Positive32/XNobar/Internal/Positive32.hs view
@@ -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
+ lib/Scroller/XNobar/Internal/Scroller.hs view
@@ -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 "<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+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 ("<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++instance Show Notification where+ show n = summary n ++ maybeBody ++ " "+ where+ maybeBody = if not $ null $ body n+ then " | " ++ body n+ else ""
+ lib/Scroller/XNobar/Scroller.hs view
@@ -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
+ lib/Server/XNobar/Server.hs view
@@ -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
+ lib/XNobar/XNobar.hs view
@@ -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 "<fc=#FF0000>Server could not start</fc>"
+ test/Main.hs view
@@ -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
+ xnobar.cabal view
@@ -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