I need to do some action while button is pressed. How can I do it?
I have version 0.12.4.
P. S.:
For some reason, onButtonActivate in
import Graphics.UI.Gtk
import Control.Concurrent
main = do
initGUI
window <- windowNew
but <-buttonNewWithLabel "Write A"
onButtonActivate but $ do
putStr "A"
threadDelay 1000000
return()
containerAdd window but
widgetShowAll window
onDestroy window mainQuit
mainGUI
do not do anything.
Also, it's good to go, if action will be done repeatedly while pressed some key on keyboard.
According to the docs onButtonActivate is depreciated so you probably shouldn't use it. Im having trouble finding the correct way though, there probably are some generics signals somewhere that you should use. You can try my solution that uses onPressed and onRelease (these are also noted as depreciated). You could do as suggested in the comment and fork a thread:
import Control.Concurrent (forkIO, killThread, threadDelay)
import Control.Monad (void, when)
whilePressed button action = do
onPressed button $ do
threadId <- forkIO go
onReleased button (killThread threadId)
where
go = do
action
threadDelay 1000000
go
Then rewrite your main to do:
whilePressed but (putStr "A")
Im not sure if this is safe though, as it seems it could be possible for the buttonReleased event to be fired before killThread is registered. It might be safer to use an IORef:
import Data.IORef
whilePressed button action = do
isPressed <- newIORef False
onPressed button $ do
writeIORef isPressed True
void $ forkIO $ go isPressed
onReleased button (writeIORef isPressed False)
where
go isPressed = do
c <- readIORef isPressed
when c $ do
action
threadDelay 1000000
void $ forkIO $ go isPressed
Unfortunately I haven't compiled or tested the code sine I cannot install GTK on this computer, but let me know if you have any issues.
This uses a ToggleButton, a "timeout" object (see timeoutAdd in the module System.Glib.MainLoop in the docs) and an IORef. A timer is started when the ToggleButton is pressed down, but only if no other timer is currently running (that's the purpose of the IORef). If the button is released, the timer is stopped. The timer's callback function returns IO False to stop and destroy the timer object.
import Graphics.UI.Gtk
import Data.IORef
import Control.Monad(void, when)
action but idle = do
butDown <- get but toggleButtonActive
if butDown
then do
putStrLn "A"
writeIORef idle False
return True
else do
writeIORef idle True
return False
main = do
initGUI
window <- windowNew
but <-toggleButtonNewWithLabel "Write A"
idle <- newIORef True
on but toggled $ do
butDown <- get but toggleButtonActive
isIdle <- readIORef idle
when (butDown && isIdle) $ void $ timeoutAdd (action but idle) 1000
containerAdd window but
widgetShowAll window
on window objectDestroy mainQuit
mainGUI
The preferred way of registering signal callbacks is using "on". Also note that "on window objectDestroy mainQuit" correctly destroys the window and stops the Gtk main loop (you version didn't destroy the timers in GHCi, they kept running after calling "main" again).
Related
I'm currently authoring an application in Haskell that relies on Yesod and its web sockets implementation.
I was wondering what is the correct way to acquire and release resources for a WebSocketT handler.
For example, in the following naive case...
chatApp :: WebSocketsT Handler ()
chatApp = do
let outgoingFlow = forever $ deliverOutgoingMessages
let incomingFlow = forever $ deliverIncomingMessages
bracket_ acquireResource
releaseResource
(race_ outgoingFlow incomingFlow)
... releaseResource does not seem to be called when a client disconnects abruptly or purposefully.
This is what I ended up doing over the weekend. This is essentially a replication of how web socket background ping process works, apart for the fact that I'm not swallowing the ping send exception when the other end is no longer reachable, but rather using it to detect the disconnection.
echoApp' :: WebSocketsT Handler ()
echoApp' = do
conn <- ask
let acquire = putStrLn "Acquiring..."
release = putStrLn "Releasing"
hardWork = (threadDelay 600000000)
ping i = do
threadDelay (30 * 1000 * 1000)
WS.sendPing conn (T.pack $ show i)
ping (i + 1)
liftIO $ bracket_ acquire release $ race_ hardWork (ping 1)
The downside of this approach is that there's still an up to 30 seconds window when the web socket process is lingering, but at least the resource gets eventually released in a more or less controllable way.
I'm experimenting with the sample program at https://github.com/gtk2hs/gtk2hs/blob/master/gtk/demo/hello/World.hs, reproduced below:
-- A simple program to demonstrate Gtk2Hs.
module Main (Main.main) where
import Graphics.UI.Gtk
main :: IO ()
main = do
initGUI
-- Create a new window
window <- windowNew
-- Here we connect the "destroy" event to a signal handler.
-- This event occurs when we call widgetDestroy on the window
-- or if the user closes the window.
on window objectDestroy mainQuit
-- Sets the border width and tile of the window. Note that border width
-- attribute is in 'Container' from which 'Window' is derived.
set window [ containerBorderWidth := 10, windowTitle := "Hello World" ]
-- Creates a new button with the label "Hello World".
button <- buttonNew
set button [ buttonLabel := "Hello World" ]
-- When the button receives the "clicked" signal, it will call the
-- function given as the second argument.
on button buttonActivated (putStrLn "Hello World")
-- Gtk+ allows several callbacks for the same event.
-- This one will cause the window to be destroyed by calling
-- widgetDestroy. The callbacks are called in the sequence they were added.
on button buttonActivated $ do
putStrLn "A \"clicked\"-handler to say \"destroy\""
widgetDestroy window
-- Insert the hello-world button into the window.
set window [ containerChild := button ]
-- The final step is to display this newly created widget. Note that this
-- also allocates the right amount of space to the windows and the button.
widgetShowAll window
-- All Gtk+ applications must have a main loop. Control ends here
-- and waits for an event to occur (like a key press or mouse event).
-- This function returns if the program should finish.
mainGUI
If I build and run this on Mac OS X, Cmd-Q or the Quit command from the app's menu does not close the application. How do I trap this event and cause it to close the app?
Update
I've added a gtk3-mac-integration dependency to my project, an import Graphics.UI.Gtk.OSX to my source file and the following immediately after calling initGUI:
app <- applicationNew
on app willTerminate (return ())
I'm definitely missing something as this doesn't seem to do anything (see https://github.com/rcook/gtkapp/commit/8531509d0648ddb657633a33773c09bc5a576014).
Update no. 2
Thanks to #Jack Henahan and OSXDemo.hs, I now have a working solution:
-- A simple program to demonstrate Gtk2Hs.
module Main (Main.main) where
import Control.Exception
import Control.Monad
import Graphics.UI.Gtk
import Graphics.UI.Gtk.OSX
showDialog :: Window -> String -> String -> IO ()
showDialog window title message = bracket
(messageDialogNew (Just window) [] MessageInfo ButtonsOk message)
widgetDestroy
(\d -> do
set d [ windowTitle := title ]
void $ dialogRun d)
main :: IO ()
main = do
void initGUI
-- Create a new window
window <- windowNew
-- Here we connect the "destroy" event to a signal handler.
-- This event occurs when we call widgetDestroy on the window
-- or if the user closes the window.
void $ on window objectDestroy mainQuit
-- Sets the border width and tile of the window. Note that border width
-- attribute is in 'Container' from which 'Window' is derived.
set window [ containerBorderWidth := 10, windowTitle := "Hello World" ]
-- Creates a new button with the label "Hello World".
button <- buttonNew
set button [ buttonLabel := "Hello World" ]
-- When the button receives the "clicked" signal, it will call the
-- function given as the second argument.
void $ on button buttonActivated (putStrLn "Hello World")
void $ on button buttonActivated $ showDialog window "THE-TITLE" "THE-MESSAGE"
-- Gtk+ allows several callbacks for the same event.
-- This one will cause the window to be destroyed by calling
-- widgetDestroy. The callbacks are called in the sequence they were added.
void $ on button buttonActivated $ do
putStrLn "A \"clicked\"-handler to say \"destroy\""
widgetDestroy window
-- Insert the hello-world button into the window.
set window [ containerChild := button ]
-- The final step is to display this newly created widget. Note that this
-- also allocates the right amount of space to the windows and the button.
widgetShowAll window
app <- applicationNew
-- blockTermination: return True to prevent quit, False to allow
on app blockTermination $ do
putStrLn "blockTermination"
return False
-- willTerminate: handle clean-up etc.
on app willTerminate $ do
putStrLn "willTerminate"
menuBar <- menuBarNew
applicationSetMenuBar app menuBar
applicationReady app
-- All Gtk+ applications must have a main loop. Control ends here
-- and waits for an event to occur (like a key press or mouse event).
-- This function returns if the program should finish.
mainGUI
You need to send an NSApplicationWillTerminate signal.
willTerminate :: ApplicationClass self => Signal self (IO ())
willTerminate = Signal (connect_NONE__NONE "NSApplicationWillTerminate")
is how it's handled in gtk-mac-integration.
My main function has one infinite loop and I'd like to execute each loop of it every 100 millisecond. I know it's done by some concurrent or parallel method, but I've never done such things before and have no idea even where to start from. How would you implement such function?
Assuming your loop body takes negligible time, just use threadDelay from Control.Concurrent:
import Control.Concurrent
main = forever $ do
mainBody
threadDelay (100*1000) -- value in microseconds
Update: To account for the time of your loop body, use this:
import Data.Time.Clock
import Control.Concurrent
import Control.Monad
mainBody :: IO ()
mainBody = putStrLn "hi"
main = forever $ do
start <- getCurrentTime
mainBody
end <- getCurrentTime
let diff = diffUTCTime end start
usecs = floor (toRational diff * 1000000) :: Int
delay = 100*1000 - usecs
if delay > 0
then threadDelay delay
else return ()
Haskell's threads are light-weight, so a quick solution would be to fork on each cycle. Thus you'll end up using the main thread as a manager of worker threads, which ensures that a worker gets spawned every 100 micros.
import Control.Concurrent
main =
forever $ do
forkIO $ loopCycle
threadDelay $ 100 * 10^3
In case you care about exceptions not getting lost and getting reraised in the main thread instead, I recommend taking a look at the "slave-thread" package. Actually, I'd recommend to use that package instead of forkIO and brothers by default, but then I'm the author so I might be subjective.
Also note that the above solution might cause an accumulation of worker threads in case the loopCycle will take longer than 100 micros to execute too often. To protect against such a scenario, you can implement a strategy in the manager thread, which will ensure that the number of active workers is limited. Following is how such a strategy could be implemented:
-- From the "SafeSemaphore" package
import qualified Control.Concurrent.SSem as Sem
main =
manager 12 (100 * 10^3) $ putStrLn "Implement me!"
manager :: Int -> Int -> IO () -> IO ()
manager limit delay worker =
do
sem <- Sem.new limit
forever $ do
forkIO $ Sem.withSem sem $ worker
threadDelay delay
You could use sleep to pause the loop at the end of every iteration for 100 milliseconds. https://www.haskell.org/hoogle/?q=sleep
I am experimenting with wxHaskell. I wasn't able to run the app under ghci, so I have to use application to test it. I wanted to test the program with println debugging. However, it seems that putStrLn doesn't work in GUI:
{-# LANGUAGE Haskell2010 #-}
module Main where
import Graphics.UI.WX
drawUI dc view = do
circle dc (point 10 10) 5 [penKind := PenSolid, color := red]
putStrLn "painted"
helloGui :: IO ()
helloGui = do
f <- frame [
text := "Example",
resizeable := False,
bgcolor := white,
layout := space 400 300,
on paint := drawUI]
return ()
main :: IO ()
main = do
putStrLn "Started"
start helloGui
If I comment out start helloGui, everything is printed well. However, if I return it, nothing is printed but the window is displayed. What's wrong here?
This is probably output buffering; the output is not written until the program exits.
Either flush explicitly:
putStrLn "Started"
hFlush stdout
Or turn on line buffering:
hSetBuffering stdout LineBuffering -- or even NoBuffering
putStrLn "Started"
Can someone please point me in the right direction when it comes to changing properties of an element in Gtk2Hs.
For example, how do I change the background-color of a DrawingArea?
There are various methods for modifying a widget's style. For example to modify the background style you can use widgetModifyBg (corresponding to the C function gtk_widget_modify_bg()). In principle, if you change the style for one state (e.g. StateNormal) then you should also change it for the others.
Y would suggest you describe the styles you want in an RC file, and then load that file from your application, but it seems that functions like gtk_rc_parse() are not bound in gtk2hs.
Here's an example:
import Graphics.UI.Gtk
main = do
initGUI
window <- windowNew
window `onDestroy` mainQuit
drawingArea <- drawingAreaNew
window `containerAdd` drawingArea
widgetModifyBg drawingArea StateNormal (Color 0xffff 0 0)
widgetShowAll window
mainGUI
If you need to do custom drawing based on a widget's styles, you can do that using widgetGetState, the widgetStyle property and the styleGet* family of functions (e.g. styleGetText). Here's an example of that:
import Graphics.Rendering.Cairo
import Graphics.UI.Gtk hiding (fill)
import Graphics.UI.Gtk.Gdk.Events (Event(Expose))
expose widget rect = do
state <- widgetGetState widget
style <- widget `get` widgetStyle
(Color red green blue) <- styleGetText style state
drawWindow <- widgetGetDrawWindow widget
renderWithDrawable drawWindow $ do
moveTo 50 50
setFontSize 20
setSourceRGB (fromIntegral red / 0xffff)
(fromIntegral green / 0xffff)
(fromIntegral blue / 0xffff)
showText "O HAI"
fill
return False
main = do
initGUI
window <- windowNew
window `onDestroy` mainQuit
drawingArea <- drawingAreaNew
drawingArea `onExpose` \(Expose sent area region count) ->
expose drawingArea area
window `containerAdd` drawingArea
widgetShowAll window
mainGUI