status-notifier-item 0.2.2.0 → 0.2.2.1

raw patch · 3 files changed

+89/−38 lines, 3 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• src/StatusNotifier/Host/Service.hs +73/−33
• src/StatusNotifier/Util.hs +12/−2
• status-notifier-item.cabal +4/−3

@@ -80,16 +80,8 @@   , menuPath :: Maybe ObjectPath   } deriving (Eq, Show) -defaultItemInfo =-  ItemInfo-  { itemServiceName = "a.b"-  , itemServicePath = "/"-  , iconThemePath = Nothing-  , iconName = ""-  , iconTitle = ""-  , iconPixmaps = []-  , menuPath = Nothing-  }+supressPixelData info =+  info { iconPixmaps = map (\(w, h, _) -> (w, h, "")) $ iconPixmaps info }  makeLensesWithLSuffix ''ItemInfo @@ -127,7 +119,7 @@       doUpdateForHandler utype uinfo (unique, handler) = do         logInfo (printf "Sending update (iconPixmaps suppressed): %s %s, for handler %s"                           (show utype)-                          (show $ uinfo { iconPixmaps = [] })+                          (show $ supressPixelData uinfo)                           (show $ hashUnique unique))         forkIO $ handler utype uinfo @@ -196,9 +188,16 @@         maybe I.defaultPath itemServicePath . Map.lookup name <$>         readMVar itemInfoMapVar -      handleItemRemoved serviceName = let busName = busName_ serviceName in-        modifyMVar_ itemInfoMapVar (return . Map.delete busName ) >>-        doUpdate ItemRemoved defaultItemInfo { itemServiceName = busName }+      handleItemRemoved serviceName =+        modifyMVar itemInfoMapVar doRemove >>=+        maybe logNonExistantRemoval (doUpdate ItemRemoved)+        where+          busName = busName_ serviceName+          doRemove currentMap =+            return (Map.delete busName currentMap, Map.lookup busName currentMap)+          logNonExistantRemoval =+            hostLogger WARNING $ printf "Attempt to remove unknown item %s" $+                       show busName        watcherRegistrationPairs =         [ (W.registerForStatusNotifierItemRegistered, const handleItemAdded)@@ -211,30 +210,71 @@        logPropError = logErrorWithMessage "Error updating property: " -      makeUpdaterFromProp = makeUpdaterFromProp' logPropError+      runProperty prop serviceName =+        getObjectPathForItemName serviceName >>= prop client serviceName -      makeUpdaterFromProp' onError lens updateType prop = getSender run-        where run sender =-                getObjectPathForItemName sender >>=-                prop client sender >>=-                either onError (runUpdate lens updateType sender)+      logUnknownSender updateType signal =+        hostLogger WARNING $+                   printf "Got signal for update type: %s from unknown sender: %s"+                   (show updateType) (show signal) -      runUpdate lens updateType sender newValue =-        modifyMVar itemInfoMapVar modify >>= callUpdate-          where modify infoMap =-                  let newMap = set (at sender . non defaultItemInfo . lens)-                               newValue infoMap-                  in return (newMap, Map.lookup sender newMap)-                callUpdate = flip whenJust (doUpdate updateType)+      logErrorsUpdater lens updateType prop signal =+        makeUpdaterFromProp lens updateType prop signal >>=+        either logPropError ((flip when logSenderErrorAndUpdateAll) . isNothing)+          where+            logSenderErrorAndUpdateAll = do+              logUnknownSender updateType signal+              void $ updatePropertyForAllItemInfos lens updateType prop -      updatePixmaps =+      makeUpdaterFromProp lens updateType prop+                          signal@M.Signal { M.signalSender = Just sender} =+        runExceptT $+          ExceptT (runProperty prop sender) >>=+          lift . runUpdateOfProperty lens updateType sender+      makeUpdaterFromProp _ _ _ _ = return $ Right Nothing++      runUpdateOfProperty lens updateType serviceName newValue = do+        maybeServiceInfo <- modifyMVar itemInfoMapVar modify+        whenJust maybeServiceInfo (doUpdate updateType)+        return maybeServiceInfo+          where+            modify infoMap =+              let newMap = set (at serviceName . _Just . lens) newValue infoMap+              in return (newMap, Map.lookup serviceName newMap)++      updatePropertyForAllItemInfos lens updateType prop = do+        readMVar itemInfoMapVar >>= mapM (runUpdateForService . itemServiceName)+        where runUpdateForService serviceName =+                runProperty prop serviceName >>=+                either (const $ return ())+                       (void . runUpdateOfProperty lens updateType serviceName)++      updateAllIcons =+        updatePropertyForAllItemInfos iconPixmapsL IconUpdated getPixmaps >>+        updatePropertyForAllItemInfos iconNameL IconNameUpdated I.getIconName++      handleNewPixmaps =         makeUpdaterFromProp iconPixmapsL IconUpdated getPixmaps-      handleNewIcon signal =-        makeUpdaterFromProp'-        (const $ updatePixmaps signal)-        iconNameL IconNameUpdated I.getIconName signal+      handleNewIconName =+        makeUpdaterFromProp iconNameL IconNameUpdated I.getIconName+      handleNewIcon signal = do+        newNameResult <- handleNewIconName signal+        newPixmapsResult <- handleNewPixmaps signal+        let remPD = right (fmap supressPixelData)+            result = (remPD newNameResult, remPD newPixmapsResult)+            debugLog = hostLogger DEBUG $ printf "Icon update results %s" (show result)+            updateAll = logUnknownSender IconUpdated signal >> void updateAllIcons+            gotProp = rights [newNameResult, newPixmapsResult]+            fullSuccess = catMaybes gotProp+        if null fullSuccess+        then if null gotProp+             then hostLogger WARNING $ printf+                    "Failed to load new icon with either method %s"+                    (show result)+             else updateAll+        else debugLog       handleNewTitle =-        makeUpdaterFromProp iconTitleL TitleUpdated I.getTitle+        logErrorsUpdater iconTitleL TitleUpdated I.getTitle        clientRegistrationPairs =         [ (I.registerForNewIcon, handleNewIcon)

@@ -4,14 +4,16 @@ import           Control.Arrow import           Control.Lens import           DBus.Client+import qualified DBus.Generation as G import qualified DBus.Internal.Message as M import qualified DBus.Internal.Types as T import qualified DBus.Introspection as I-import qualified DBus.Generation as G+import           Data.Bits import qualified Data.ByteString as BS import           Data.Maybe import qualified Data.Vector.Storable as VS import           Data.Vector.Storable.ByteString+import           Data.Word import           Language.Haskell.TH import           Network.Socket (ntohl) import           StatusNotifier.TH@@ -49,9 +51,17 @@ whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenJust = flip $ maybe $ return () +convertARGBToABGR :: Word32 -> Word32+convertARGBToABGR bits = (blue `shift` 16) .|. (red `shift` (-16)) .|. green .|. alpha+  where+    blue = bits .&. 0xFF+    green = bits .&. 0xFF00+    red = bits .&. 0xFF0000+    alpha = bits .&. 0xFF000000+ networkToSystemByteOrder :: BS.ByteString -> BS.ByteString networkToSystemByteOrder original =-  vectorToByteString $ VS.map ntohl $ byteStringToVector original+  vectorToByteString $ VS.map (convertARGBToABGR . ntohl) $ byteStringToVector original  maybeToEither :: b -> Maybe a -> Either b a maybeToEither = flip maybe Right . Left

@@ -1,11 +1,11 @@--- This file has been generated from package.yaml by hpack version 0.28.2.+-- This file has been generated from package.yaml by hpack version 0.21.2. -- -- see: https://github.com/sol/hpack ----- hash: fab14775734399bef953c7eccd528496b0abd4ae265b3f999bf78e2ee151b2b4+-- hash: 0c0d886a82dbaa1abe2f1122ced43a208b5f1e3444653dbbe36e8f2fc564a729  name:           status-notifier-item-version:        0.2.2.0+version:        0.2.2.1 synopsis:       A wrapper over the StatusNotifierItem/libappindicator dbus specification description:    Please see the README on Github at <https://github.com/IvanMalison/status-notifier-item#readme> category:       Desktop@@ -18,6 +18,7 @@ license-file:   LICENSE build-type:     Simple cabal-version:  >= 1.10+ extra-source-files:     ChangeLog.md     README.md