wtk-gtk-0.2: Graphics/UI/Gtk/WtkGtk.hs
---------------------------------------------------------
--
-- Module : GUI.WtkGtk
-- Copyright : Bartosz Wójcik (2010)
-- License : BSD3
--
-- Maintainer : bartek@sudety.it
-- Stability : Unstable
-- Portability : portable
--
-- | Gtk instantiation of interface between application and GUI.
---------------------------------------------------------
module Graphics.UI.Gtk.WtkGtk
(module Graphics.UI.Gtk.WtkGtkBp
,State (..)
,WidgetsCollection (..)
,initState
,logSt
,newTable
,newOutputPage
,newOutputText
,showSelection
,showEntry
,showButton
,showCheckBox
,reShowPage
)
where
import Graphics.UI.Gtk.WtkGui
import Graphics.UI.Gtk.WtkGtkBp
import Graphics.UI.Gtk
import Control.Monad
--import Control.Monad.Error
import Data.IORef
import Data.Lenses
import Data.Maybe
-- | The State.
-- It contains all details that have to passed around to manage properly
-- Gtk UI and of course users state.
data State a = St { ntbk :: Notebook -- ^ Notebook. All the GUI is embeded in a notebook.
, titleN :: String -- ^ Notebook's title
, usrSt :: a -- ^ User's state
, bs :: [(Int,Button,ConnectId Button)] -- ^ Page number and its closing button and closing signal
, inputPg :: Int -- id of widget with focus
-> IORef (State a) -- state living in IO
-> IO (VBox, [WidgetsCollection]) -- ^ Function showing input page. Id of widget with focus,
-- state are input. vbox to be shown and
-- list of widgets to set focus are output.
, newUsrSt :: String -- Raw entry from widget
-> Int -- Id of widget
-> a -- Previous state
-> a -- ^ Gives new, user defined state, having new entry of a widget.
, idFocus :: Int -- ^ id of widget with focus
, debug :: Bool -- ^ set, displays lots of debug info
}
-- | Serialization of inputable widgets for focus purposes. To be used in the function showing input page for
-- producing proper output.
data WidgetsCollection = CSL (Int, ComboBox)
| CEn (Int, Entry)
| CBu (Int, Button)
| CCB (Int, CheckButton)
| Dummy
-- | Finds requested widget in the collection.
findI :: Int -> [WidgetsCollection] -> WidgetsCollection
findI _ [] = Dummy
findI i (x:xs) = case x of
CSL (n,_) -> if n == i then x else findI i xs
CEn (n,_) -> if n == i then x else findI i xs
CBu (n,_) -> if n == i then x else findI i xs
CCB (n,_) -> if n == i then x else findI i xs
_ -> findI i xs
-- | State initializaion
initState :: Notebook -- ^ Gtk's 'Notebook
-> String -- ^ Notebook's title
-> a -- ^ Initialized user's state
-> (Int -> IORef (State a) -> IO (VBox, [WidgetsCollection])) -- ^ Input page creation
-> (String -> Int -> a -> a) -- ^ User state change
-> Bool -- ^ Debug on/off
-> IO (IORef (State a))
initState ntbk title iniUsrState inputPg newUstSt debug =
newIORef $ St ntbk title iniUsrState [] inputPg newUstSt 0 debug
-- | Displays debuging detail if switched on
logSt :: Bool -> String -> IO ()
logSt True txt = putStrLn txt
logSt _ _ = return ()
-- | Renders text output page on the notebook with closing button on the tab.
newOutputPage :: String -- ^ Title of page
-> VBox -- ^ Content
-> IORef (State a) -- ^ State
-> IO ()
newOutputPage txt vbox state = do
-- adds new page to the notebook and displays it
win <- scrolledWindowNew Nothing Nothing
scrolledWindowSetPolicy win PolicyNever PolicyAutomatic
scrolledWindowAddWithViewport win vbox
-- Page label consists of text label and close button
img <- imageNewFromStock stockClose (IconSizeUser 1)
button <- buttonNew
containerAdd button img
st <- readIORef state
newPg <- notebookGetNPages $ ntbk st
clSig <- onClicked button $ myNotebookRemovePage state newPg
lb <- labelNew $ Just $ show newPg ++ ". " ++ txt
hb <- hBoxNew False 0
boxPackStart hb lb PackNatural 0
boxPackStart hb button PackNatural 0
logSt (debug st) $ "New page " ++ show newPg
writeIORef state (st { bs = ((newPg, button, clSig) : bs st)})
logSt (debug st) $ "pages " ++ show ( map (\(i,_,_) -> i) (bs st))
-- Widget has to be shown before put to notebook's page
-- otherwise its content won't be rendered properly.
widgetShowAll hb
notebookAppendPageMenu (ntbk st) win hb lb
widgetShowAll $ ntbk st
-- | Renders text output page on the notebook with closing button on the tab.
newOutputText :: String -- ^ Title of page
-> String -- ^ Content
-> IORef (State a) -- ^ State
-> IO ()
newOutputText txt content state = do
-- adds new page to the notebook and displays it
win <- scrolledWindowNew Nothing Nothing
scrolledWindowSetPolicy win PolicyNever PolicyAutomatic
mb <- vBoxNew False 0
scrolledWindowAddWithViewport win mb
info <- labelNew (Just content)
labelSetSelectable info True
boxPackStart mb info PackNatural 7
-- Monospace font for the window
f <- fontDescriptionNew
fontDescriptionSetFamily f "Monospace"
widgetModifyFont info (Just f)
set info [ miscXalign := 0.01 ] -- so the text is left-justified.
-- Page label consists of text label and close button
img <- imageNewFromStock stockClose (IconSizeUser 1)
button <- buttonNew
containerAdd button img
lb <- labelNew $ Just txt
hb <- hBoxNew False 0
boxPackStart hb lb PackNatural 0
boxPackStart hb button PackNatural 0
st <- readIORef state
newPg <- notebookGetNPages $ ntbk st
clSig <- onClicked button $ myNotebookRemovePage state newPg
logSt (debug st) $ "New page " ++ show newPg
writeIORef state (st { bs = ((newPg, button, clSig) : bs st)})
logSt (debug st) $ "pages " ++ show ( map (\(i,_,_) -> i) (bs st))
-- Widget has to be shown before put to notebook's page
-- otherwise its content won't be rendered properly.
widgetShowAll hb
notebookAppendPageMenu (ntbk st) win hb lb
widgetShowAll $ ntbk st
-- Removes page and redefined closing signals of other output pages.
myNotebookRemovePage :: IORef (State a) -> Int -> IO ()
myNotebookRemovePage state newPg = do
st <- readIORef state
k <- notebookGetCurrentPage $ ntbk st
logSt (debug st) $ "removedPage " ++ show newPg ++ " " ++ show ( map (\(i,_,_) -> i) (bs st) )
notebookRemovePage (ntbk st) newPg
-- New signals attached to the closing buttons.
newSignals <- mapM (newSignal st) $ filter (\(i,_,_) -> i /= newPg) (bs st)
writeIORef state $ st { bs = newSignals}
-- Input page has to be re-rendered in order to get new state
-- on the action widget. Otherwise next same action won't have
-- new signals attached to buttons.
-- It is re-rendered only if either
-- - it is current page
-- - it becomes current page, beacuse the last other page has been removed
when (k == 0 || null newSignals) $ reShowPageVoid (idFocus st) state
where newSignal st (i,bt,sg) | i > newPg = do
signalDisconnect sg
newSignal <- onClicked bt (myNotebookRemovePage state (i-1))
logSt (debug st) $ "newSignal " ++ show (i-1)
return (i-1,bt,newSignal)
| otherwise = return $ (i,bt,sg)
-- ============ Re-showing input page ================
reShowPageVoid nr state = reShowPage nr state >> return ()
reShowPageVoid' nr state _ = reShowPage nr state >> return ()
reShowPage'' nr state _ = reShowPage nr state
reShowPage' nr state _ = reShowPage nr state
-- | Re-shows the page.
reShowPage :: Int -> IORef (State a) -> IO Bool
reShowPage nr state = do
st <- readIORef state
i <- notebookGetCurrentPage $ ntbk st
(vb,collection) <- (inputPg st) nr state
--case head $ drop nr collection of
case findI nr collection of
CSL (_,cb) -> widgetGrabFocus cb >> logSt (debug st) ("focus " ++ show nr)
CEn (_,en) -> widgetGrabFocus en >> logSt (debug st) ("focus " ++ show nr)
CBu (_,bt) -> widgetGrabFocus bt >> logSt (debug st) ("focus " ++ show nr)
CCB (_,cb) -> widgetGrabFocus cb >> logSt (debug st) ("focus " ++ show nr)
_ -> logSt (debug st) $ "reShowPage Dummy with focus: " ++ show nr
widgetShowAll vb
-- Old page is removed after the new one is shown. New one is inserted under
-- the number of the old one, therefore the old one is moved to next number.
-- This works according to experience and is not confirmed by any API docu.
notebookInsertPage (ntbk st) vb (titleN st) i
notebookRemovePage (ntbk st) (i + 1)
notebookSetCurrentPage (ntbk st) i
widgetShowAll (ntbk st)
logSt (debug st) $ "reShow " ++ show nr ++ " " ++ show i
return False
-- ================= Combo Box ====================
-- | Shows combo box and sets its attributes according to input.
-- Attaches new selection list to the given table.
showSelection
:: TableClass self =>
InputField -- ^ @Selection@ constructor
-> Int -- ^ left coordinate
-> Int -- ^ up coordinate
-> Int -- ^ id of active widget
-> self -- ^ table to attach
-> IORef (State a) -- ^ user state
-> IO ComboBox
showSelection field left up nr t state = do
cb <- comboBoxWithText (field `fetch` val_selString)
-- Set active entry to one from state
comboBoxSetActive cb (nbr $ field `fetch` val_selValue)
-- Set sensitivity depending on editability
widgetSetSensitivity cb (field `fetch` att_editable)
-- On changed entry signal render new UI
on cb changed $ showNewSel cb (field `fetch` idOf) state
st <- readIORef state
when (field `fetch` idOf /= nr) $ widgetSetCanFocus cb True >>
(afterGrabFocus cb $ reShowPageVoid (field `fetch` idOf) state) >>
logSt (debug st) ("comboBoxWithInputField " ++
show nr)
widgetGetCanFocus cb >>= logSt (debug st) . show
tableAttach t cb left (left+1) up (up+1) [Fill] [Shrink] 0 5
return cb
where nbr (Just x) = x
nbr Nothing = (-1)
-- | Renders new UI after user action
showNewSel self nr state = do
-- currently active item of the list
k <- comboBoxGetActive self
-- new state of whole UI
st <- readIORef state
writeIORef state $ st { usrSt = (newUsrSt st) (show k) nr (usrSt st) }
reShowPage nr state
return ()
-- ================= Entry ====================
-- | Entry field is rendered and attached to the given table.
showEntry
:: TableClass self =>
InputField -- ^ Data and attributes
-> Int -- ^ Left coordinate
-> Int -- ^ Top coordinate
-> Int -- ^ Id of active widget
-> self -- ^ Table to attach to
-> IORef (State a) -- ^ The state
-> IO Entry
showEntry field left up nr t state = do
st <- readIORef state
en <- entryNew
widgetSetSensitivity en (field `fetch` att_editable)
afterFocusOut en (outEntry en (field `fetch` idOf) state)
when (field `fetch` idOf /= nr) $ liftM (\ _ -> ()) $
afterFocusIn en $
reShowPage' (field `fetch` idOf) state
-- Text is the invalid value in case of error flag raised
-- or the value otherwise.
entrySetText en $ field `fetch` att_rawValue
tableAttach t en left (left+1) up (up+1) [Fill] [Shrink] 0 5
return en
where outEntry self nr state _ = do
st <- readIORef state
-- Retrieve text from the entry field.
txt <- entryGetText self
writeIORef state $ st { usrSt = (newUsrSt st) txt nr $ usrSt st }
return False
-- ================= Button ====================
-- | Attaches given buttun to the given table with action and attributes.
showButton
:: (TableClass self, ButtonClass b) =>
InputField -- ^ Attributes
-> Int -- ^ Left coordinate
-> Int -- ^ Top coordinate
-> Int -- ^ Id of active widget
-> self -- ^ Table to attach to
-> IORef (State a1) -- ^ The state
-> b -- ^ Button to attach
-> (IORef (State a1) -> IO a) -- ^ Action attached to the button
-> IO b
showButton field left up nr t state bt action = do
st <- readIORef state
widgetSetSensitivity bt $ field `fetch` att_editable --editable att
let id = field `fetch` idOf
when (id /= nr) $ liftM (\ _ -> ()) $ afterFocusIn bt $ reShowPage' id state
-- On button click there are 3 actions in sequence: new state stored, the @action@ and page refresh.
onClicked bt $ writeIORef state (st { usrSt = (newUsrSt st) "" nr $ usrSt st
, idFocus = id }) >>
action state >>
reShowPageVoid id state
tableAttach t bt left (left+1) up (up+1) [Fill] [Shrink] 0 5
return bt
-- ================= Check Box ====================
-- | Renders and attaches new check button to the given table.
showCheckBox
:: TableClass self =>
InputField -- ^ @CheckBox@ constructor
-> Int -- ^ Left coordinate
-> Int -- ^ top coordinate
-> Int -- ^ id of active widget
-> self -- ^ table to attach to
-> IORef (State a) -- ^ The state
-> IO CheckButton
showCheckBox field left up nr t state = do
box <- checkButtonNew
toggleButtonSetActive box $ field `fetch` val_cbValue --api
onToggled box (aferCheckBox field nr state)
st <- readIORef state
widgetSetSensitivity box $ field `fetch` att_editable --att
-- On focus in (only if grabbed from another widget) redraw page of notebook
let id = field `fetch` idOf
when (id /= nr) $ liftM (\ _ -> ()) $ onFocusIn box $ reShowPage' id state
-- Use (aferCheckBox' state b widget) for single click needed to change the value
-- Use (reShowPage state i) for double click needed to change the value
tableAttach t box left (left+1) up (up+1) [Fill] [Shrink] 0 5
return box
where aferCheckBox field nr state = do
st <- readIORef state
writeIORef state $ st { usrSt = (newUsrSt st) "" nr $ usrSt st }
reShowPageVoid (field `fetch` idOf) state
-- ====================== New Table ==========================
-- | Packs a new table into a new frame, the frame into given box and returns table.
-- Gets label for the frame, box and size of the new table.
newTable :: BoxClass self => String -> self -> Int -> Int -> IO Table
newTable label box x y = frameNew >>= \fr ->
frameSetLabel fr label >>
boxPackStart box fr PackNatural 5 >>
tableNew x y False >>= \tb ->
containerAdd fr tb >>
return tb