module System.Taffybar.WindowIcon where

import           Control.Concurrent
import           Control.Monad
import           Control.Monad.IO.Class
import           Control.Monad.Trans.Class
import           Control.Monad.Trans.Maybe
import           Data.Bits
import           Data.Int
import           Data.List
import qualified Data.Map as M
import           Data.Maybe
import qualified Data.MultiMap as MM
import           Data.Ord
import qualified Data.Text as T
import           Data.Word
import           Foreign.Marshal.Alloc
import           Foreign.Marshal.Array
import           Foreign.Ptr
import           Foreign.Storable
import qualified GI.GdkPixbuf.Enums as Gdk
import qualified GI.GdkPixbuf.Objects.Pixbuf as Gdk
import           System.Log.Logger
import           System.Taffybar.Context
import           System.Taffybar.Hooks
import           System.Taffybar.Information.Chrome
import           System.Taffybar.Information.EWMHDesktopInfo
import           System.Taffybar.Information.X11DesktopInfo
import           System.Environment.XDG.DesktopEntry
import           System.Taffybar.Util
import           System.Taffybar.Widget.Util
import           Text.Printf

type ColorRGBA = Word32

-- | Convert a C array of integer pixels in the ARGB format to the ABGR format.
-- Returns an unmanged Ptr that points to a block of memory that must be freed
-- manually.
pixelsARGBToBytesABGR
  :: (Storable a, Bits a, Num a, Integral a)
  => Ptr a -> Int -> IO (Ptr Word8)
pixelsARGBToBytesABGR :: forall a.
(Storable a, Bits a, Num a, Integral a) =>
Ptr a -> Int -> IO (Ptr Word8)
pixelsARGBToBytesABGR Ptr a
ptr Int
size = do
  target <- Int -> IO (Ptr Word8)
forall a. Storable a => Int -> IO (Ptr a)
mallocArray (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4)
  let writeIndex Int
i = do
        bits <- Ptr a -> Int -> IO a
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr a
ptr Int
i
        let b = a -> Word8
toByte a
bits
            g = a -> Word8
toByte (a -> Word8) -> a -> Word8
forall a b. (a -> b) -> a -> b
$ a
bits a -> Int -> a
forall a. Bits a => a -> Int -> a
`shift` (-Int
8)
            r = a -> Word8
toByte (a -> Word8) -> a -> Word8
forall a b. (a -> b) -> a -> b
$ a
bits a -> Int -> a
forall a. Bits a => a -> Int -> a
`shift` (-Int
16)
            a = a -> Word8
toByte (a -> Word8) -> a -> Word8
forall a b. (a -> b) -> a -> b
$ a
bits a -> Int -> a
forall a. Bits a => a -> Int -> a
`shift` (-Int
24)
            baseTarget = Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
i
            doPoke Int
offset = Ptr Word8 -> Int -> Word8 -> IO ()
forall a. Storable a => Ptr a -> Int -> a -> IO ()
pokeElemOff Ptr Word8
target (Int
baseTarget Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset)
            toByte = a -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Word8) -> (a -> a) -> a -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0xFF)
        doPoke 0 r
        doPoke 1 g
        doPoke 2 b
        doPoke 3 a
      writeIndexAndNext Int
i
        | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
size = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | Bool
otherwise = Int -> IO ()
writeIndex Int
i IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
writeIndexAndNext (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
  writeIndexAndNext 0
  return target

selectEWMHIcon :: Int32 -> [EWMHIcon] -> Maybe EWMHIcon
selectEWMHIcon :: Int32 -> [EWMHIcon] -> Maybe EWMHIcon
selectEWMHIcon Int32
imgSize [EWMHIcon]
icons = [EWMHIcon] -> Maybe EWMHIcon
forall a. [a] -> Maybe a
listToMaybe [EWMHIcon]
prefIcon
  where
    sortedIcons :: [EWMHIcon]
sortedIcons = (EWMHIcon -> EWMHIcon -> Ordering) -> [EWMHIcon] -> [EWMHIcon]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((EWMHIcon -> Int) -> EWMHIcon -> EWMHIcon -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing EWMHIcon -> Int
ewmhHeight) [EWMHIcon]
icons
    smallestLargerIcon :: [EWMHIcon]
smallestLargerIcon =
      Int -> [EWMHIcon] -> [EWMHIcon]
forall a. Int -> [a] -> [a]
take Int
1 ([EWMHIcon] -> [EWMHIcon]) -> [EWMHIcon] -> [EWMHIcon]
forall a b. (a -> b) -> a -> b
$ (EWMHIcon -> Bool) -> [EWMHIcon] -> [EWMHIcon]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
imgSize) (Int -> Bool) -> (EWMHIcon -> Int) -> EWMHIcon -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EWMHIcon -> Int
ewmhHeight) [EWMHIcon]
sortedIcons
    largestIcon :: [EWMHIcon]
largestIcon = Int -> [EWMHIcon] -> [EWMHIcon]
forall a. Int -> [a] -> [a]
take Int
1 ([EWMHIcon] -> [EWMHIcon]) -> [EWMHIcon] -> [EWMHIcon]
forall a b. (a -> b) -> a -> b
$ [EWMHIcon] -> [EWMHIcon]
forall a. [a] -> [a]
reverse [EWMHIcon]
sortedIcons
    prefIcon :: [EWMHIcon]
prefIcon = [EWMHIcon]
smallestLargerIcon [EWMHIcon] -> [EWMHIcon] -> [EWMHIcon]
forall a. [a] -> [a] -> [a]
++ [EWMHIcon]
largestIcon

getPixbufFromEWMHIcons :: Int32 -> [EWMHIcon] -> IO (Maybe Gdk.Pixbuf)
getPixbufFromEWMHIcons :: Int32 -> [EWMHIcon] -> IO (Maybe Pixbuf)
getPixbufFromEWMHIcons Int32
size = (EWMHIcon -> IO Pixbuf) -> Maybe EWMHIcon -> IO (Maybe Pixbuf)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse EWMHIcon -> IO Pixbuf
pixBufFromEWMHIcon (Maybe EWMHIcon -> IO (Maybe Pixbuf))
-> ([EWMHIcon] -> Maybe EWMHIcon)
-> [EWMHIcon]
-> IO (Maybe Pixbuf)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> [EWMHIcon] -> Maybe EWMHIcon
selectEWMHIcon Int32
size

-- | Create a pixbuf from the pixel data in an EWMHIcon.
pixBufFromEWMHIcon :: EWMHIcon -> IO Gdk.Pixbuf
pixBufFromEWMHIcon :: EWMHIcon -> IO Pixbuf
pixBufFromEWMHIcon EWMHIcon {ewmhWidth :: EWMHIcon -> Int
ewmhWidth = Int
w, ewmhHeight :: EWMHIcon -> Int
ewmhHeight = Int
h, ewmhPixelsARGB :: EWMHIcon -> Ptr X11Window
ewmhPixelsARGB = Ptr X11Window
px} = do
  let width :: Int32
width = Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
w
      height :: Int32
height = Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
h
      rowStride :: Int32
rowStride = Int32
width Int32 -> Int32 -> Int32
forall a. Num a => a -> a -> a
* Int32
4
  wPtr <- Ptr X11Window -> Int -> IO (Ptr Word8)
forall a.
(Storable a, Bits a, Num a, Integral a) =>
Ptr a -> Int -> IO (Ptr Word8)
pixelsARGBToBytesABGR Ptr X11Window
px (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
h)
  Gdk.pixbufNewFromData wPtr Gdk.ColorspaceRgb True 8
     width height rowStride (Just free)

getIconPixBufFromEWMH :: Int32 -> X11Window -> X11Property (Maybe Gdk.Pixbuf)
getIconPixBufFromEWMH :: Int32 -> X11Window -> X11Property (Maybe Pixbuf)
getIconPixBufFromEWMH Int32
size X11Window
x11WindowId = MaybeT (ReaderT X11Context IO) Pixbuf -> X11Property (Maybe Pixbuf)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (ReaderT X11Context IO) Pixbuf
 -> X11Property (Maybe Pixbuf))
-> MaybeT (ReaderT X11Context IO) Pixbuf
-> X11Property (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ do
  ewmhData <- ReaderT X11Context IO (Maybe EWMHIconData)
-> MaybeT (ReaderT X11Context IO) EWMHIconData
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (ReaderT X11Context IO (Maybe EWMHIconData)
 -> MaybeT (ReaderT X11Context IO) EWMHIconData)
-> ReaderT X11Context IO (Maybe EWMHIconData)
-> MaybeT (ReaderT X11Context IO) EWMHIconData
forall a b. (a -> b) -> a -> b
$ X11Window -> ReaderT X11Context IO (Maybe EWMHIconData)
getWindowIconsData X11Window
x11WindowId
  MaybeT $ lift $ withEWMHIcons ewmhData (getPixbufFromEWMHIcons size)

-- | Create a pixbuf with the indicated RGBA color.
pixBufFromColor
  :: MonadIO m
  => Int32 -> Word32 -> m Gdk.Pixbuf
pixBufFromColor :: forall (m :: * -> *). MonadIO m => Int32 -> Word32 -> m Pixbuf
pixBufFromColor Int32
imgSize Word32
c = do
  pixbuf <- Maybe Pixbuf -> Pixbuf
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Pixbuf -> Pixbuf) -> m (Maybe Pixbuf) -> m Pixbuf
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Colorspace -> Bool -> Int32 -> Int32 -> Int32 -> m (Maybe Pixbuf)
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
Colorspace -> Bool -> Int32 -> Int32 -> Int32 -> m (Maybe Pixbuf)
Gdk.pixbufNew Colorspace
Gdk.ColorspaceRgb Bool
True Int32
8 Int32
imgSize Int32
imgSize
  Gdk.pixbufFill pixbuf c
  return pixbuf

getDirectoryEntryByClass
  :: String
  -> TaffyIO (Maybe DesktopEntry)
getDirectoryEntryByClass :: String -> TaffyIO (Maybe DesktopEntry)
getDirectoryEntryByClass String
klass = do
  entries <- String -> MultiMap String DesktopEntry -> [DesktopEntry]
forall k a. Ord k => k -> MultiMap k a -> [a]
MM.lookup String
klass (MultiMap String DesktopEntry -> [DesktopEntry])
-> ReaderT Context IO (MultiMap String DesktopEntry)
-> ReaderT Context IO [DesktopEntry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT Context IO (MultiMap String DesktopEntry)
getDirectoryEntriesByClassName
  when (length entries > 1) $ liftIO $
       logM "System.Taffybar.WindowIcon" DEBUG $ printf
         "Class \"%s\" has multiple desktop entries: %s"
         klass (intercalate ", " $ map deFilename entries)
  return $ listToMaybe entries

getWindowIconForAllClasses
  :: Monad m
  => (p -> String -> m (Maybe a)) -> p -> String -> m (Maybe a)
getWindowIconForAllClasses :: forall (m :: * -> *) p a.
Monad m =>
(p -> String -> m (Maybe a)) -> p -> String -> m (Maybe a)
getWindowIconForAllClasses p -> String -> m (Maybe a)
doOnClass p
size String
klass =
  (m (Maybe a) -> String -> m (Maybe a))
-> m (Maybe a) -> [String] -> m (Maybe a)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl m (Maybe a) -> String -> m (Maybe a)
combine (Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing) ([String] -> m (Maybe a)) -> [String] -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ String -> [String]
parseWindowClasses String
klass
  where
    combine :: m (Maybe a) -> String -> m (Maybe a)
combine m (Maybe a)
soFar String
theClass =
      m (Maybe a) -> m (Maybe a) -> m (Maybe a)
forall (m :: * -> *) a.
Monad m =>
m (Maybe a) -> m (Maybe a) -> m (Maybe a)
maybeTCombine m (Maybe a)
soFar (p -> String -> m (Maybe a)
doOnClass p
size String
theClass)

getWindowIconFromDesktopEntryByClasses ::
     Int32 -> String -> TaffyIO (Maybe Gdk.Pixbuf)
getWindowIconFromDesktopEntryByClasses :: Int32 -> String -> TaffyIO (Maybe Pixbuf)
getWindowIconFromDesktopEntryByClasses =
  (Int32 -> String -> TaffyIO (Maybe Pixbuf))
-> Int32 -> String -> TaffyIO (Maybe Pixbuf)
forall (m :: * -> *) p a.
Monad m =>
(p -> String -> m (Maybe a)) -> p -> String -> m (Maybe a)
getWindowIconForAllClasses Int32 -> String -> TaffyIO (Maybe Pixbuf)
getWindowIconFromDesktopEntryByClass
  where getWindowIconFromDesktopEntryByClass :: Int32 -> String -> TaffyIO (Maybe Pixbuf)
getWindowIconFromDesktopEntryByClass Int32
size String
klass =
          MaybeT (ReaderT Context IO) Pixbuf -> TaffyIO (Maybe Pixbuf)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (ReaderT Context IO) Pixbuf -> TaffyIO (Maybe Pixbuf))
-> MaybeT (ReaderT Context IO) Pixbuf -> TaffyIO (Maybe Pixbuf)
forall a b. (a -> b) -> a -> b
$ do
            entry <- TaffyIO (Maybe DesktopEntry)
-> MaybeT (ReaderT Context IO) DesktopEntry
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (TaffyIO (Maybe DesktopEntry)
 -> MaybeT (ReaderT Context IO) DesktopEntry)
-> TaffyIO (Maybe DesktopEntry)
-> MaybeT (ReaderT Context IO) DesktopEntry
forall a b. (a -> b) -> a -> b
$ String -> TaffyIO (Maybe DesktopEntry)
getDirectoryEntryByClass String
klass
            lift $ logPrintF "System.Taffybar.WindowIcon" DEBUG
                   "Using desktop entry for icon %s"
                   (deFilename entry, klass)
            MaybeT $ lift $ getImageForDesktopEntry size entry

getWindowIconFromClasses :: Int32 -> String -> IO (Maybe Gdk.Pixbuf)
getWindowIconFromClasses :: Int32 -> String -> IO (Maybe Pixbuf)
getWindowIconFromClasses =
  (Int32 -> String -> IO (Maybe Pixbuf))
-> Int32 -> String -> IO (Maybe Pixbuf)
forall (m :: * -> *) p a.
Monad m =>
(p -> String -> m (Maybe a)) -> p -> String -> m (Maybe a)
getWindowIconForAllClasses Int32 -> String -> IO (Maybe Pixbuf)
getWindowIconFromClass
  where getWindowIconFromClass :: Int32 -> String -> IO (Maybe Pixbuf)
getWindowIconFromClass Int32
size String
klass = Int32 -> Text -> IO (Maybe Pixbuf)
loadPixbufByName Int32
size (String -> Text
T.pack String
klass)

getPixBufFromChromeData :: X11Window -> TaffyIO (Maybe Gdk.Pixbuf)
getPixBufFromChromeData :: X11Window -> TaffyIO (Maybe Pixbuf)
getPixBufFromChromeData X11Window
window = do
  imageData <- TaffyIO (MVar (Map Int ChromeTabImageData))
getChromeTabImageDataTable TaffyIO (MVar (Map Int ChromeTabImageData))
-> (MVar (Map Int ChromeTabImageData)
    -> ReaderT Context IO (Map Int ChromeTabImageData))
-> ReaderT Context IO (Map Int ChromeTabImageData)
forall a b.
ReaderT Context IO a
-> (a -> ReaderT Context IO b) -> ReaderT Context IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (Map Int ChromeTabImageData)
-> ReaderT Context IO (Map Int ChromeTabImageData)
forall (m :: * -> *) a. Monad m => m a -> ReaderT Context m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Map Int ChromeTabImageData)
 -> ReaderT Context IO (Map Int ChromeTabImageData))
-> (MVar (Map Int ChromeTabImageData)
    -> IO (Map Int ChromeTabImageData))
-> MVar (Map Int ChromeTabImageData)
-> ReaderT Context IO (Map Int ChromeTabImageData)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar (Map Int ChromeTabImageData)
-> IO (Map Int ChromeTabImageData)
forall a. MVar a -> IO a
readMVar
  X11WindowToChromeTabId x11LookupMapVar <- getX11WindowToChromeTabId
  x11LookupMap <- lift $ readMVar x11LookupMapVar
  return $ tabImageData <$> (M.lookup window x11LookupMap >>= flip M.lookup imageData)