--------------------------------------------------------- -- -- 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