module Graphics.UI.WxGeneric.GenericWidget
( valuedCompose
, mkGenWid, mkSingleObservable, mkSingleObservableEx, GenWid, GenWidIO
, MapValue(..)
, module Graphics.UI.WxGeneric.GenericWidget.Parameters
, module Graphics.UI.WxGeneric.GenericWidget.WidgetTree
)
where
import Graphics.UI.WX
import qualified Graphics.UI.WXCore as WXCore
import qualified Graphics.UI.XTC as XTC
import qualified Graphics.UI.WxGeneric.Composite as C
import Graphics.UI.WxGeneric.GenericWidget.Parameters
import Graphics.UI.WxGeneric.GenericWidget.WidgetTree
type GenWidIO a = forall w. Parms w -> IO (GenWid a)
valuedCompose :: (Parms (WXCore.CPanel ())
-> IO (Layout, IO a, a -> IO(), IO (IO ()), IO() -> IO(), IO WidTree)
)
-> GenWidIO a
valuedCompose f genWidParms =
do let w = getParent genWidParms
p <- panel w []
C.propagateFutureEvents C.allEvents p w
(lay, getter, setter, getChange, setChange, getWidTree) <- f (setParent p genWidParms)
return $ mkGenWidEx p (container p lay) getter setter getChange setChange getWidTree
data ValuedCmds a = ValuedCmds
{ pickGetValue :: IO a
, pickSetValue :: a -> IO ()
, pickGetChange :: IO (IO ())
, pickSetChange :: IO() -> IO()
, pickGetWidTree :: IO WidTree
}
instance XTC.Observable (ValuedCmds a) where
change = newEvent "change" pickGetChange pickSetChange
instance C.ValuedWidget a (ValuedCmds a) where
widgetValue = newAttr "valued" pickGetValue pickSetValue
newtype GenWid a = GenWid { unGenWid :: (C.CompositeInherit (ValuedCmds a)) }
deriving ( Widget, Able, Bordered, Child, Dimensions, Identity, Literate, Visible, Reactive, Parent, Sized
, XTC.Observable, C.ValuedWidget a
)
mkGenWid :: forall w a.
Window w -> IO a -> (a -> IO ()) -> IO (IO ()) -> (IO() -> IO()) -> (IO WidTree)
-> GenWid a
mkGenWid w getVal setVal getChg setChg getWidTree =
GenWid $ C.singleComposite w (C.Inherit (ValuedCmds getVal setVal getChg setChg getWidTree))
mkGenWidEx :: forall w a.
Window w -> Layout -> IO a -> (a -> IO ()) -> IO (IO ()) -> (IO() -> IO()) -> (IO WidTree)
-> GenWid a
mkGenWidEx w lay getVal setVal getChg setChg getWidTree =
GenWid $ C.singleCompositeEx w lay (C.Inherit (ValuedCmds getVal setVal getChg setChg getWidTree))
mkSingleObservable :: forall w a. (XTC.Observable (Window w)) =>
Window w -> IO a -> (a -> IO ()) -> IO WidTree
-> GenWid a
mkSingleObservable wid getter setter getWidTree =
mkGenWid wid getter setter getChange setChange getWidTree
where getChange = get wid (on XTC.change)
setChange x = set wid [on XTC.change := x]
mkSingleObservableEx
:: forall w a. (XTC.Observable (Window w)) =>
Window w -> (Layout -> Layout) -> IO a -> (a -> IO ()) -> IO WidTree
-> GenWid a
mkSingleObservableEx wid lay getter setter getWidTree =
mkGenWidEx wid (lay $ widget wid) getter setter getChange setChange getWidTree
where getChange = get wid (on XTC.change)
setChange x = set wid [on XTC.change := x]
class MapValue (valued :: * -> *) where
mapValue :: (old -> new)
-> (old -> new -> old)
-> valued old
-> valued new
instance MapValue GenWid where
mapValue oldToNew newToOld (GenWid composite) =
let updateCmds valuedCmds =
valuedCmds { pickGetValue = pickGetValue valuedCmds >>= return . oldToNew
, pickSetValue = \x -> do old <- pickGetValue valuedCmds
pickSetValue valuedCmds (newToOld old x)
}
in GenWid $ C.updateInherited updateCmds composite
instance WidgetTree (GenWid a) where
widgetTree = readAttr "widgetTree"
(pickGetWidTree . C.unInherit . C.pickUser . unGenWid)