Иконка в трее для программы на Хаскелле (win32)
Предположим, нам нужно сделать какую-то утилитку, которая будет себе висеть фоновым процессом и время от времени информировать нас о своём состоянии иконкой в трее.
Для этого нам нужно выделить основное действие программы в отдельную процедуру, которая циклически вызывается. В нашем примере мы создадим переменную, которую будем изменять от 0 до 2 и соответственно переключать картинку на иконке в трее, а затем усыплять процесс на полсекунды, что бы потом повторить цикл снова...
Итак, главный модуль программы Main.hs выглядит так:
module Main where
import Data.IORef
import System.Win32.Process
import HTrayIcon
---------------------------------------------------------------------------------------------------
main :: IO ()
main = do
-- Инициализация программы
num <- newIORef 0
-- Создадим иконку и запустим основной цикл программы
withTrayIconLoop $ mainAction num
---------------------------------------------------------------------------------------------------
mainAction :: IORef Int -> IconHnd -> IO ()
mainAction num icon = do
-- Что-нибудь делаем
n <- readIORef num
writeIORef num $ (n+1) `mod` 3
modifyTrayIcon icon n -- Меняем иконку в трее
sleep 500 -- Поели -- можно поспать...
Затем нужен ещё модуль HTrayIcon.hs, который создаёт невидимое окошко, иконку в трее, грузит файлы иконок и организует цикл обработки сообщений, чередующейся с нашей главной работой...
module HTrayIcon ( IconHnd -- Maybe (HWND, [HICON])
, withTrayIconLoop -- (IconHnd -> IO ()) -> IO ()
, modifyTrayIcon -- IconHnd -> Int -> IO ()
)
where
import Control.Monad
import Control.Concurrent.Chan
import qualified Control.OldException as E
import qualified System.Win32.DLL as DLL
import qualified Graphics.Win32 as W32
import System.Win32.Types
---------------------------------------------------------------------------------------------------
-- | Пара, состоящая из указателя на главное окно программы
-- и списка указателей на картинки для иконки в трее
--
type IconHnd = Maybe (W32.HWND, [W32.HICON])
---------------------------------------------------------------------------------------------------
-- | Основной цикл программы, чередующий выполнение главного действия и обработку сообщений Windows
--
withTrayIconLoop :: (IconHnd -> IO ()) -> IO ()
withTrayIconLoop action = do
quitChan <- newChan -- Спецканал для сообщения о завершении программы
mainInstance <- DLL.getModuleHandle Nothing
let winClass = W32.mkClassName "TrayIconTestClass"
res <- W32.registerClass ( 0, mainInstance, Nothing, Nothing, Nothing, Nothing, winClass )
case res of
Nothing -> return ()
_ -> do
hWnd <- W32.createWindow -- Создадим главное окно программы, но отображать его не будем
winClass "TrayIconTest" 0
Nothing Nothing Nothing Nothing
Nothing Nothing
mainInstance
(wndProc quitChan)
icon <- createTrayIcon hWnd -- Создадим иконку в трее
W32.allocaMessage $ \msg -> do -- Выделим память под сообщения Windows
let mainLoop = do -- Основной цикл программы
action icon -- Главное действие программы, выполняемое в основном цикле
ok <- W32.c_PeekMessage msg hWnd 0 0 1 -- Посмотрим, нет ли для нас сообщений
when (ok /= 0) $ do -- Если есть, обработаем их
W32.translateMessage msg
W32.dispatchMessage msg >>= ignore
empty <- isEmptyChan quitChan -- Пришло ли сообщение о завершении программы?
when empty mainLoop -- Если нет, то повторим основной цикл
mainLoop -- Запустим основной цикл программы
---------------------------------------------------------------------------------------------------
--
wndProc :: Chan () -> W32.HWND -> W32.WindowMessage -> W32.WPARAM -> W32.LPARAM -> IO W32.LRESULT
wndProc quitChan hWnd wMsg wParam lParam
| wMsg == W32.wM_DESTROY = do W32.sendMessage hWnd W32.wM_QUIT 1 0
quitChan `writeChan` () -- Программа должна быть завершена
return 0
| otherwise = W32.defWindowProc (Just hWnd) wMsg wParam lParam
---------------------------------------------------------------------------------------------------
--
foreign import ccall unsafe "trayicon.h TrayIcon"
c_TrayIcon :: DWORD -> W32.HWND -> W32.HICON -> IO Bool
nIM_ADD :: DWORD; nIM_ADD = 0
nIM_MODIFY :: DWORD; nIM_MODIFY = 1
---------------------------------------------------------------------------------------------------
-- | Загружает иконку из файла fname
--
loadIcon :: String -> IO W32.HICON
loadIcon fname =
W32.loadImage nullPtr fname W32.iMAGE_ICON 16 16 $! W32.lR_LOADFROMFILE + W32.lR_DEFAULTCOLOR
---------------------------------------------------------------------------------------------------
-- | Создаёт иконку в трее для данного ей окна
-- Загружает три иконки из файлов 0.ico, 1.ico и 2.ico, которые потом можно
-- отображать в трее с помощью процедуры modifyTrayIcon, передавая ей номер иконки (0..2)
--
createTrayIcon :: W32.HWND -> IO IconHnd
createTrayIcon hWnd = do
hics <- mapM loadIcon ["0.ico", "1.ico", "2.ico"]
result <- c_TrayIcon nIM_ADD hWnd (hics!!0)
case result of
True -> return $! Just (hWnd, hics)
False -> return Nothing
`E.catch` \_ -> return Nothing
---------------------------------------------------------------------------------------------------
-- | Меняет иконку в трее
--
modifyTrayIcon :: IconHnd -> Int -> IO ()
modifyTrayIcon (Just (hWnd, hics)) n = c_TrayIcon nIM_MODIFY hWnd (hics!!n) >> return ()
modifyTrayIcon Nothing _ = return ()
---------------------------------------------------------------------------------------------------
-- | Игнорирует переданный ей параметр
--
ignore :: a -> IO ()
ignore _ = return ()
Ну и, наконец, пара файликов на Си (увы, пока никто не удосужился сделать обёртку для функции WinAPI Shell_NotifyIcon и структуры NOTIFYICONDATA):
trayicon.h
BOOL TrayIcon(DWORD msg, HWND hWnd, HICON hic);
и trayicon.c
#include
#include
BOOL TrayIcon(DWORD msg, HWND hWnd, HICON hic)
{
NOTIFYICONDATA tnd;
tnd.cbSize = sizeof(NOTIFYICONDATA);
tnd.hWnd = hWnd;
tnd.uID = 0;
tnd.uFlags = NIF_MESSAGE | NIF_ICON | NIF_TIP;
tnd.uCallbackMessage = 0;
tnd.hIcon = hic;
tnd.szTip[0] = 0;
return Shell_NotifyIcon(msg, &tnd);
}
Компилируем всё это дело:
e:\P\ghc-6.10.1\bin\ghc.exe --make Main.hs trayicon.c -o Main.exe -O3 -fglasgow-exts -Wall -fno-gen-manifest -optl-mwindows
запускаем и смотрим, как в трее меняется иконка с цифрами 0, 1, 2!
Ах да, сначала же ещё нужно создать файлы с иконками 0.ico, 1.ico и 2.ico. Ну, это уже дело техники... :о)
ЗЫ. Вначале я выделял основную работу в отдельный поток, но с Threaded-RTS возникли какие-то утечки памяти, а без него этот поток ни в какую не хотел работать.
Потом я решил было убрать обработку сообщений, но обнаружил. что при выключении питания компьютера винда ругается на неотвечающую программу -- встанет столбом и спрашивает, что ей делать. Ладно там для десктопа пойдёт, а если какой-то терминал, у которого ни клавиатуры стандартной, ни мышки, ни даже сенсорного экрана?..
Пришлось вернуть обработку событий, но вставить её в в главный цикл программы... :о(
ЗЗЫ. Может быть кто из знатоков WinAPI укажет мне на возможные кривизны кода?
Для этого нам нужно выделить основное действие программы в отдельную процедуру, которая циклически вызывается. В нашем примере мы создадим переменную, которую будем изменять от 0 до 2 и соответственно переключать картинку на иконке в трее, а затем усыплять процесс на полсекунды, что бы потом повторить цикл снова...
Итак, главный модуль программы Main.hs выглядит так:
module Main where
import Data.IORef
import System.Win32.Process
import HTrayIcon
---------------------------------------------------------------------------------------------------
main :: IO ()
main = do
-- Инициализация программы
num <- newIORef 0
-- Создадим иконку и запустим основной цикл программы
withTrayIconLoop $ mainAction num
---------------------------------------------------------------------------------------------------
mainAction :: IORef Int -> IconHnd -> IO ()
mainAction num icon = do
-- Что-нибудь делаем
n <- readIORef num
writeIORef num $ (n+1) `mod` 3
modifyTrayIcon icon n -- Меняем иконку в трее
sleep 500 -- Поели -- можно поспать...
Затем нужен ещё модуль HTrayIcon.hs, который создаёт невидимое окошко, иконку в трее, грузит файлы иконок и организует цикл обработки сообщений, чередующейся с нашей главной работой...
module HTrayIcon ( IconHnd -- Maybe (HWND, [HICON])
, withTrayIconLoop -- (IconHnd -> IO ()) -> IO ()
, modifyTrayIcon -- IconHnd -> Int -> IO ()
)
where
import Control.Monad
import Control.Concurrent.Chan
import qualified Control.OldException as E
import qualified System.Win32.DLL as DLL
import qualified Graphics.Win32 as W32
import System.Win32.Types
---------------------------------------------------------------------------------------------------
-- | Пара, состоящая из указателя на главное окно программы
-- и списка указателей на картинки для иконки в трее
--
type IconHnd = Maybe (W32.HWND, [W32.HICON])
---------------------------------------------------------------------------------------------------
-- | Основной цикл программы, чередующий выполнение главного действия и обработку сообщений Windows
--
withTrayIconLoop :: (IconHnd -> IO ()) -> IO ()
withTrayIconLoop action = do
quitChan <- newChan -- Спецканал для сообщения о завершении программы
mainInstance <- DLL.getModuleHandle Nothing
let winClass = W32.mkClassName "TrayIconTestClass"
res <- W32.registerClass ( 0, mainInstance, Nothing, Nothing, Nothing, Nothing, winClass )
case res of
Nothing -> return ()
_ -> do
hWnd <- W32.createWindow -- Создадим главное окно программы, но отображать его не будем
winClass "TrayIconTest" 0
Nothing Nothing Nothing Nothing
Nothing Nothing
mainInstance
(wndProc quitChan)
icon <- createTrayIcon hWnd -- Создадим иконку в трее
W32.allocaMessage $ \msg -> do -- Выделим память под сообщения Windows
let mainLoop = do -- Основной цикл программы
action icon -- Главное действие программы, выполняемое в основном цикле
ok <- W32.c_PeekMessage msg hWnd 0 0 1 -- Посмотрим, нет ли для нас сообщений
when (ok /= 0) $ do -- Если есть, обработаем их
W32.translateMessage msg
W32.dispatchMessage msg >>= ignore
empty <- isEmptyChan quitChan -- Пришло ли сообщение о завершении программы?
when empty mainLoop -- Если нет, то повторим основной цикл
mainLoop -- Запустим основной цикл программы
---------------------------------------------------------------------------------------------------
--
wndProc :: Chan () -> W32.HWND -> W32.WindowMessage -> W32.WPARAM -> W32.LPARAM -> IO W32.LRESULT
wndProc quitChan hWnd wMsg wParam lParam
| wMsg == W32.wM_DESTROY = do W32.sendMessage hWnd W32.wM_QUIT 1 0
quitChan `writeChan` () -- Программа должна быть завершена
return 0
| otherwise = W32.defWindowProc (Just hWnd) wMsg wParam lParam
---------------------------------------------------------------------------------------------------
--
foreign import ccall unsafe "trayicon.h TrayIcon"
c_TrayIcon :: DWORD -> W32.HWND -> W32.HICON -> IO Bool
nIM_ADD :: DWORD; nIM_ADD = 0
nIM_MODIFY :: DWORD; nIM_MODIFY = 1
---------------------------------------------------------------------------------------------------
-- | Загружает иконку из файла fname
--
loadIcon :: String -> IO W32.HICON
loadIcon fname =
W32.loadImage nullPtr fname W32.iMAGE_ICON 16 16 $! W32.lR_LOADFROMFILE + W32.lR_DEFAULTCOLOR
---------------------------------------------------------------------------------------------------
-- | Создаёт иконку в трее для данного ей окна
-- Загружает три иконки из файлов 0.ico, 1.ico и 2.ico, которые потом можно
-- отображать в трее с помощью процедуры modifyTrayIcon, передавая ей номер иконки (0..2)
--
createTrayIcon :: W32.HWND -> IO IconHnd
createTrayIcon hWnd = do
hics <- mapM loadIcon ["0.ico", "1.ico", "2.ico"]
result <- c_TrayIcon nIM_ADD hWnd (hics!!0)
case result of
True -> return $! Just (hWnd, hics)
False -> return Nothing
`E.catch` \_ -> return Nothing
---------------------------------------------------------------------------------------------------
-- | Меняет иконку в трее
--
modifyTrayIcon :: IconHnd -> Int -> IO ()
modifyTrayIcon (Just (hWnd, hics)) n = c_TrayIcon nIM_MODIFY hWnd (hics!!n) >> return ()
modifyTrayIcon Nothing _ = return ()
---------------------------------------------------------------------------------------------------
-- | Игнорирует переданный ей параметр
--
ignore :: a -> IO ()
ignore _ = return ()
Ну и, наконец, пара файликов на Си (увы, пока никто не удосужился сделать обёртку для функции WinAPI Shell_NotifyIcon и структуры NOTIFYICONDATA):
trayicon.h
BOOL TrayIcon(DWORD msg, HWND hWnd, HICON hic);
и trayicon.c
#include
#include
BOOL TrayIcon(DWORD msg, HWND hWnd, HICON hic)
{
NOTIFYICONDATA tnd;
tnd.cbSize = sizeof(NOTIFYICONDATA);
tnd.hWnd = hWnd;
tnd.uID = 0;
tnd.uFlags = NIF_MESSAGE | NIF_ICON | NIF_TIP;
tnd.uCallbackMessage = 0;
tnd.hIcon = hic;
tnd.szTip[0] = 0;
return Shell_NotifyIcon(msg, &tnd);
}
Компилируем всё это дело:
e:\P\ghc-6.10.1\bin\ghc.exe --make Main.hs trayicon.c -o Main.exe -O3 -fglasgow-exts -Wall -fno-gen-manifest -optl-mwindows
запускаем и смотрим, как в трее меняется иконка с цифрами 0, 1, 2!
Ах да, сначала же ещё нужно создать файлы с иконками 0.ico, 1.ico и 2.ico. Ну, это уже дело техники... :о)
ЗЫ. Вначале я выделял основную работу в отдельный поток, но с Threaded-RTS возникли какие-то утечки памяти, а без него этот поток ни в какую не хотел работать.
Потом я решил было убрать обработку сообщений, но обнаружил. что при выключении питания компьютера винда ругается на неотвечающую программу -- встанет столбом и спрашивает, что ей делать. Ладно там для десктопа пойдёт, а если какой-то терминал, у которого ни клавиатуры стандартной, ни мышки, ни даже сенсорного экрана?..
Пришлось вернуть обработку событий, но вставить её в в главный цикл программы... :о(
ЗЗЫ. Может быть кто из знатоков WinAPI укажет мне на возможные кривизны кода?