{-# LANGUAGE ExistentialQuantification, FlexibleContexts, FlexibleInstances , GeneralizedNewtypeDeriving, MultiParamTypeClasses, RankNTypes , ScopedTypeVariables, UndecidableInstances #-} -- |The ComIO type module Graphics.UI.AF.WxForm.ComIO ( io -- * ComIO , ComIO ( pickGetVal, pickSetVal, pickAppendVal , pickGetEnabled, pickSetEnabled, pickAddLimit) , mkComIO -- * Component construction , staticComIO , SetOn (..) , guiComM, GuiComHelper(..), AddGui , getterSetterComIO -- * Handle limits , makeLimitVar, addToLimitVar, checkLimits, tellUserOfIllegalValue , Limit, LimitResult(..) -- * Listener monad and signaling of change , OnChangeVars, makeOnChangeVar , OnChange(addListener, setParentListener) , unsafeSignalChange, unsafeRunListenerM, ListenerM , module Control.Monad.RecursiveObserver ) where import Graphics.UI.WX (Var, varCreate, varGet, varSet) import qualified Graphics.UI.WX as Wx import qualified Graphics.UI.AF.General.AutoForm as AF import Graphics.UI.AF.WxForm.GUI import qualified Random import Control.Monad.Writer import Control.Monad.RecursiveObserver import System.IO.Unsafe(unsafeInterleaveIO) io :: MonadIO m => IO a -> m a io = liftIO instance AF.Valued ComIO where mapValue old2NewFun new2OldFun comIO = comIO { pickGetVal = do val <- pickGetVal comIO return $ old2NewFun val , pickSetVal = \newVal -> do oldVal <- pickGetVal comIO pickSetVal comIO (new2OldFun oldVal newVal) , pickAppendVal = case pickAppendVal comIO of Nothing -> Nothing Just f' -> Just (\newVal -> -- we use unsafeInterleaveIO as the oldVal is not always needed -- and as it defies the purpose of the appendVal optimization. do oldVal <- unsafeInterleaveIO $ pickGetVal comIO f' (new2OldFun oldVal newVal) ) , pickAddLimit = \limitFun -> pickAddLimit comIO (\oldVal -> limitFun (old2NewFun oldVal)) } noValue comIO = comIO { pickGetVal = return () , pickSetVal = const $ return () , pickAppendVal = Just $ const $ return () , pickAddLimit = const $ return () } instance (MonadIO m, Observable OnChangeVars m) => AF.ValuedAction ComIO m where getValue = io . pickGetVal setValue comIO x = do io $ pickSetVal comIO x signalChange (pickOnChangeVar comIO) nonRecursiveSetValue comIO x = whenNotVisited (pickOnChangeVar comIO) (AF.setValue comIO x) appendValue comIO xs = maybe (do value <- AF.getValue comIO AF.setValue comIO (value `mappend` xs) ) (\f -> io $ f xs) (pickAppendVal comIO) data LimitResult = Rejected String | Accepted type Limit a = a -> IO LimitResult -- |Component IO-commands data ComIO a = ComIO { pickGetVal :: IO a , pickSetVal :: a -> IO() , pickAppendVal :: Maybe (a -> IO()) -- ^Appends a value to the component. This only -- makes sense for some component. E.g. list components. , pickOnChangeVar :: OnChangeVars , pickGetEnabled :: IO Bool -- ^Tells the callee if the GUI for the component is enabled. -- Even if the component is disabled, a programmer can -- still call 'pickSetVal', 'pickAppendVal', and -- 'pickSetState'. It is only for the GUI-user the -- component is enabled or disabled. , pickSetEnabled :: Bool -> IO() -- ^Sets the enabledness of a component. See also -- 'pickGetEnabled'. , pickAddLimit :: Limit a -> IO() -- ^Adds a limit check to the component. } mkComIO :: (MonadIO m) => IO a -> (a -> IO ()) -> OnChangeVars -> IO Bool -> (Bool -> IO ()) -> (Limit a -> IO ()) -> m (ComIO a) mkComIO getVal setVal ocVar getEnabled setEnabled addLimit = do return $ ComIO getVal setVal Nothing ocVar getEnabled setEnabled addLimit -- ComIO constructor functions ----------------------------------------- -- | Returns a ComIO type, which just stores values when setVal is -- called and retrieves values when getVal is called. It should be -- used when no GUI can be created for a type. staticComIO :: (MonadIO m) => a -> m (ComIO a) staticComIO val = do valVar <- io $ varCreate val let getVal = varGet valVar setVal x = do varSet valVar x return () getterSetterComIO getVal setVal getterSetterComIO :: (MonadIO m) => IO a -> (a -> IO()) -> m (ComIO a) getterSetterComIO getVal setVal = do enableVar <- io $ varCreate True ocVar <- io $ makeOnChangeVar let getEnabled = varGet enableVar setEnabled x = do varSet enableVar x return () addLimit _ = return () mkComIO getVal setVal ocVar getEnabled setEnabled addLimit -- |IO-commands helped in the construction of components. Is used by -- function that construct components via guiComM. data GuiComHelper a = GuiComHelper { testInputParm' :: (SetOn -> a -> IO ()) , readGuiOnGetValParm' :: (Eq a) => IO a -> IO () } type AddGui builder com a = forall w. Wx.Window w -> GUI -> ComIO a -> builder (com a) guiComM :: (Show a, MonadIO builder) => AddGui builder com a -> Maybe (a -> a -> Bool) -> a -> (a -> IO ()) -> Wx.Window w -> GUI -> builder (com a, GuiComHelper a) guiComM addGui equals value setGuiValue wid gui = do limitVar <- io $ makeLimitVar lastValVar <- io $ varCreate value onChangeVar <- io $ makeOnChangeVar enabledVar <- io $ varCreate True onGetValVar <- io $ varCreate (varGet lastValVar) -- let whenChanged newValue thenDo = case equals of Nothing -> thenDo Just eq -> do oldVal <- varGet lastValVar when (not $ oldVal `eq` newValue) thenDo testInput setOn newValue = do res <- checkLimits limitVar newValue case (setOn, res) of (SetOnAccept, Rejected msg) -> do tellUserOfIllegalValue msg (SetOnAccept, Accepted) -> whenChanged newValue $ do varSet lastValVar newValue setGuiValue newValue signalGuiChange onChangeVar (SetOnReject, Rejected msg) -> do tellUserOfIllegalValue msg setGuiValue =<< varGet lastValVar (SetOnReject, Accepted) -> whenChanged newValue $ do varSet lastValVar newValue signalGuiChange onChangeVar setValue x = do res <- checkLimits limitVar x case res of Rejected _ -> return () -- FIXME: should probably log something Accepted -> varSet lastValVar x >> setGuiValue x readGuiOnGetVal f = do varSet onGetValVar $ do x <- f res <- checkLimits limitVar x case res of Rejected msg -> do tellUserOfIllegalValue msg xOld <- varGet lastValVar setGuiValue xOld return xOld Accepted -> do varSet lastValVar x signalGuiChange onChangeVar return x getVal = do f <- varGet onGetValVar f setEnabled enabled = do varSet enabledVar enabled Wx.set wid [ Wx.enabled Wx.:= enabled ] com <- mkComIO getVal setValue onChangeVar (varGet enabledVar) setEnabled (addToLimitVar limitVar) >>= addGui wid gui io $ setGuiValue value return ( com, GuiComHelper testInput readGuiOnGetVal) -- Calls setVal when the value is acceptet by limit function or call -- setVal when value is rejected by limit function. data SetOn = SetOnAccept | SetOnReject -- Limit handeling ------------------------------------------------------- type LimitVar a = Var [Limit a] -- |Constructs a 'LimitVar' with no limits in it. makeLimitVar :: IO (LimitVar a) makeLimitVar = varCreate [] -- |Adds a limit to a 'LimitVar' addToLimitVar :: LimitVar a -> Limit a -> IO () addToLimitVar limitVar limit = do limits <- varGet limitVar varSet limitVar (limits ++ [limit]) checkLimits :: (Show a) => LimitVar a -> a -- ^The new value -> IO LimitResult -- ^The result of the limit check checkLimits limitVar newValue = do limits <- varGet limitVar callLimitChecks limits where callLimitChecks [] = return Accepted callLimitChecks (limit:limits) = do res <- limit newValue case res of Rejected _ -> return res Accepted -> callLimitChecks limits -- |Use this function to tell the GUI-user that he violated some limit. tellUserOfIllegalValue :: String -> IO() tellUserOfIllegalValue = putStrLn -- On Change handeling --------------------------------------------------------- newtype EventID = EventID Int deriving (Random.Random, Show, Eq) newtype ListenerM a = ListenerM { listenerM' :: ListenerT EventID IO a } deriving (Monad, MonadIO, MonadListener, Observable OnChangeVars, Observable (ComIO b)) instance Observable OnChangeVars (ListenerT EventID IO) where whenNotVisited = whenNotVisitedHelper (io . varGet . pickEventID) visit = visitHelper (\oc eid -> do varSet (pickEventID oc) eid) signalChange = signalChangeHelper (\oc -> listenerM' $ do listeners' <- io $ getListeners oc parentListeners <- io $ getParentListener oc sequence_ (listeners' ++ [parentListeners]) ) instance Observable (ComIO a) (ListenerT EventID IO) where whenNotVisited o = whenNotVisited (pickOnChangeVar o) visit o = visit (pickOnChangeVar o) signalChange o = signalChange (pickOnChangeVar o) {- Detecting eternal recursion if signalGuiChange are called X number of times with Y ms, then we properly have an eternal recursion and we could stop transmititng the call until Z ms has passed. -} signalGuiChange :: OnChange oc => oc -> IO() signalGuiChange oc = do runListenerTWithNewEID (listenerM' $ signalChange oc) join $ getWxHaskellListener oc unsafeSignalChange :: OnChange oc => oc -> IO() unsafeSignalChange = signalGuiChange unsafeRunListenerM :: ListenerM a -> IO a unsafeRunListenerM m = runListenerTWithNewEID (listenerM' m) data OnChangeVars = OnChangeVars { pickEventID :: Var EventID , pickListeners :: Var [ListenerM ()] , pickParent :: Var (ListenerM ()) , pickWxHaskellListeners :: Var (IO ()) } -- |Constructs an 'OnChangeVar' with no listeners. makeOnChangeVar :: IO OnChangeVars makeOnChangeVar = do eid <- varCreate (EventID 0) listeners <- varCreate [] parent <- varCreate (return ()) wxHaskell <- varCreate (return ()) return $ OnChangeVars { pickEventID = eid , pickListeners = listeners , pickParent = parent , pickWxHaskellListeners = wxHaskell } class Observable oc ListenerM => OnChange oc where addListener :: oc -> ListenerM () -> IO() addListener oc action = do listeners' <- getListeners oc setListeners oc (listeners' ++ [action]) getListeners :: oc -> IO [ListenerM ()] setListeners :: oc -> [ListenerM ()] -> IO() getParentListener :: oc -> IO (ListenerM ()) setParentListener :: oc -> ListenerM () -> IO() getWxHaskellListener :: oc -> IO (IO ()) setWxHaskellListener :: oc -> IO () -> IO () instance OnChange OnChangeVars where getListeners oc = varGet $ pickListeners oc setListeners oc actions = varSet (pickListeners oc) actions getParentListener oc = varGet $ pickParent oc setParentListener oc action = varSet (pickParent oc) action getWxHaskellListener oc = varGet $ pickWxHaskellListeners oc setWxHaskellListener oc action = varSet (pickWxHaskellListeners oc) action instance OnChange (ComIO a) where getListeners oc = getListeners (pickOnChangeVar oc) setListeners oc actions = setListeners (pickOnChangeVar oc) actions getParentListener oc = getParentListener (pickOnChangeVar oc) setParentListener oc action = setParentListener (pickOnChangeVar oc) action getWxHaskellListener oc = getWxHaskellListener (pickOnChangeVar oc) setWxHaskellListener oc actions = setWxHaskellListener (pickOnChangeVar oc) actions {- ------------- Making ComIO instances of some WxHaskell classes ------------ -} instance Wx.Commanding (ComIO a) where command = Wx.newEvent "Commanding" getter setter where getter = getWxHaskellListener setter = setWxHaskellListener instance Wx.Able (ComIO a) where enabled = Wx.newAttr "Able" (\w -> pickGetEnabled w) (\w -> pickSetEnabled w) instance Wx.Valued ComIO where value = Wx.newAttr "Value" (\w -> pickGetVal w) (\w -> pickSetVal w) -------------------------------------------------------------------------------- {- Some difficult to understand design rationale: In ComIO, instead of the GUI type we could just use (Layout, PriLabel). When needing GUI boxes (is needed when having types with multiply children), they could be created directly by genericCom. However, we need the extra GUI type to ensure that only non top-level types gets surrounded by a box. We cannot have this in the generic function, as the generic function needs to act the same for all types. Note, that sometimes we do want top-level types surrounded by boxes, but not always. Threading a (isTopLevel :: Bool) is ugly and not even a solution, as the top-level can be: data Foo = Foo Bar; data Bar = Bar Int String and then no box around Foo but box around Bar. But as Foo should be ignored as it only has one child we still have box around the top level. Not what we intended. Now, there may be a workaround for that, but it all gets very ugly. Furtermore, to get tab order and shortcuts, we need to know all the labels at once. Which, again requires the extra step. -}