I am trying to make a counter widget in Reflex with the following qualities:
It has a minimum value of 0 -- and hitting "decrement" while at 0 results in nothing happening.
(solved) The increment button is to the right of the decrement button.
It has Bulma CSS styles applied.
This is the code I currently have:
bodyElementIncrRounds :: ObeliskWidget js t route m => m ()
bodyElementIncrRounds = do
-- el "h2" $ text "Using foldDyn with function application"
evIncr <- button "Increment"
evDecr <- button "Decrement"
-- evReset <- button "Reset"
dynNum <- foldDyn ($) (0 :: Int) $ leftmost [(+ 1) <$ evIncr, (+ (-1)) <$ evDecr]
el "h3" $ display dynNum
return ()
This is what the result is:
When I try to swap the buttons by flipping these to values: (+ 1) <$ evIncr, (+ (-1)) <$ evDecr, it has no effect at all on the location of the buttons. (I.e. increment remains on the left.)
When I try to apply Bulma code like this:
bodyElementIncrRounds :: ObeliskWidget js t route m => m ()
bodyElementIncrRounds = do
-- el "h2" $ text "Using foldDyn with function application"
evIncr <- elAttr "button" ("class" =: "button") $ button "Increment"
evDecr <- button "Decrement"
-- evReset <- button "Reset"
dynNum <- foldDyn ($) (0 :: Int) $ leftmost [(+ 1) <$ evIncr, (+ (-1)) <$ evDecr]
el "h3" $ display dynNum
return ()
It duplicates the button for some reason and also places the existing (ugly) button inside of the Bulma widget (edit: the duplication problem has been solved, but not the "button inside the button" problem):
Related
I have this sample code where I have a ListBox containing ListBoxRows, which in turn contain a Label. When I click on the ListBox, I get a ListBoxRow. So far so good. The problems start when I want to interact with the ListBoxRows children.
I have used this function to get the Label, which is the child of the ListBoxRow.
https://hackage.haskell.org/package/gi-gtk-3.0.18/docs/GI-Gtk-Objects-Container.html#g:13
However, the returned type is Widget. How do I convert the type of the object? Function widgetGetName tells me it is a label, but the Haskell Type system insists it is a Widget, so I can not use label specific functions.
working code
_ <- onListBoxRowSelected listbox2 (\(Just r) -> do
cc <- containerGetChildren r
mlabel <- castTo Label (head cc)
case mlabel of
Nothing -> putStrLn "Not a label!"
Just label -> (labelGetText label) >>= putStrLn . unpack)
Thanks to Dan
Try this:
cc <- containerGetChildren r
mlabel <- castTo Label (head cc)
case mlabel of
Nothing -> putStrLn “Not a label!”
Just label -> labelGetText label >>= putStrLn
I have this piece of code and it works perfectly fine. It toggles some styles on the text input field depending on the field value.
numberInput :: (MonadWidget t m) => m (Dynamic t (Maybe Double))
numberInput = divClass "form-group" $ do
let errorState = "style" =: "border-color: red"
validState = "style" =: "border-color: green"
rec n <- textInput $ def & textInputConfig_inputType .~ "number"
& textInputConfig_initialValue .~ "0"
& textInputConfig_attributes .~ attrs
let result = fmap (readMay . unpack) $ _textInput_value n
attrs = fmap (maybe errorState (const validState)) result
return result
I ran into some problems making the parent element dynamic. I'd like to toggle the styles on the parent element of text input. I'd like to write something like but failed!
numberInput :: (MonadWidget t m) => m (Dynamic t (Maybe Double))
numberInput = do
rec
dynAttrs <- -- reference to textInput
elDynAttr "div" dynAttrs $ do
n <- textInput $ def & textInputConfig_inputType .~ "number"
& textInputConfig_initialValue .~ "0"
...
Thanks for helping out!
Here is a little program where the attributes (align right or left) of the parent element depend on the state of a child element:
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
import Reflex.Dom
import qualified Data.Text as T
import Safe
main :: IO ()
main = mainWidget bodyElement
bodyElement :: MonadWidget t m => m ()
bodyElement = el "div" $ do
el "h2" $ text "Dynamic parent element"
numberInput
return ()
numberInput :: (MonadWidget t m) => m (Dynamic t (Maybe Double))
numberInput = do
rec
let errorState = ("align" :: T.Text) =: "right"
validState = "align" =: "left"
let result = fmap (readMay . T.unpack) $ _textInput_value n
attrs = fmap (maybe errorState (const validState)) result
n <- elDynAttr "div" attrs $ do
n1 <- textInput $ def & textInputConfig_inputType .~ "number"
& textInputConfig_initialValue .~ "0"
text "Some additional control"
return n1
return result
As user user2407038 mentions, we have to return the numeric text element from an inner scope to the outer scope. Then we can use recursive do to access the element we define later in the program.
As soon as you type a letter into the numeric field, it will jump to the right.
Duplicating this from github as per #HeinrichApfelmus's suggestion:
This may be just a usage error on my part, but I am noticing a strange phenomenon when trying to set up conditional visibility/layout for dynamically created UI elements (in WX of course). As somewhat of a toy-example, I tried to create a widget that created StaticText elements on the fly and allowed the user to "browse" through these elements through '<' '>' buttons.
The problem I am noting is that all labels are invisible until a new one is created, at which point the current widget in focus becomes visible. Whether this is a bug or just a paradigm I am misusing, or a subtlety with reactive frameworks, I am unsure as to how to resolve this. Here is the code I have at this point, which exhibits the problem:
{-# LANGUAGE RecursiveDo #-}
module Test.Adder where
import Reactive.Banana
import Reactive.Banana.WX
import Graphics.UI.WX.Attributes
import Graphics.UI.WX hiding (Event, newEvent, empty, Identity)
import Graphics.UI.WXCore hiding (Event, Timer, empty, Identity, newEvent)
import Graphics.UI.WXCore.Frame
-- | Combine Unit-Events
anyEvent :: [Event ()] -> Event ()
anyEvent = foldl1 (unionWith (\_ _ -> ()))
-- | Unsugared if-then-else function
if_ :: Bool -> a -> a -> a
if_ True x _ = x
if_ False _ y = y
-- | Apply a function to the value at an index, or return a default value
-- if the index is out of range
(!?) :: (a -> b) -> b -> Int -> ([a] -> b)
(f!? ~y) n xs
| n < 0 = y
| otherwise = case drop n xs of
x:_ -> f x
[] -> y
main :: IO ()
main = start test
create :: Window w -> Int -> Behavior Int -> Event Int -> Event () -> MomentIO (StaticText ())
create t i bi ei eRef = do
let tx = replicate i '\t' ++ show i
x <- liftIO $ staticText t [ text := tx ]
let beq = (==i) <$> bi
let eMe = filterE (==i) ei
sink x [ visible :== beq ]
reactimate (refresh x <$ anyEvent [ eRef, () <$ eMe ])
return x
test :: IO ()
test = do
f <- frame [text := "Test"]
add <- button f [ text := "+" ]
prv <- button f [ text := "<" ]
cur <- staticText f []
nxt <- button f [ text := ">" ]
tab <- panel f [ clientSize := sz 200 300 ]
deb <- staticText f []
ref <- button f [ text := "refresh" ]
let networkDescription :: MomentIO ()
networkDescription = mdo
eAdd <- event0 add command
eRef <- event0 ref command
let bNotFirst = (>0) <$> bCur
bNotLast = (<) <$> bCur <*> bNext
sink prv [ enabled :== bNotFirst ]
sink cur [ text :== show <$> bCur ]
sink nxt [ enabled :== bNotLast ]
ePrev <- event0 prv command
eNext <- event0 nxt command
let eDelta :: Enum n => Event (n -> n)
eDelta = unions [ pred <$ whenE bNotFirst ePrev
, succ <$ whenE bNotLast eNext ]
eChange = flip ($) <$> bCur <#> eDelta
bCur <- stepper 0 $ eChange
(eIndex, bCount) <- mapAccum 0 ((\x -> (x, succ x)) <$ eAdd)
let bView = (\n i -> if_ (n==0) (0) i) <$> bCount <*> bCur
bNext = pred <$> bCount
eCreate = (\n -> create tab n bView eChange $ anyEvent [eRef,eAdd]) <$> eIndex
reCreate <- execute eCreate
bItemer <- accumB id $ flip (.) . (:) <$> reCreate
let bItems = ($[]) <$> bItemer
bThis = (widget!?(nullLayouts!!0)) <$> bCur <*> bItems
sink tab [ layout :== bThis ]
liftIO $ set f [ layout := column 5 [ margin 10 $ row 5 [ widget add
, widget prv
, widget cur
, widget nxt
, widget ref
]
, fill $ widget tab
]
]
network <- compile networkDescription
actuate network
>
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 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.