AutoForms-0.4.0: src/Graphics/UI/AF/WxForm/ComIO.hs
{-# 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.
-}