---------------------------------------------------------
--
-- 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.
                  , 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
          -> 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 iniUsrState inputPg newUstSt debug = newIORef $ St ntbk 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 "Input" 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