tabloid-0.45: MultiWidgetContainerController.hs

{-# LANGUAGE ExistentialQuantification #-}

module MultiWidgetContainerController
    (
     new
    , main
    , view
    , Controller
    ) where

import Graphics.UI.Gtk
import qualified MultiWidgetContainerView as View
import qualified DataProcController as DP
import Component
import WindowedApp
import Control.Applicative
import qualified Data.Map as M

type Controller = Ref C

view = View.mainWidget . gui

new :: IO Controller
new = do
  v@(View.V _ _ _ ab) <- View.new 
  this <- newRef (C v M.empty M.empty)
  onClicked ab (addComponent this) 
  return this

removeComponent :: String -> C -> C
removeComponent name state = 
  state { components = (M.delete name (components state)) }
  
addComponent :: Controller -> IO ()
addComponent this = this .<< 
    \(C g cs env) -> do
      name <- entryGetText (View.nameE g)
      putStrLn $ "add comp " ++ name
      dpc <- DP.new (this .>> getEnv)
      (dpc .> DP.view) >>= View.add g name
      let cs' =  M.insert name dpc cs
      dpc .< DP.onUpdate (Just (\ls -> this .<< dpcUpdated name ls))
      return (C g cs' env)

-- internal 

getEnv :: C -> IO DP.Env
getEnv = return . contents 

dpcUpdated :: String -> [[String]] -> C -> IO C
dpcUpdated name content state = do  
  putStrLn $ "new content from " ++ name
  return (state {contents = M.insert name content (contents state)})

data C = C 
    { gui :: View.ViewState
    , components :: M.Map String DP.Controller
    , contents :: DP.Env
    }

main = windowedApp "tabloid" $ do
    	 clut <- new
         mw <- View.mainWidget <$>  (clut .> gui)         
         return mw