WxM.hs

{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving, RankNTypes #-}

module Graphics.UI.AF.WxForm.WxM
    ( io, Widget(..), toWidget, Parent(Parent)
    , WxAct
    , startI
    , getParentI
    --
    , WxM, runWxM, wxActToListenerM, liftWxActToListenerM
    , getFrame, getPanel, withPanel
    , liftIO, liftIO'
    , withMaxDepth, getMaxDepth, goDeeper
    , extractGui, comIOAddGui, getPostponedIO, postponeAction', getClose, getCloseWindow
    , WxMGUI(..)
    )

where

import qualified Graphics.UI.AF.General.AutoForm as AF

import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.Fix
import Control.Monad.Trans(MonadIO, liftIO)

import qualified Graphics.UI.WX      as Wx
import qualified Graphics.UI.WXCore  as Wx

import Graphics.UI.AF.WxForm.ComIO
import Graphics.UI.AF.WxForm.GUI

data Widget = forall w. Widget (Wx.Window w)

toWidget :: forall w. Wx.Window w
         -> Widget
toWidget w = Widget w

data Parent = forall w. Parent (Wx.Window w)

instance AF.SimpleDialog WxM where
    infoDialog title msg  = standardDialog' (\w -> Wx.infoDialog w title msg)
    errorDialog title msg = standardDialog' (\w -> Wx.errorDialog w title msg)

standardDialog' :: (forall w. Wx.Window w -> IO a) -> WxM a
standardDialog' dialog =
    do Parent parent <- getFrame
       x <- liftIO $ dialog parent
       return x

instance AF.SimpleDialog WxAct where
    infoDialog title msg  = standardDialog'' (\w -> Wx.infoDialog w title msg)
    errorDialog title msg = standardDialog'' (\w -> Wx.errorDialog w title msg)

standardDialog'' :: (forall w. Wx.Window w -> IO a) -> WxAct a
standardDialog'' dialog =
    do (Parent parent) <- getParentI
       x <- liftIO $ dialog parent
       return x

-- (Parent, closeWindow)
newtype WxAct a = WxAct { wxAct' :: ReaderT (Parent, IO()) ListenerM a }
    deriving ( Monad, MonadIO, MonadListener, Observable (ComIO b)
             , Observable OnChangeVars
             )

liftWxActToListenerM :: ((forall b. WxAct b -> ListenerM b) -> IO a) -> WxM a
liftWxActToListenerM f =
    do p        <- getFrame
       close    <- getClose
       let local' act = runReaderT (wxAct' act) (p, close)
       liftIO $ f local'


getParentI :: WxAct Parent
getParentI = WxAct $ asks fst

getCloseWindow :: WxAct (IO ())
getCloseWindow = WxAct $ liftM snd ask

wxActToListenerM :: WxAct a -> WxM (ListenerM a)
wxActToListenerM act = 
    do p      <- getFrame
       close  <- getClose
       return (runReaderT (wxAct' act) (p, close))

---------------------------- WxM ----------------------------------
newtype WxM a = WxM { wxm' :: StateT WxMState (ReaderT WxMReader IO) a }
    deriving (Monad, MonadIO, MonadFix)

data WxMReader = WxMReader { frame'    :: Parent     -- ^The parent frame or dialog.
                           , close'    :: IO ()      -- ^Closing the parent frame or dialog.
                           , panel'    :: Parent     -- ^The panel or frame the widgets should
                                                     -- be attached to, like `textCtrl panel []`.
                           , maxDepth' :: Int
                           }

data WxMGUI = WxMGUI { wxmWidget :: Widget, wxmGui :: GUI }

data WxMState = WxMState { wxmGuis                :: [WxMGUI]
                         , wxmAfterCreationAction :: WxAct()
                         , wxmUpdateEnabledness   :: IO ()
                         , wxmGlobalEnabled       :: Wx.Var Bool
                         }
initialWxMState :: IO WxMState
initialWxMState = do globalEnable <- Wx.varCreate True
                     return $ WxMState [] (return()) (return ()) globalEnable

extractGui :: WxM (ComIO a) -> WxM (ComIO a, Widget, GUI)
extractGui wxmComIO
    = testLiftWxM2WxM (wxmComIO >>= getGui)
    where
      testLiftWxM2WxM :: WxM a -> WxM a
      testLiftWxM2WxM wxm = 
          do iState <- io $ initialWxMState
             (x, st) <- WxM $ lift $ runStateT (wxm' wxm) iState
             WxM $ modify (\y -> y { wxmAfterCreationAction
                                         = do wxmAfterCreationAction y
                                              wxmAfterCreationAction st
                                   }
                          )
             return x
      -- FIXME: no label
      getGui :: ComIO a -> WxM (ComIO a, Widget, GUI)
      getGui comIO
          = do -- We handle all the encapsulated guis here, as enabledness should apply to them all.
               -- And we _don't_ do listeners, getValue, setValue as they shold only apply to
               -- the input ComIO (see argument wxmComIO).
               WxMState { wxmGuis              = guis
                        , wxmUpdateEnabledness = updateEnabledness
                        , wxmGlobalEnabled     = globalEnabled
                        } <- WxM $ get
               let com' = comIO { pickSetEnabled = \enabled -> do Wx.varSet globalEnabled enabled
                                                                  updateEnabledness
                                }
               case guis of
                 []    -> error "Cannot handle yet :("
                 [gui] -> return (com', wxmWidget gui, wxmGui gui)
                 guis' -> return ( com', (wxmWidget $ head guis')
                                 , containerGUI (map wxmGui guis') (PriLabel BadConstr "")
                                 )

comIOAddGui :: AddGui WxM ComIO a
comIOAddGui w gui comIO =
    do guis <- WxM $ gets wxmGuis
       case (reverse guis, gui) of
         ((WxMGUI wid (Buttons lay)):xs, Buttons lay')
             -> setGuis $ reverse $ (WxMGUI wid (Buttons $ Wx.row 5 [lay, lay'])):xs  -- FIXME: merge comio
         _   -> setGuis (guis ++ [WxMGUI (toWidget w) gui])
       --
       enabledVar    <- io $ Wx.varCreate True
       globalEnabled <- WxM $ gets wxmGlobalEnabled
       let updateEnabledness = do enabled <- liftM2 (&&) (Wx.varGet enabledVar) (Wx.varGet globalEnabled)
                                  pickSetEnabled comIO enabled
       WxM $ modify (\x -> x { wxmUpdateEnabledness = 
                                   do wxmUpdateEnabledness x
                                      updateEnabledness
                             }
                    )
       return $ comIO { pickSetEnabled = \enable -> do Wx.varSet enabledVar enable
                                                       updateEnabledness
                      }

defaultMaxDepth :: Int
defaultMaxDepth = 5


startI :: String -> WxM a -> IO ()
startI title wxq
    = Wx.start $ do f <- Wx.frame [ Wx.text Wx.:= title ]
                    p <- Wx.panel f []
                    (guis, afterCreationAction, _) <- execWxM wxq (Parent f) (Wx.close f) p
                    (lay, _) <- unboxedLayout $ containerGUI (map wxmGui guis) labelless
                    unsafeRunListenerM (runReaderT (wxAct' afterCreationAction) (Parent f, Wx.close f))
                    Wx.set f [ Wx.layout Wx.:= Wx.container p $ Wx.fill lay ]

-- newtype WxM a = WxM { wxm' :: StateT WxMState (ReaderT WxMReader IO) a }
execWxM :: WxM a -> Parent -> IO() -> Wx.Window w -> IO ([WxMGUI], WxAct(), a)
execWxM wxm parentWindow c panel =
    do iState <- initialWxMState
       (val, st) <- runReaderT (runStateT (wxm' wxm) iState) (WxMReader parentWindow c (Parent panel) defaultMaxDepth)
       return (wxmGuis st, wxmAfterCreationAction st, val)

runWxM :: WxM a -> Wx.Window w' -> IO() -> Wx.Window w -> IO a
runWxM wxm parentWindow c panel =
    do iState <- initialWxMState
       runReaderT (evalStateT (wxm' wxm) iState) (WxMReader (Parent parentWindow) c (Parent panel) defaultMaxDepth)

liftIO' :: ((forall b. WxM b -> IO b) -> IO a) -> WxM a
liftIO' f = do Parent parentWindow <- getFrame
               c                   <- getClose
               Parent panel        <- getPanel
               let local' wxm = runWxM wxm parentWindow c panel
               liftIO $ f local'

setGuis :: [WxMGUI] -> WxM ()
setGuis guis = WxM $ modify (\state -> state {wxmGuis = guis} )

getPostponedIO :: WxM (WxAct ())
getPostponedIO = WxM $ gets wxmAfterCreationAction

postponeAction' :: WxAct a -> WxM ()
postponeAction' action = WxM $ modify addAction where
    addAction state = state { wxmAfterCreationAction = wxmAfterCreationAction state >> (action >> return ()) }

-- |Returns enclosing frame or dialog.
getFrame :: WxM Parent
getFrame = WxM $ ask >>= return . frame'

-- |Returns an action to close the enclosing frame or dialog.
getClose :: WxM (IO())
getClose = WxM $ ask >>= return . close'

-- |Returns the panel or frame the widgets should be attached to, like `textCtrl panel []`.
getPanel :: WxM Parent
getPanel = WxM $ ask >>= return . panel'

-- |Sets the panel or frame the widgets should be attached to, like `textCtrl panel []`.
withPanel :: Wx.Window w -> WxM a -> WxM a
withPanel panel wxm = WxM $ local (\x -> x { panel' = Parent panel }) $ wxm' wxm

getMaxDepth :: WxM Int
getMaxDepth = WxM $ ask >>= return . maxDepth'

withMaxDepth :: (Int -> Int) -> WxM a -> WxM a
withMaxDepth maxDepth wxm =
    do currentMaxD <- getMaxDepth
       WxM $ local (\x -> x { maxDepth' = maxDepth currentMaxD }) $ wxm' wxm

goDeeper :: WxM Bool
goDeeper = do d <- getMaxDepth
              return (d > 0)