I would like to do something like this:
handlerOn = do
cid <- canvas `on` buttonPressEvent $ tryEvent do
signalDisconnect cid
handlerOff
putStrLn "handlerOn"
handlerOff = do
cid <- canvas `on` buttonPressEvent $ tryEvent do
signalDisconnect cid
handlerOn
putStrLn "handlerOff"
This won't work as it is, of course, because I'm trying to use cid inside a code block where cid is not assigned yet.
The idea is to register an event listener that when it receives an event, it will deregister itself and register a different event listener which will do the same, back and forth.
GHC supports recursive do.
handlerOn = do
rec cid <- canvas `on` buttonPressEvent $ tryEvent do
signalDisconnect cid
handlerOff
putStrLn "handlerOn"
You could also use Control.Monad.Fix.
handlerOff = do
mfix $ \cid -> canvas `on` buttonPressEvent $ tryEvent do
signalDisconnect cid
handlerOn
putStrLn "handlerOff"
Or manage the handler yourself.
do ...
h <- newIORef undefined
let handlerOn = do
...
writeIORef h handlerOff
handlerOff = do
...
writeIORef h handlerOn
writeIORef h handlerOn
canvas `on` buttonPressEvent $ tryEvent =<< readIORef h
Or just make everything into a single handler.
do ...
ms <- newIORef False
canvas `on` buttonPressEvent $ tryEvent do
s <- readIORef ms
if s
then ...
else ...
Related
What I'd like to do is something like this where every time one of these print actions occurs it updates the counter to ensure that the next subsequent occurrence of a print action will always have the correct order in which it occurred among any of the possible print actions that may occur across multiple threads shown by the counter. The problem in my example is that if the IORef is read at the same time between threads then two or more print actions will have the same counter value. From what I've read it seems that using the Data.Atomics.Counter library would solve this problem but i am having a really hard time understanding how to use it do so. Can anyone show me an example or try to explain it to me please?
main = do
myref <- newIORef 1 :: IO (IORef Int)
void(forkIO (forever $ do ref <- readIORef myref
print ("hi " ++ show (ref))
modifyIORef myref (+1) ))
void(forkIO (forever $ do ref <- readIORef myref
print ("hey " ++ show (ref))
modifyIORef myref (+1) ))
forever $ do ref <- readIORef myref
print ("hello " ++ show (ref))
modifyIORef myref (+1)
I would use an MVar for this.
inc mvar = forever $ do
v <- takeMVar mvar
print v
putMVar mvar (v+1)
main = do
mvar <- newMVar 1
forkIO (inc mvar)
forkIO (inc mvar)
inc mvar
It is important that the print occur between takeMVar and putMVar, while the MVar is empty; otherwise another thread may empty the MVar and execute its print.
You could use atomicModifyIORef'. It would look something like:
increment ref = forever do
val <- atomicModifyIORef' ref \old -> (old + 1, old)
print val
main = do
ref <- newIORef 0
forkIO $ increment ref
forkIO $ increment ref
increment ref
The following example requires the packages of:
- text
- string-conversions
- process
Code:
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
module Example where
import qualified Data.Text as T
import Data.Text (Text)
import Data.Monoid
import Control.Monad.Identity
import System.Process
import GHC.IO.Handle
import Debug.Trace
import Data.String.Conversions
runGhci :: Text -> IO Text
runGhci _ = do
let expr = "print \"test\""
let inputLines = (<> "\n") <$> T.lines expr :: [Text]
print inputLines
createProcess ((proc "ghci" ["-v0", "-ignore-dot-ghci"]) {std_in=CreatePipe, std_out=CreatePipe, std_err=CreatePipe}) >>= \case
(Just pin, Just pout, Just perr, ph) -> do
output <-
forM inputLines (\i -> do
let script = i <> "\n"
do
hPutStr pin $ cs $ script
hFlush pin
x <- hIsEOF pout >>= \case
True -> return ""
False -> hGetLine pout
y <- hIsEOF perr >>= \case
True -> return ""
False -> hGetLine perr
let output = cs $! x ++ y
return $ trace "OUTPUT" $ output
)
let f i o = "ghci>" <> i <> o
let final = T.concat ( zipWith f (inputLines :: [Text]) (output :: [Text]) :: [Text])
print final
terminateProcess ph
pure $ T.strip $ final
_ -> error "Invaild GHCI process"
If I attempt to run the above:
stack ghci src/Example.hs
ghci> :set -XOverloadedStrings
ghci> runGhci ""
["print \"test\"\n"]
It appears to be blocking on hIsEOF perr, according to https://stackoverflow.com/a/26510673/1663462 it sounds like I shouldn't call this function unless there is 'some output' ready to be flushed / read... However how do I handle the case where it does not have any output at that stage? I don't mind periodically 'checking' or having a timeout.
How can I prevent the above from hanging? I've tried various approaches involving hGetContents, hGetLine however they all seem to end up blocking (or closing the handle) in this situation...
I had to use additional threads, MVars, as well as timeouts:
runGhci :: Text -> IO Text
runGhci _ = do
let expr = "123 <$> 123"
let inputLines = filter (/= "") (T.lines expr)
print inputLines
createProcess ((proc "ghci" ["-v0", "-ignore-dot-ghci"]) {std_in=CreatePipe, std_out=CreatePipe, std_err=CreatePipe}) >>= \case
(Just pin, Just pout, Just perr, ph) -> do
output <- do
forM inputLines
(\i -> do
let script = "putStrLn " ++ show magic ++ "\n"
++ cs i ++ "\n"
++ "putStrLn " ++ show magic ++ "\n"
do
stdoutMVar <- newEmptyMVar
stderrMVar <- newMVar ""
hPutStr pin script
hFlush pin
tOutId <- forkIO $ extract' pout >>= putMVar stdoutMVar
tErrId <- forkIO $ do
let f' = hGetLine perr >>= (\l -> modifyMVar_ stderrMVar (return . (++ (l ++ "\n"))))
forever f'
x <- timeout (1 * (10^6)) (takeMVar stdoutMVar) >>= return . fromMaybe "***ghci timed out"
y <- timeout (1 * (10^6)) (takeMVar stderrMVar) >>= return . fromMaybe "***ghci timed out"
killThread tOutId
killThread tErrId
return $ trace "OUTPUT" $ cs $! x ++ y
)
let final = T.concat ( zipWith f (inputLines :: [Text]) (output :: [Text]) :: [Text])
print final
terminateProcess ph
pure $ T.strip $ cs $ final
_ -> error "Invaild GHCI process"
I have a little example using IORef in threepenny-gui (TPG):
testIORef :: IORef String -> Window -> UI ()
testIORef ref window = void $ do
return window # set title "Test IORef"
inCell <- UI.input
outCell <- UI.input
-- When value changes write to IORef
on UI.valueChange inCell $ \_ -> do
inValue <- get value inCell
liftIO $ writeIORef ref inValue
-- function that reads the IORef and sets the value of an element with it
let setValue oc = do
newVal <- liftIO $ readIORef ref
element oc # set value newVal
-- When enter is pressed update the value of the output
on UI.keydown inCell $ \c -> if (c==13) then setValue outCell else return outCell
getBody window #+ [ column [ grid [[string "In cell :", element inCell]
,[string "Out cell:", element outCell]
]
, string "Cells should update while typing."
]
]
I am trying to change this to use the Reactive stuff in TPG. I have got as far as making the Behaviors from the events valueChange and keyDown:
inValue <- stepper "0" $ UI.valueChange inCell
inEnter <- stepper "0" $ fmap show $ filterE (\kc-> kc==13) $ UI.keydown inCell
But I am stuck on how to use these Behaviors to save/get the value to/from the IORef. The problem is that the IORef calls will be in the UI monad, so if I use them the Behaviour will be Behavior (UI a), but then they won't work with sink. I know in this case I needn't use an IORef (eg. the currency conversion example) - but in my actual case I do.
EDIT:
I tried writing my own attribute:
valueUI :: ReadWriteAttr Element (UI String) String
so that I can set an attribute with a Behavior (UI String):
inEnter <- stepper "0" $ fmap show $ filterE (\kc-> kc==13) $ UI.keydown inCell
let getValue = fmap (const $ liftIO $ readIORef ref) inEnter
element outCell # sink valueUI getValue
The code compiles but doesn't work.
I'm starting a GUI with haskell and gtk2hs.
I've got a notebook widget and I want to switch pages with "F1, F2 ... F11" keys.
My working code is:
import Control.Monad.Trans (liftIO)
import Graphics.UI.Gtk
main = do
initGUI
builder <- builderNew
builderAddFromFile builder "M62.glade"
window <- builderGetObject builder castToWindow "window1"
notebook <- builderGetObject builder castToNotebook "notebook1"
window `on` keyPressEvent $ tryEvent $ do "F1" <- eventKeyName
liftIO $ notebookSetCurrentPage notebook 0
window `on` keyPressEvent $ tryEvent $ do "F2" <- eventKeyName
liftIO $ notebookSetCurrentPage notebook 1
window `on` keyPressEvent $ tryEvent $ do "F3" <- eventKeyName
liftIO $ notebookSetCurrentPage notebook 2
window `on` keyPressEvent $ tryEvent $ do "F4" <- eventKeyName
liftIO $ notebookSetCurrentPage notebook 3
window `on` keyPressEvent $ tryEvent $ do "F5" <- eventKeyName
liftIO $ notebookSetCurrentPage notebook 4
window `on` keyPressEvent $ tryEvent $ do "F6" <- eventKeyName
liftIO $ notebookSetCurrentPage notebook 5
window `on` keyPressEvent $ tryEvent $ do "F7" <- eventKeyName
liftIO $ notebookSetCurrentPage notebook 6
window `on` keyPressEvent $ tryEvent $ do "F8" <- eventKeyName
liftIO $ notebookSetCurrentPage notebook 7
window `on` keyPressEvent $ tryEvent $ do "F9" <- eventKeyName
liftIO $ notebookSetCurrentPage notebook 8
window `on` keyPressEvent $ tryEvent $ do "F10" <- eventKeyName
liftIO $ notebookSetCurrentPage notebook 9
window `on` keyPressEvent $ tryEvent $ do "F11" <- eventKeyName
liftIO $ notebookSetCurrentPage notebook 10
onDestroy window mainQuit
widgetShowAll window
mainGUI
Is there betters and/or concises ways to do it?
I've tried to handle it out of the 'main' but then only "F1" works.
I don't see how to manage this boilerplate.
I don't know much about gtk2hs, but using forM_ to loop over the key indices should go a long way. Also, it seems events are a MonadPlus, so pattern match failure can be favorably replaced with guard.
forM_ [0..10] $ \i -> do
let key = "F" ++ show (i + 1)
window `on` keyPressEvent $ tryEvent $ do
pressed <- eventKeyName
guard (pressed == key)
liftIO $ notebookSetCurrentPage notebook i
How about this:
window `on` keyPressEvent $ tryEvent $ do
'F':n_ <- eventKeyName
let (n, ""):_ = reads n_
liftIO . notebookSetCurrentPage notebook $ n - 1
This is hopelessly partial: there are two partial pattern matches that can throw an exception. But that's okay, because that's what tryEvent is for. At time of writing, all other answers involve registering many event handlers, whereas this one registers only one. This should have a (slight) performance advantage.
Try splitting the repeated part into a function, like this:
import Control.Monad
import Graphics.UI.Gtk
main = do
initGUI
builder <- builderNew
builderAddFromFile builder "M62.glade"
window <- builderGetObject builder castToWindow "window1"
notebook <- builderGetObject builder castToNotebook "notebook1"
-- Split the repeated code into a reusable function, like this
let registerKeyPressEvent n =
window `on` keyPressEvent $ tryEvent $ do
pressed <- eventKeyName
guard (pressed == ("F" ++ show (n + 1)))
liftIO $ notebookSetCurrentPage notebook n
-- Thanks to Tarmil for catching a bug in the code that used to be above.
-- Tarmil got it right, so I'm borrowing his/her version.
-- Then you can call it more than once
registerKeyPressEvent 0
registerKeyPressEvent 1
registerKeyPressEvent 2
registerKeyPressEvent 3
registerKeyPressEvent 4
registerKeyPressEvent 5
registerKeyPressEvent 6
registerKeyPressEvent 7
registerKeyPressEvent 8
registerKeyPressEvent 9
registerKeyPressEvent 10
-- But even that is too verbose.
-- You can shorten it even further like this:
mapM_ registerKeyPressEvent [0..10]
mapM is like map, except for monads. The type of map is:
map :: (a -> b) -> [a] -> [b]
meaning that it takes a function and applies it to every element of a list, returning the result. The type of mapM is:
mapM :: Monad m => (a -> m b) -> [a] -> m [b]
meaning that it takes a monadic function (such as registerKeyPressEvent, function in the IO monad that creates the side effect of registering a key press event). mapM then executes this function once for every element in the list, and not only collects the results into a list, but collects the monadic actions into the resulting monad, meaning that the side effects from running registerKeyPressEvent 11 times are performed in order.
The final piece of the puzzle is that you might get a type error if you use mapM, because it assumes you care about the resulting list, and therefore returns m [b]. However, in this case, the type of main is IO (), and () is not going to match up to [b]. You therefore want a slight variation on mapM that throws away the resulting list, only collecting the monadic actions:
mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
This has the return type you're looking for.
I have written a small application which tracks my progress in TV Series. The application is written in Haskell with functional reactive programming (FRP) with reactive banana.
The application can:
add/remove new TV Series to the table
change the season and episode of an series
I have problems writing the code that adds a new TV series to the table and wires the new events. The CRUD example from here didn't quite help me because I have more requirements then just selecting an element from the list.
How do I write a reactiveTable function like the reactiveListDisplay function from the CRUD Example in a FRP way? How can events be added for the remove button and the season and episode spin buttons after the network has been compiled?
data Series = Series { name :: String
, season :: Int
, episode :: Int
}
insertIntoTable :: TableClass t => t -> SeriesChangeHandler -> SeriesRemoveHandler -> Series -> IO ()
insertIntoTable table changeHandler removeHandler (Series name s e) = do
(rows, cols) <- tableGetSize table
tableResize table (rows+1) cols
nameLabel <- labelNew $ Just name
adjustmentS <- adjustmentNew (fromIntegral s) 1 1000 1 0 0
adjustmentE <- adjustmentNew (fromIntegral e) 1 1000 1 0 0
seasonButton <- spinButtonNew adjustmentS 1.0 0
episodeButton <- spinButtonNew adjustmentE 1.0 0
removeButton <- buttonNewWithLabel "remove"
let getSeries = do
s <- spinButtonGetValue seasonButton
e <- spinButtonGetValue episodeButton
return $ Series name (round s) (round e)
handleSeries onEvent widget handler = do
onEvent widget $ do
series <- getSeries
handler series
handleSeries onValueSpinned seasonButton changeHandler
handleSeries onValueSpinned episodeButton changeHandler
onPressed removeButton $ do
series <- getSeries
containerRemove table nameLabel
containerRemove table seasonButton
containerRemove table episodeButton
containerRemove table removeButton
removeHandler series
let tadd widget x = tableAdd table widget x (rows - 1)
tadd nameLabel 0
tadd seasonButton 1
tadd episodeButton 2
tadd removeButton 3
widgetShowAll table
main :: IO ()
main = do
initGUI
window <- windowNew
scroll <- scrolledWindowNew Nothing Nothing
table <- tableNew 1 5 True
addButton <- buttonNewWithLabel "add series"
vbox <- vBoxNew False 10
containerAdd window vbox
boxPackStart vbox addButton PackNatural 0
let networkDescription :: forall t. Frameworks t => Moment t ()
networkDescription = do
addEvent <- eventButton addButton
(changeHandler,fireChange) <- liftIO $ newAddHandler
changeEvent <- fromAddHandler changeHandler
(removeHandler,fireRemove) <- liftIO $ newAddHandler
removeEvent <- fromAddHandler removeHandler
let insertIntoTable' = insertIntoTable table fireChange fireRemove
addSeries e = do
s <- addSeriesDialog
liftIO $ insertIntoTable' s
liftIO $ mapM_ insertIntoTable' initSeries
reactimate $ addSeries <$> addEvent
reactimate $ updateSeries conn <$> changeEvent
reactimate $ removeSeries conn <$> removeEvent
network <- compile networkDescription
actuate network
onDestroy window $ do
D.disconnect conn
mainQuit
widgetShowAll window
mainGUI
I want to refactor the insertIntoTable method to use events and behaviors rather than using simple callbacks.
EDIT:
I have tried the gtk TreeView with a ListStore backend. In this scenario you don't need dynamic event switching. I have written the reactiveList function below to get a list behavior out of insert, change and remove events. It works ^^
reactiveList :: (Frameworks t)
=> ListStore a
-> Event t (Int,a) -- insert event
-> Event t (Int,a) -- change event
-> Event t (Int,a) -- remove event
-> Moment t (Behavior t [a])
reactiveList store insertE changeE removeE = do
(listHandler,fireList) <- liftIO $ newAddHandler
let onChange f (i,a) = do
f i a
list <- listStoreToList store
fireList list
reactimate $ onChange (listStoreInsert store) <$> insertE
reactimate $ onChange (listStoreSetValue store) <$> changeE
reactimate $ onChange (const . listStoreRemove store) <$> removeE
initList <- liftIO $ listStoreToList store
fromChanges initList listHandler
main :: IO ()
main = do
initGUI
window <- windowNew
addButton <- buttonNewWithLabel "add series"
vbox <- vBoxNew False 10
seriesList <- listStoreNew (initSeries :: [Series])
listView <- treeViewNewWithModel seriesList
treeViewSetHeadersVisible listView True
let newCol title newRenderer f = do
col <- treeViewColumnNew
treeViewColumnSetTitle col title
renderer <- newRenderer
cellLayoutPackStart col renderer False
cellLayoutSetAttributes col renderer seriesList f
treeViewAppendColumn listView col
return renderer
newCol "Image" cellRendererPixbufNew $ \s -> [cellPixbuf :=> newPixbuf s]
newCol "Name" cellRendererTextNew $ \s -> [cellText := name s]
seasonSpin <- newCol "Season" cellRendererSpinNew $ \s ->
[ cellRendererSpinAdjustment :=> adjustmentNew (fromIntegral (season s)) 1 1000 1 0 0
, cellText := (show $ season s)
, cellTextEditable := True
]
episodeSpin <- newCol "Episode" cellRendererSpinNew $ \s ->
[ cellRendererSpinAdjustment :=> adjustmentNew (fromIntegral (episode s)) 1 1000 1 0 0
, cellText := (show $ episode s)
, cellTextEditable := True
]
containerAdd window vbox
boxPackStart vbox listView PackGrow 0
boxPackStart vbox addButton PackNatural 0
let networkDescription :: forall t. Frameworks t => Moment t ()
networkDescription = do
(addHandler,fireAdd) <- liftIO $ newAddHandler
maybeSeriesE <- fromAddHandler addHandler
(removeHandler,fireRemove) <- liftIO $ newAddHandler
removeE <- fromAddHandler removeHandler
-- when the add button was pressed,
-- open a dialog and return maybe a new series
askSeriesE <- eventButton addButton
reactimate $ (const $ fireAdd =<< askSeries) <$> askSeriesE
-- ommit all nothing series
let insertE = filterJust maybeSeriesE
insert0E = ((,) 0) <$> insertE
seasonSpinE <- eventSpin seasonSpin seriesList
episodeSpinE <- eventSpin episodeSpin seriesList
let changeSeason (i,d,s) = (i,s {season = round d})
changeEpisode (i,d,s) = (i,s {episode = round d})
let changeE = (changeSeason <$> seasonSpinE) `union` (changeEpisode <$> episodeSpinE)
listB <- reactiveList seriesList insert0E changeE removeE
listE <- (changes listB)
reactimate $ (putStrLn . unlines . map show) <$> listE
reactimate $ insertSeries conn <$> insertE
reactimate $ updateSeries conn . snd <$> changeE
reactimate $ removeSeries conn . snd <$> removeE
return ()
network <- compile networkDescription
actuate network
onDestroy window $ do
D.disconnect conn
mainQuit
widgetShowAll window
mainGUI
I'm open for comments and suggestions.
It sounds like your problem is much closer to the Bar Tab example than the CRUD one.
The basic idea for adding new widgets--along with new behaviors and events--is to use so-called "dynamic event switching". Essentially, this is a way to put newly created events and behaviors back into your network.
The action to create a new widget has two parts. The first part is to just create the widget, using liftIO. The second is to get its inputs and use trimE or trimB as appropriate. Leaving out most of the GTk-specific details (I don't know how to use GTk :P), it'll look something like this:
let newSeries name = do
label <- liftIO . labelNew $ Just name
liftIO $ tadd labelNew 0
{- ... the rest of your controls here ... -}
seasonNumber <- trimB $ getSpinButtonBehavior seasonButton
{- ... wrap the rest of the inputs using trimB and trimE ... -}
return (label, seasonNumber, ...)
So this function creates a new widget, "trims" its inputs and returns the values to you. Now you have to actually use these values:
newSeasons <- execute (FrameworkMoment newSeries <$> nameEvents)
here nameEvents should be an Event String containing an event with the name of the new series each time you want to add it.
Now that you have a stream of all of the new seasons, you can combine it all into a single behavior of a list of entries using something like stepper.
For more details--including things like getting the aggregate information out of all of your widgets--look at the actual example code.