{-# 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)