{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | This widget listens on DBus for freedesktop notifications
-- (<http://developer.gnome.org/notification-spec/>).  Currently it is
-- somewhat ugly, but the format is somewhat configurable.
--
-- The widget only displays one notification at a time and
-- notifications are cancellable.
--
-- The notificationDaemon thread handles new notifications
-- and cancellation requests, adding or removing the notification
-- to or from the queue. It additionally starts a timeout thread
-- for each notification added to queue.
--
-- The display thread blocks idling until it is awakened to refresh the GUI
--
-- A timeout thread is associated with a notification id.
-- It sleeps until the specific timeout and then removes every notification
-- with that id from the queue

module System.Taffybar.Widget.FreedesktopNotifications
  ( Notification(..)
  , NotificationConfig(..)
  , defaultNotificationConfig
  , notifyAreaNew
  ) where

import           BroadcastChan
import           Control.Concurrent
import           Control.Concurrent.STM
import           Control.Monad ( forever, void )
import           Control.Monad.IO.Class
import           DBus
import           DBus.Client
import           Data.Default ( Default(..) )
import           Data.Foldable
import           Data.Int ( Int32 )
import           Data.Map ( Map )
import           Data.Monoid
import           Data.Sequence ( Seq, (|>), viewl, ViewL(..) )
import qualified Data.Sequence as S
import           Data.Text ( Text )
import qualified Data.Text as T
import           Data.Word ( Word32 )
import           GI.GLib (markupEscapeText)
import           GI.Gtk
import qualified GI.Pango as Pango
import           System.Taffybar.Util

import Prelude

-- | A simple structure representing a Freedesktop notification
data Notification = Notification
  { Notification -> Text
noteAppName :: Text
  , Notification -> Word32
noteReplaceId :: Word32
  , Notification -> Text
noteSummary :: Text
  , Notification -> Text
noteBody :: Text
  , Notification -> Maybe Int32
noteExpireTimeout :: Maybe Int32
  , Notification -> Word32
noteId :: Word32
  } deriving (Int -> Notification -> ShowS
[Notification] -> ShowS
Notification -> String
(Int -> Notification -> ShowS)
-> (Notification -> String)
-> ([Notification] -> ShowS)
-> Show Notification
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Notification] -> ShowS
$cshowList :: [Notification] -> ShowS
show :: Notification -> String
$cshow :: Notification -> String
showsPrec :: Int -> Notification -> ShowS
$cshowsPrec :: Int -> Notification -> ShowS
Show, Notification -> Notification -> Bool
(Notification -> Notification -> Bool)
-> (Notification -> Notification -> Bool) -> Eq Notification
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Notification -> Notification -> Bool
$c/= :: Notification -> Notification -> Bool
== :: Notification -> Notification -> Bool
$c== :: Notification -> Notification -> Bool
Eq)

data NotifyState = NotifyState
  { NotifyState -> Label
noteWidget :: Label
  , NotifyState -> Widget
noteContainer :: Widget
  , NotifyState -> NotificationConfig
noteConfig :: NotificationConfig -- ^ The associated configuration
  , NotifyState -> TVar (Seq Notification)
noteQueue :: TVar (Seq Notification) -- ^ The queue of active notifications
  , NotifyState -> TVar Word32
noteIdSource :: TVar Word32 -- ^ A source of fresh notification ids
  , NotifyState -> BroadcastChan In ()
noteChan :: BroadcastChan In () -- ^ Writing to this channel wakes up the display thread
  }

initialNoteState :: Widget -> Label -> NotificationConfig -> IO NotifyState
initialNoteState :: Widget -> Label -> NotificationConfig -> IO NotifyState
initialNoteState Widget
wrapper Label
l NotificationConfig
cfg = do
  TVar Word32
m <- Word32 -> IO (TVar Word32)
forall a. a -> IO (TVar a)
newTVarIO Word32
1
  TVar (Seq Notification)
q <- Seq Notification -> IO (TVar (Seq Notification))
forall a. a -> IO (TVar a)
newTVarIO Seq Notification
forall a. Seq a
S.empty
  BroadcastChan In ()
ch <- IO (BroadcastChan In ())
forall (m :: * -> *) a. MonadIO m => m (BroadcastChan In a)
newBroadcastChan
  NotifyState -> IO NotifyState
forall (m :: * -> *) a. Monad m => a -> m a
return NotifyState :: Label
-> Widget
-> NotificationConfig
-> TVar (Seq Notification)
-> TVar Word32
-> BroadcastChan In ()
-> NotifyState
NotifyState { noteQueue :: TVar (Seq Notification)
noteQueue = TVar (Seq Notification)
q
                     , noteIdSource :: TVar Word32
noteIdSource = TVar Word32
m
                     , noteWidget :: Label
noteWidget = Label
l
                     , noteContainer :: Widget
noteContainer = Widget
wrapper
                     , noteConfig :: NotificationConfig
noteConfig = NotificationConfig
cfg
                     , noteChan :: BroadcastChan In ()
noteChan = BroadcastChan In ()
ch
                     }

-- | Removes every notification with id 'nId' from the queue
notePurge :: NotifyState -> Word32 -> IO ()
notePurge :: NotifyState -> Word32 -> IO ()
notePurge NotifyState
s Word32
nId = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ())
-> ((Seq Notification -> Seq Notification) -> STM ())
-> (Seq Notification -> Seq Notification)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TVar (Seq Notification)
-> (Seq Notification -> Seq Notification) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (NotifyState -> TVar (Seq Notification)
noteQueue NotifyState
s) ((Seq Notification -> Seq Notification) -> IO ())
-> (Seq Notification -> Seq Notification) -> IO ()
forall a b. (a -> b) -> a -> b
$
  (Notification -> Bool) -> Seq Notification -> Seq Notification
forall a. (a -> Bool) -> Seq a -> Seq a
S.filter ((Word32
nId Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/=) (Word32 -> Bool)
-> (Notification -> Word32) -> Notification -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Notification -> Word32
noteId)

-- | Removes the first (oldest) notification from the queue
noteNext :: NotifyState -> IO ()
noteNext :: NotifyState -> IO ()
noteNext NotifyState
s = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar (Seq Notification)
-> (Seq Notification -> Seq Notification) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (NotifyState -> TVar (Seq Notification)
noteQueue NotifyState
s) Seq Notification -> Seq Notification
forall {a}. Seq a -> Seq a
aux
  where
    aux :: Seq a -> Seq a
aux Seq a
queue = case Seq a -> ViewL a
forall a. Seq a -> ViewL a
viewl Seq a
queue of
      ViewL a
EmptyL -> Seq a
forall a. Seq a
S.empty
      a
_ :< Seq a
ns -> Seq a
ns

-- | Generates a fresh notification id
noteFreshId :: NotifyState -> IO Word32
noteFreshId :: NotifyState -> IO Word32
noteFreshId NotifyState { TVar Word32
noteIdSource :: TVar Word32
noteIdSource :: NotifyState -> TVar Word32
noteIdSource } = STM Word32 -> IO Word32
forall a. STM a -> IO a
atomically (STM Word32 -> IO Word32) -> STM Word32 -> IO Word32
forall a b. (a -> b) -> a -> b
$ do
  Word32
nId <- TVar Word32 -> STM Word32
forall a. TVar a -> STM a
readTVar TVar Word32
noteIdSource
  TVar Word32 -> Word32 -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Word32
noteIdSource (Word32 -> Word32
forall a. Enum a => a -> a
succ Word32
nId)
  Word32 -> STM Word32
forall (m :: * -> *) a. Monad m => a -> m a
return Word32
nId

--------------------------------------------------------------------------------
-- | Handles a new notification
notify :: NotifyState
       -> Text -- ^ Application name
       -> Word32 -- ^ Replaces id
       -> Text -- ^ App icon
       -> Text -- ^ Summary
       -> Text -- ^ Body
       -> [Text] -- ^ Actions
       -> Map Text Variant -- ^ Hints
       -> Int32 -- ^ Expires timeout (milliseconds)
       -> IO Word32
notify :: NotifyState
-> Text
-> Word32
-> Text
-> Text
-> Text
-> [Text]
-> Map Text Variant
-> Int32
-> IO Word32
notify NotifyState
s Text
appName Word32
replaceId Text
_ Text
summary Text
body [Text]
_ Map Text Variant
_ Int32
timeout = do
  Word32
realId <- if Word32
replaceId Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0 then NotifyState -> IO Word32
noteFreshId NotifyState
s else Word32 -> IO Word32
forall (m :: * -> *) a. Monad m => a -> m a
return Word32
replaceId
  let configTimeout :: Maybe Int32
configTimeout = NotificationConfig -> Maybe Int32
notificationMaxTimeout (NotifyState -> NotificationConfig
noteConfig NotifyState
s)
      realTimeout :: Maybe Int32
realTimeout = if Int32
timeout Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int32
0 -- Gracefully handle out of spec negative values
                    then Maybe Int32
configTimeout
                    else case Maybe Int32
configTimeout of
                           Maybe Int32
Nothing -> Int32 -> Maybe Int32
forall a. a -> Maybe a
Just Int32
timeout
                           Just Int32
maxTimeout -> Int32 -> Maybe Int32
forall a. a -> Maybe a
Just (Int32 -> Int32 -> Int32
forall a. Ord a => a -> a -> a
min Int32
maxTimeout Int32
timeout)

  Text
escapedSummary <- Text -> Int64 -> IO Text
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Int64 -> m Text
markupEscapeText Text
summary (-Int64
1)
  Text
escapedBody <- Text -> Int64 -> IO Text
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Text -> Int64 -> m Text
markupEscapeText Text
body (-Int64
1)
  let n :: Notification
n = Notification :: Text
-> Word32 -> Text -> Text -> Maybe Int32 -> Word32 -> Notification
Notification { noteAppName :: Text
noteAppName = Text
appName
                       , noteReplaceId :: Word32
noteReplaceId = Word32
replaceId
                       , noteSummary :: Text
noteSummary = Text
escapedSummary
                       , noteBody :: Text
noteBody = Text
escapedBody
                       , noteExpireTimeout :: Maybe Int32
noteExpireTimeout = Maybe Int32
realTimeout
                       , noteId :: Word32
noteId = Word32
realId
                       }
  -- Either add the new note to the queue or replace an existing note if their ids match
  STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Seq Notification
queue <- TVar (Seq Notification) -> STM (Seq Notification)
forall a. TVar a -> STM a
readTVar (TVar (Seq Notification) -> STM (Seq Notification))
-> TVar (Seq Notification) -> STM (Seq Notification)
forall a b. (a -> b) -> a -> b
$ NotifyState -> TVar (Seq Notification)
noteQueue NotifyState
s
    TVar (Seq Notification) -> Seq Notification -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar (NotifyState -> TVar (Seq Notification)
noteQueue NotifyState
s) (Seq Notification -> STM ()) -> Seq Notification -> STM ()
forall a b. (a -> b) -> a -> b
$ case (Notification -> Bool) -> Seq Notification -> Maybe Int
forall a. (a -> Bool) -> Seq a -> Maybe Int
S.findIndexL (\Notification
n_ -> Notification -> Word32
noteId Notification
n Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Notification -> Word32
noteId Notification
n_) Seq Notification
queue of
      Maybe Int
Nothing -> Seq Notification
queue Seq Notification -> Notification -> Seq Notification
forall a. Seq a -> a -> Seq a
|> Notification
n
      Just Int
index -> Int -> Notification -> Seq Notification -> Seq Notification
forall a. Int -> a -> Seq a -> Seq a
S.update Int
index Notification
n Seq Notification
queue
  NotifyState -> Notification -> IO ()
startTimeoutThread NotifyState
s Notification
n
  NotifyState -> IO ()
wakeupDisplayThread NotifyState
s
  Word32 -> IO Word32
forall (m :: * -> *) a. Monad m => a -> m a
return Word32
realId

-- | Handles user cancellation of a notification
closeNotification :: NotifyState -> Word32 -> IO ()
closeNotification :: NotifyState -> Word32 -> IO ()
closeNotification NotifyState
s Word32
nId = do
  NotifyState -> Word32 -> IO ()
notePurge NotifyState
s Word32
nId
  NotifyState -> IO ()
wakeupDisplayThread NotifyState
s

notificationDaemon :: (AutoMethod f1, AutoMethod f2)
                      => f1 -> f2 -> IO ()
notificationDaemon :: forall f1 f2. (AutoMethod f1, AutoMethod f2) => f1 -> f2 -> IO ()
notificationDaemon f1
onNote f2
onCloseNote = do
  Client
client <- IO Client
connectSession
  RequestNameReply
_ <- Client -> BusName -> [RequestNameFlag] -> IO RequestNameReply
requestName Client
client BusName
"org.freedesktop.Notifications" [RequestNameFlag
nameAllowReplacement, RequestNameFlag
nameReplaceExisting]
  Client -> ObjectPath -> Interface -> IO ()
export Client
client ObjectPath
"/org/freedesktop/Notifications" Interface
interface
  where
    getServerInformation :: IO (Text, Text, Text, Text)
    getServerInformation :: IO (Text, Text, Text, Text)
getServerInformation = (Text, Text, Text, Text) -> IO (Text, Text, Text, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
"haskell-notification-daemon",
                                   Text
"nochair.net",
                                   Text
"0.0.1",
                                   Text
"1.1")
    getCapabilities :: IO [Text]
    getCapabilities :: IO [Text]
getCapabilities = [Text] -> IO [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return [Text
"body", Text
"body-markup"]
    interface :: Interface
interface = Interface
defaultInterface
      { interfaceName :: InterfaceName
interfaceName = InterfaceName
"org.freedesktop.Notifications"
      , interfaceMethods :: [Method]
interfaceMethods =
          [ MemberName -> IO (Text, Text, Text, Text) -> Method
forall fn. AutoMethod fn => MemberName -> fn -> Method
autoMethod MemberName
"GetServerInformation" IO (Text, Text, Text, Text)
getServerInformation
          , MemberName -> IO [Text] -> Method
forall fn. AutoMethod fn => MemberName -> fn -> Method
autoMethod MemberName
"GetCapabilities" IO [Text]
getCapabilities
          , MemberName -> f2 -> Method
forall fn. AutoMethod fn => MemberName -> fn -> Method
autoMethod MemberName
"CloseNotification" f2
onCloseNote
          , MemberName -> f1 -> Method
forall fn. AutoMethod fn => MemberName -> fn -> Method
autoMethod MemberName
"Notify" f1
onNote
          ]
      }

--------------------------------------------------------------------------------
wakeupDisplayThread :: NotifyState -> IO ()
wakeupDisplayThread :: NotifyState -> IO ()
wakeupDisplayThread NotifyState
s = IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ BroadcastChan In () -> () -> IO Bool
forall (m :: * -> *) a.
MonadIO m =>
BroadcastChan In a -> a -> m Bool
writeBChan (NotifyState -> BroadcastChan In ()
noteChan NotifyState
s) ()

-- | Refreshes the GUI
displayThread :: NotifyState -> IO ()
displayThread :: NotifyState -> IO ()
displayThread NotifyState
s = do
  BroadcastChan Out ()
chan <- BroadcastChan In () -> IO (BroadcastChan Out ())
forall (m :: * -> *) (dir :: Direction) a.
MonadIO m =>
BroadcastChan dir a -> m (BroadcastChan Out a)
newBChanListener (NotifyState -> BroadcastChan In ()
noteChan NotifyState
s)
  IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Maybe ()
_ <- BroadcastChan Out () -> IO (Maybe ())
forall (m :: * -> *) a.
MonadIO m =>
BroadcastChan Out a -> m (Maybe a)
readBChan BroadcastChan Out ()
chan
    Seq Notification
ns <- TVar (Seq Notification) -> IO (Seq Notification)
forall a. TVar a -> IO a
readTVarIO (NotifyState -> TVar (Seq Notification)
noteQueue NotifyState
s)
    IO () -> IO ()
postGUIASync (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      if Seq Notification -> Int
forall a. Seq a -> Int
S.length Seq Notification
ns Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
      then Widget -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetHide (NotifyState -> Widget
noteContainer NotifyState
s)
      else do
        Label -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> Text -> m ()
labelSetMarkup (NotifyState -> Label
noteWidget NotifyState
s) (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ NotificationConfig -> [Notification] -> Text
formatMessage (NotifyState -> NotificationConfig
noteConfig NotifyState
s) (Seq Notification -> [Notification]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq Notification
ns)
        Widget -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShowAll (NotifyState -> Widget
noteContainer NotifyState
s)
  where
    formatMessage :: NotificationConfig -> [Notification] -> Text
formatMessage NotificationConfig {Int
Maybe Int32
[Notification] -> Text
notificationFormatter :: NotificationConfig -> [Notification] -> Text
notificationMaxLength :: NotificationConfig -> Int
notificationFormatter :: [Notification] -> Text
notificationMaxLength :: Int
notificationMaxTimeout :: Maybe Int32
notificationMaxTimeout :: NotificationConfig -> Maybe Int32
..} [Notification]
ns =
      Int -> Text -> Text
T.take Int
notificationMaxLength (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ [Notification] -> Text
notificationFormatter [Notification]
ns

--------------------------------------------------------------------------------
startTimeoutThread :: NotifyState -> Notification -> IO ()
startTimeoutThread :: NotifyState -> Notification -> IO ()
startTimeoutThread NotifyState
s Notification {Maybe Int32
Word32
Text
noteId :: Word32
noteExpireTimeout :: Maybe Int32
noteBody :: Text
noteSummary :: Text
noteReplaceId :: Word32
noteAppName :: Text
noteId :: Notification -> Word32
noteExpireTimeout :: Notification -> Maybe Int32
noteBody :: Notification -> Text
noteSummary :: Notification -> Text
noteReplaceId :: Notification -> Word32
noteAppName :: Notification -> Text
..} = case Maybe Int32
noteExpireTimeout of
  Maybe Int32
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  Just Int32
timeout -> IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    Int -> IO ()
threadDelay (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
timeout Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
10Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
3 :: Int))
    NotifyState -> Word32 -> IO ()
notePurge NotifyState
s Word32
noteId
    NotifyState -> IO ()
wakeupDisplayThread NotifyState
s

--------------------------------------------------------------------------------
data NotificationConfig = NotificationConfig
  { NotificationConfig -> Maybe Int32
notificationMaxTimeout :: Maybe Int32 -- ^ Maximum time that a notification will be displayed (in seconds).  Default: None
  , NotificationConfig -> Int
notificationMaxLength :: Int -- ^ Maximum length displayed, in characters.  Default: 100
  , NotificationConfig -> [Notification] -> Text
notificationFormatter :: [Notification] -> T.Text -- ^ Function used to format notifications, takes the notifications from first to last
  }

defaultFormatter :: [Notification] -> T.Text
defaultFormatter :: [Notification] -> Text
defaultFormatter [Notification]
ns =
  let count :: Int
count = [Notification] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Notification]
ns
      n :: Notification
n = [Notification] -> Notification
forall a. [a] -> a
head [Notification]
ns
      prefix :: Text
prefix = if Int
count Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
               then Text
""
               else Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Int -> String
forall a. Show a => a -> String
show Int
count) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
") "
      msg :: Text
msg =  if Text -> Bool
T.null (Notification -> Text
noteBody Notification
n)
             then Notification -> Text
noteSummary Notification
n
             else Notification -> Text
noteSummary Notification
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Notification -> Text
noteBody Notification
n
  in Text
"<span fgcolor='yellow'>" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"</span>" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg

-- | The default formatter is one of
-- * Summary : Body
-- * Summary
-- * (N) Summary : Body
-- * (N) Summary
-- depending on the presence of a notification body, and where N is the number of queued notifications.
defaultNotificationConfig :: NotificationConfig
defaultNotificationConfig :: NotificationConfig
defaultNotificationConfig =
  NotificationConfig :: Maybe Int32
-> Int -> ([Notification] -> Text) -> NotificationConfig
NotificationConfig { notificationMaxTimeout :: Maybe Int32
notificationMaxTimeout = Maybe Int32
forall a. Maybe a
Nothing
                     , notificationMaxLength :: Int
notificationMaxLength = Int
100
                     , notificationFormatter :: [Notification] -> Text
notificationFormatter = [Notification] -> Text
defaultFormatter
                     }

instance Default NotificationConfig where
  def :: NotificationConfig
def = NotificationConfig
defaultNotificationConfig

-- | Create a new notification area with the given configuration.
notifyAreaNew :: MonadIO m => NotificationConfig -> m Widget
notifyAreaNew :: forall (m :: * -> *). MonadIO m => NotificationConfig -> m Widget
notifyAreaNew NotificationConfig
cfg = IO Widget -> m Widget
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Widget -> m Widget) -> IO Widget -> m Widget
forall a b. (a -> b) -> a -> b
$ do
  Frame
frame <- Maybe Text -> IO Frame
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> m Frame
frameNew Maybe Text
forall a. Maybe a
Nothing
  Box
box <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
boxNew Orientation
OrientationHorizontal Int32
3
  Label
textArea <- Maybe Text -> IO Label
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> m Label
labelNew (Maybe Text
forall a. Maybe a
Nothing :: Maybe Text)
  EventBox
button <- IO EventBox
forall (m :: * -> *). (HasCallStack, MonadIO m) => m EventBox
eventBoxNew
  Separator
sep <- Orientation -> IO Separator
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> m Separator
separatorNew Orientation
OrientationHorizontal

  Label
bLabel <- Maybe Text -> IO Label
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Maybe Text -> m Label
labelNew (Maybe Text
forall a. Maybe a
Nothing :: Maybe Text)
  Label -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> Text -> m ()
widgetSetName Label
bLabel Text
"NotificationCloseButton"
  Label -> Text -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> Text -> m ()
labelSetMarkup Label
bLabel Text
"×"

  Label -> Int32 -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> Int32 -> m ()
labelSetMaxWidthChars Label
textArea (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> Int -> Int32
forall a b. (a -> b) -> a -> b
$ NotificationConfig -> Int
notificationMaxLength NotificationConfig
cfg)
  Label -> EllipsizeMode -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsLabel a) =>
a -> EllipsizeMode -> m ()
labelSetEllipsize Label
textArea EllipsizeMode
Pango.EllipsizeModeEnd

  EventBox -> Label -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
containerAdd EventBox
button Label
bLabel
  Box -> Label -> Bool -> Bool -> Word32 -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsBox a, IsWidget b) =>
a -> b -> Bool -> Bool -> Word32 -> m ()
boxPackStart Box
box Label
textArea Bool
True Bool
True Word32
0
  Box -> Separator -> Bool -> Bool -> Word32 -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsBox a, IsWidget b) =>
a -> b -> Bool -> Bool -> Word32 -> m ()
boxPackStart Box
box Separator
sep Bool
False Bool
False Word32
0
  Box -> EventBox -> Bool -> Bool -> Word32 -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsBox a, IsWidget b) =>
a -> b -> Bool -> Bool -> Word32 -> m ()
boxPackStart Box
box EventBox
button Bool
False Bool
False Word32
0

  Frame -> Box -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsContainer a, IsWidget b) =>
a -> b -> m ()
containerAdd Frame
frame Box
box

  Frame -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetHide Frame
frame
  Widget
w <- Frame -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
toWidget Frame
frame

  NotifyState
s <- Widget -> Label -> NotificationConfig -> IO NotifyState
initialNoteState Widget
w Label
textArea NotificationConfig
cfg
  SignalHandlerId
_ <- EventBox
-> ((?self::EventBox) => WidgetButtonReleaseEventCallback)
-> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a
-> ((?self::a) => WidgetButtonReleaseEventCallback)
-> m SignalHandlerId
onWidgetButtonReleaseEvent EventBox
button (NotifyState -> WidgetButtonReleaseEventCallback
forall {p}. NotifyState -> p -> IO Bool
userCancel NotifyState
s)

  Box
realizableWrapper <- Orientation -> Int32 -> IO Box
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Orientation -> Int32 -> m Box
boxNew Orientation
OrientationHorizontal Int32
0
  Box -> Frame -> Bool -> Bool -> Word32 -> IO ()
forall (m :: * -> *) a b.
(HasCallStack, MonadIO m, IsBox a, IsWidget b) =>
a -> b -> Bool -> Bool -> Word32 -> m ()
boxPackStart Box
realizableWrapper Frame
frame Bool
False Bool
False Word32
0
  Box -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadIO m, IsWidget a) =>
a -> m ()
widgetShow Box
realizableWrapper

  -- We can't start the dbus listener thread until we are in the GTK
  -- main loop, otherwise things are prone to lock up and block
  -- infinitely on an mvar.  Bad stuff - only start the dbus thread
  -- after the fake invisible wrapper widget is realized.
  IO SignalHandlerId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO SignalHandlerId -> IO ()) -> IO SignalHandlerId -> IO ()
forall a b. (a -> b) -> a -> b
$ Box -> ((?self::Box) => IO ()) -> IO SignalHandlerId
forall a (m :: * -> *).
(IsWidget a, MonadIO m) =>
a -> ((?self::a) => IO ()) -> m SignalHandlerId
onWidgetRealize Box
realizableWrapper (((?self::Box) => IO ()) -> IO SignalHandlerId)
-> ((?self::Box) => IO ()) -> IO SignalHandlerId
forall a b. (a -> b) -> a -> b
$ do
    IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (NotifyState -> IO ()
displayThread NotifyState
s)
    (Text
 -> Word32
 -> Text
 -> Text
 -> Text
 -> [Text]
 -> Map Text Variant
 -> Int32
 -> IO Word32)
-> (Word32 -> IO ()) -> IO ()
forall f1 f2. (AutoMethod f1, AutoMethod f2) => f1 -> f2 -> IO ()
notificationDaemon (NotifyState
-> Text
-> Word32
-> Text
-> Text
-> Text
-> [Text]
-> Map Text Variant
-> Int32
-> IO Word32
notify NotifyState
s) (NotifyState -> Word32 -> IO ()
closeNotification NotifyState
s)

  -- Don't show the widget by default - it will appear when needed
  Box -> IO Widget
forall (m :: * -> *) o. (MonadIO m, IsWidget o) => o -> m Widget
toWidget Box
realizableWrapper

  where
    -- | Close the current note and pull up the next, if any
    userCancel :: NotifyState -> p -> IO Bool
userCancel NotifyState
s p
_ = do
      NotifyState -> IO ()
noteNext NotifyState
s
      NotifyState -> IO ()
wakeupDisplayThread NotifyState
s
      Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True