diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +0.2 +=== + + * Added `appName`, a way to provide a custom application name for a notification. + + * Renamed `ServerInfo` record accessors, so that they are less likely to conflict with other definitions. + 0.1.1.0 ======= diff --git a/example/notify-send.hs b/example/notify-send.hs new file mode 100644 --- /dev/null +++ b/example/notify-send.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +module Main (main) where + +import Data.Bool (bool) +import Data.Int (Int32) +import Data.Maybe (catMaybes) +import Data.Word (Word8) +import qualified Libnotify as L +import Options.Applicative +import Prelude hiding (mod) +import Text.Printf (printf) +import Text.Read (readEither) + + +main :: IO () +main = do + Options {summary, body, mod} <- parseOpts + L.display_ (mod <> L.summary summary <> foldMap L.body body) + +data Options = Options + { summary :: String + , body :: Maybe String + , mod :: L.Mod L.Notification + } + +parseOpts :: IO Options +parseOpts = + customExecParser (prefs showHelpOnError) (info (helper <*> parser) desc) + where + desc = + fullDesc <> progDesc "Create a notification." <> header "notify-send - an example of the libnotify library" + parser = do + summary <- argument str (metavar "SUMMARY") + body <- optional (argument str (metavar "BODY")) + mod <- parserMod + pure Options {..} + parserMod = + fmap (mconcat . catMaybes) . traverse optional $ + [ option urgency (short 'u' <> long "urgency" <> metavar "LEVEL") + , option timeout (short 't' <> long "timeout" <> metavar "TIME") + , option appName (short 'a' <> long "app-name" <> metavar "APP_NAME") + , option icon (short 'i' <> long "icon" <> metavar "ICON") + , option category (short 'c' <> long "category" <> metavar "TIME") + , option hint (short 'h' <> long "hint" <> metavar "TYPE:NAME:VALUE") + ] + urgency = + eitherReader $ \case + "low" -> + pure (L.urgency L.Low) + "normal" -> + pure (L.urgency L.Normal) + "critical" -> + pure (L.urgency L.Critical) + urg -> + Left (printf "Unknown urgency `%s'. Known urgencies: `low', `normal', and `critical'." urg) + timeout = do + time <- auto + pure (L.timeout (bool (L.Custom time) L.Infinite (time == 0))) + appName = do + name <- str + pure (L.appName name) + icon = do + name <- str + pure (L.icon name) + category = do + cat <- str + pure (L.category cat) + hint :: ReadM (L.Mod L.Notification) + hint = + eitherReader $ \typeNameVal -> + case break (== ':') typeNameVal of + (type_, ':' : nameVal) -> + case break (== ':') nameVal of + (name, ':' : val) -> + case type_ of + "int" -> do + int <- readEither val + pure (L.hint name (int :: Int32)) + "double" -> do + double <- readEither val + pure (L.hint name (double :: Double)) + "string" -> + pure (L.hint name val) + "byte" -> do + byte <- readEither val + pure (L.hint name (byte :: Word8)) + _ -> + Left (printf "Invalid hint: `%s`" typeNameVal) + _ -> + Left (printf "Invalid hint: `%s`" typeNameVal) + _ -> + Left (printf "Invalid hint: `%s`" typeNameVal) diff --git a/libnotify.cabal b/libnotify.cabal --- a/libnotify.cabal +++ b/libnotify.cabal @@ -1,5 +1,5 @@ name: libnotify -version: 0.1.1.0 +version: 0.2 synopsis: Bindings to libnotify library description: The package provides a high level interface to libnotify API (see "Libnotify") @@ -17,6 +17,7 @@ asset/*.png extra-source-files: example/endless.hs + example/notify-send.hs CHANGELOG.md README.md @@ -27,7 +28,7 @@ source-repository this type: git location: https://github.com/supki/libnotify - tag: 0.1.1.0 + tag: 0.2 library default-language: @@ -45,6 +46,5 @@ Libnotify.C.NotifyNotification ghc-options: -Wall - -fno-warn-unused-do-bind extra-libraries: notify diff --git a/src/Libnotify.hs b/src/Libnotify.hs --- a/src/Libnotify.hs +++ b/src/Libnotify.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} -- | High level interface to libnotify API module Libnotify ( -- * Notification API @@ -21,6 +22,7 @@ , nohints , action , noactions + , appName , reuse -- * Convenience re-exports , Monoid(..), (<>) @@ -29,6 +31,7 @@ import Control.Applicative ((<$)) import Data.ByteString (ByteString) import Data.Int (Int32) +import Data.Maybe (fromMaybe) import Data.Monoid (Monoid(..), (<>), Last(..)) import Data.Word (Word8) import Graphics.UI.Gtk.Gdk.Pixbuf (Pixbuf) @@ -41,8 +44,9 @@ -- | Notification object -newtype Notification = Notification - { unNotification :: NotifyNotification +data Notification = Notification + { token :: !NotifyNotification + , name :: !String } deriving (Show, Eq) -- | Display notification @@ -57,13 +61,13 @@ -- -- <> display :: Mod Notification -> IO Notification -display (Mod m a) = do - notify_init "haskell-libnotify" - n <- maybe (notify_notification_new "" "" "") (return . unNotification) (getLast m) - let y = Notification n - a y - notify_notification_show n - return y +display (Mod (Last reusedToken) (Last named) acts) = do + let name = fromMaybe defaultAppName named + _ <- notify_init name + token <- maybe (notify_notification_new "" "" "") return reusedToken + acts token name + _ <- notify_notification_show token + return Notification {token, name} -- | Display and discard notification token -- @@ -73,16 +77,18 @@ -- | Close notification close :: Notification -> IO () -close n = () <$ do - notify_init "haskell-libnotify" - notify_notification_close (unNotification n) +close Notification {name, token} = () <$ do + _ <- notify_init name + notify_notification_close token -- | A notification modifier -data Mod a = Mod (Last a) (a -> IO ()) +data Mod a = -- the unused type parameter cannot be removed without breaking backward compatibility + Mod (Last NotifyNotification) (Last String) (NotifyNotification -> String -> IO ()) instance Monoid (Mod a) where - mempty = Mod mempty (\_ -> return ()) - mappend (Mod x fx) (Mod y fy) = Mod (x <> y) (\n -> fx n >> fy n) + mempty = Mod mempty mempty (\_ _ -> return ()) + mappend (Mod u x fx) (Mod v y fy) = + Mod (u <> v) (x <> y) (\token name -> fx token name >> fy token name) -- | Set notification summary -- @@ -164,8 +170,8 @@ -> (Notification -> String -> IO a) -- ^ Callback -> Mod Notification action a l f = - Mod mempty (\n -> notify_notification_add_action (unNotification n) a l - (\p s' -> () <$ f (Notification p) s')) + Mod mempty mempty + (\token name -> notify_notification_add_action token a l (\p s' -> () <$ f (Notification p name) s')) -- | Remove all actions from the notification -- @@ -176,6 +182,10 @@ noactions :: Mod Notification noactions = act notify_notification_clear_actions +-- | Set the application name. +appName :: String -> Mod Notification +appName name = Mod mempty (Last (Just name)) (\_ _ -> return ()) + -- | Reuse existing notification token, instead of creating a new one -- -- If you try to reuse multiple tokens, the last one wins, e.g. @@ -188,8 +198,12 @@ -- -- <> reuse :: Notification -> Mod Notification -reuse n = Mod (Last (Just n)) (\_ -> return ()) +reuse Notification {token, name} = Mod (Last (Just token)) (Last (Just name)) (\_ _ -> return ()) -- A helper for making an I/O 'Mod' act :: (NotifyNotification -> IO ()) -> Mod Notification -act f = Mod mempty (f . unNotification) +act f = Mod mempty mempty (\token _name -> f token) + +-- The default application name used unless the user specifies the preferred one with 'appName'. +defaultAppName :: String +defaultAppName = "haskell-libnotify" diff --git a/src/Libnotify/C/Notify.hsc b/src/Libnotify/C/Notify.hsc --- a/src/Libnotify/C/Notify.hsc +++ b/src/Libnotify/C/Notify.hsc @@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} -- | Low level bindings to libnotify -- -- See also . Haddocks here @@ -72,10 +73,10 @@ -- | Server information data ServerInfo = ServerInfo - { name :: String - , vendor :: String - , version :: String - , specVersion :: String + { serverName :: String + , serverVendor :: String + , serverVersion :: String + , serverSpecVersion :: String } deriving (Show, Eq, Typeable, Data, Generic) -- | Return server information @@ -95,11 +96,11 @@ ret <- notify_get_server_info_c p_name p_vendor p_version p_specVersion if ret then do - name <- peekCString =<< peek p_name - vendor <- peekCString =<< peek p_vendor - version <- peekCString =<< peek p_version - specVersion <- peekCString =<< peek p_specVersion - return $ Just ServerInfo { name, vendor, version, specVersion } + serverName <- peekCString =<< peek p_name + serverVendor <- peekCString =<< peek p_vendor + serverVersion <- peekCString =<< peek p_version + serverSpecVersion <- peekCString =<< peek p_specVersion + return $ Just ServerInfo {..} else return Nothing