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 Data.IORef
import Data.Lenses
import Data.Maybe
data State a = St { ntbk :: Notebook
, usrSt :: a
, bs :: [(Int,Button,ConnectId Button)]
, inputPg :: Int
-> IORef (State a)
-> IO (VBox, [WidgetsCollection])
, newUsrSt :: String
-> Int
-> a
-> a
, idFocus :: Int
, debug :: Bool
}
data WidgetsCollection = CSL (Int, ComboBox)
| CEn (Int, Entry)
| CBu (Int, Button)
| CCB (Int, CheckButton)
| Dummy
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
initState :: Notebook
-> a
-> (Int -> IORef (State a) -> IO (VBox, [WidgetsCollection]))
-> (String -> Int -> a -> a)
-> Bool
-> IO (IORef (State a))
initState ntbk iniUsrState inputPg newUstSt debug = newIORef $ St ntbk iniUsrState [] inputPg newUstSt 0 debug
logSt :: Bool -> String -> IO ()
logSt True txt = putStrLn txt
logSt _ _ = return ()
newOutputPage :: String
-> VBox
-> IORef (State a)
-> IO ()
newOutputPage txt vbox state = do
win <- scrolledWindowNew Nothing Nothing
scrolledWindowSetPolicy win PolicyNever PolicyAutomatic
scrolledWindowAddWithViewport win vbox
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))
widgetShowAll hb
notebookAppendPageMenu (ntbk st) win hb lb
widgetShowAll $ ntbk st
newOutputText :: String
-> String
-> IORef (State a)
-> IO ()
newOutputText txt content state = do
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
f <- fontDescriptionNew
fontDescriptionSetFamily f "Monospace"
widgetModifyFont info (Just f)
set info [ miscXalign := 0.01 ]
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))
widgetShowAll hb
notebookAppendPageMenu (ntbk st) win hb lb
widgetShowAll $ ntbk st
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
newSignals <- mapM (newSignal st) $ filter (\(i,_,_) -> i /= newPg) (bs st)
writeIORef state $ st { bs = newSignals}
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 (i1))
logSt (debug st) $ "newSignal " ++ show (i1)
return (i1,bt,newSignal)
| otherwise = return $ (i,bt,sg)
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
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 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
notebookInsertPage (ntbk st) vb "Input" i
notebookRemovePage (ntbk st) (i + 1)
notebookSetCurrentPage (ntbk st) i
widgetShowAll (ntbk st)
logSt (debug st) $ "reShow " ++ show nr ++ " " ++ show i
return False
showSelection
:: TableClass self =>
InputField
-> Int
-> Int
-> Int
-> self
-> IORef (State a)
-> IO ComboBox
showSelection field left up nr t state = do
cb <- comboBoxWithText (field `fetch` val_selString)
comboBoxSetActive cb (nbr $ field `fetch` val_selValue)
widgetSetSensitivity cb (field `fetch` att_editable)
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)
showNewSel self nr state = do
k <- comboBoxGetActive self
st <- readIORef state
writeIORef state $ st { usrSt = (newUsrSt st) (show k) nr (usrSt st) }
reShowPage nr state
return ()
showEntry
:: TableClass self =>
InputField
-> Int
-> Int
-> Int
-> self
-> IORef (State a)
-> 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
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
txt <- entryGetText self
writeIORef state $ st { usrSt = (newUsrSt st) txt nr $ usrSt st }
return False
showButton
:: (TableClass self, ButtonClass b) =>
InputField
-> Int
-> Int
-> Int
-> self
-> IORef (State a1)
-> b
-> (IORef (State a1) -> IO a)
-> IO b
showButton field left up nr t state bt action = do
st <- readIORef state
widgetSetSensitivity bt $ field `fetch` att_editable
let id = field `fetch` idOf
when (id /= nr) $ liftM (\ _ -> ()) $ afterFocusIn bt $ reShowPage' id state
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
showCheckBox
:: TableClass self =>
InputField
-> Int
-> Int
-> Int
-> self
-> IORef (State a)
-> 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
let id = field `fetch` idOf
when (id /= nr) $ liftM (\ _ -> ()) $ onFocusIn box $ reShowPage' id state
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
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