module Graphics.UI.WxGeneric.Composite
(
Composite, pickPanel, pickLayout, pickUser
, compose, singleComposite, singleCompositeEx
, mapPanelAttr, forAllChildren
, mapUserAttr, mapInheritedAttr
, mapEventF, mapPanelEvent, mapInheritedEvent
, propagateFutureEvents, EventToken(..), allEvents
, propagateFutureEventsEx, propagateWxEvent
, isEnterOrLeave, isMouseMotion, isMouseWheel
, ValuedWidget, widgetValue
, updateUser, updateInherited
, Inherit(..), CompositeInherit
)
where
import Graphics.UI.WX
import Graphics.UI.WXCore hiding (Event)
import qualified Graphics.UI.XTC as XTC
data Composite user = forall w.
Composite { pickPanel :: Window w
, pickLayout :: Layout
, pickUser :: user
}
newtype Inherit super = Inherit { unInherit :: super }
type CompositeInherit super = Composite (Inherit super)
compose :: (Panel () -> IO (Layout, user))
-> Window w -> [Prop (Composite user)] -> IO (Composite user)
compose f w props =
do p <- panel w []
(lay, user) <- f p
set p [ layout := lay ]
let composite = Composite p (container p lay) user
set composite props
return composite
singleComposite :: Window w -> user -> Composite user
singleComposite w u = Composite w (widget w) u
singleCompositeEx :: Window w -> Layout -> user -> Composite user
singleCompositeEx = Composite
mapPanelAttr :: (forall w. Attr (Window w) attr) -> Attr (Composite user) attr
mapPanelAttr attr = newAttr (attrName attr) getter setter
where getter (Composite wid _ _) = get wid attr
setter (Composite wid _ _) x = set wid [ attr := x ]
forAllChildren :: Attr (Window ()) attr -> (forall w. Attr (Window w) attr)
-> Attr (Composite user) attr
forAllChildren childAttr panelAttr = newAttr (attrName panelAttr) getter setter
where getter (Composite wid _ _) = get wid panelAttr
setter (Composite wid _ _) val =
do set wid [ panelAttr := val ]
xs <- get wid children
mapM_ (\x -> set x [ childAttr := val ]) xs
mapUserAttr :: Attr user attr -> Attr (Composite user) attr
mapUserAttr = mapAttrW pickUser
mapInheritedAttr :: Attr super attr -> Attr (CompositeInherit super) attr
mapInheritedAttr = mapAttrW (unInherit . pickUser)
instance Widget (Composite user) where
widget (Composite _ lay _) = lay
instance Able (Composite user) where
enabled = mapPanelAttr enabled
instance Bordered (Composite user) where
border = mapPanelAttr border
instance Child (Composite user) where
parent = mapPanelAttr parent
instance Colored (Composite user) where
bgcolor = forAllChildren bgcolor bgcolor
color = forAllChildren color color
instance Dimensions (Composite user) where
outerSize = mapPanelAttr outerSize
position = mapPanelAttr position
area = mapPanelAttr area
bestSize = mapPanelAttr bestSize
clientSize = mapPanelAttr clientSize
virtualSize = mapPanelAttr virtualSize
instance Identity (Composite user) where
identity = mapPanelAttr identity
instance Literate (Composite user) where
font = forAllChildren font font
fontSize = forAllChildren fontSize fontSize
fontWeight = forAllChildren fontWeight fontWeight
fontFamily = forAllChildren fontFamily fontFamily
fontShape = forAllChildren fontShape fontShape
fontFace = forAllChildren fontFace fontFace
fontUnderline = forAllChildren fontUnderline fontUnderline
textColor = forAllChildren textColor textColor
textBgcolor = forAllChildren textBgcolor textBgcolor
instance Parent (Composite user) where
children = mapPanelAttr children
clipChildren = mapPanelAttr clipChildren
instance Sized (Composite user) where
size = mapPanelAttr size
instance Visible (Composite user) where
visible = mapPanelAttr visible
refresh (Composite w _ _) = refresh w
fullRepaintOnResize = mapPanelAttr fullRepaintOnResize
instance Checkable super => Checkable (CompositeInherit super) where
checkable = mapInheritedAttr checkable
checked = mapInheritedAttr checked
instance Help super => Help (CompositeInherit super) where
help = mapInheritedAttr help
instance XTC.Observable super => XTC.Observable (CompositeInherit super) where
change = mapInheritedEvent XTC.change
instance Tipped super => Tipped (CompositeInherit super) where
tooltip = mapInheritedAttr tooltip
instance Items super String => Items (CompositeInherit super) String where
itemCount = mapInheritedAttr itemCount
items = mapInheritedAttr items
item x = mapInheritedAttr (item x)
itemDelete w x = itemDelete (unInherit $ pickUser w) x
itemsDelete w = itemsDelete (unInherit $ pickUser w)
itemAppend w x = itemAppend (unInherit $ pickUser w) x
instance Selection super => Selection (CompositeInherit super) where
selection = mapInheritedAttr selection
instance Selections super => Selections (CompositeInherit super) where
selections = mapInheritedAttr selections
instance Textual super => Textual (CompositeInherit super) where
text = mapInheritedAttr text
instance ValuedWidget a (super a) => ValuedWidget a (Composite (Inherit (super a))) where
widgetValue = mapInheritedAttr widgetValue
mapPanelEvent :: (forall w. Event (Window w) event) -> Event (Composite user) event
mapPanelEvent event = newEvent "" getter setter where
getter (Composite w _ _) = get w (on event)
setter (Composite w _ _) val = set w [ on event := val ]
mapInheritedEvent :: Event super event -> Event (CompositeInherit super) event
mapInheritedEvent event = mapEventF (unInherit . pickUser) event
mapEventF :: (to -> from) -> Event from event -> Event to event
mapEventF f event = newEvent "" getter setter where
getter w = get (f w) (on event)
setter w val = set (f w) [ on event := val ]
instance Selecting super => Selecting (CompositeInherit super) where
select = mapInheritedEvent select
instance Commanding super => Commanding (CompositeInherit super) where
command = mapInheritedEvent command
instance Reactive (Composite user) where
mouse = mapPanelEvent mouse
keyboard = mapPanelEvent keyboard
closing = mapPanelEvent closing
idle = mapPanelEvent idle
resize = mapPanelEvent resize
focus = mapPanelEvent focus
activate = mapPanelEvent activate
class ValuedWidget value widget | widget -> value where
widgetValue :: Attr widget value
updateUser :: (user -> user') -> Composite user -> Composite user'
updateUser f (Composite panel' lay user) = Composite panel' lay (f user)
updateInherited :: (super -> super') -> CompositeInherit super -> CompositeInherit super'
updateInherited f (Composite panel' lay super) = Composite panel' lay (Inherit $ f $ unInherit super)
data EventToken = Mouse
| Keyboard
| Focus
allEvents :: [EventToken]
allEvents = [ Mouse, Keyboard, Focus ]
propagateFutureEvents :: (Reactive from, Reactive to) => [EventToken] -> from -> to -> IO ()
propagateFutureEvents events from to = sequence_ $ map propHelper events
where
propHelper Mouse = propagateFutureEventsEx (not . isEnterOrLeave) from to mouse mouse
propHelper Keyboard = propagateFutureEventsEx (const True) from to keyboard keyboard
propHelper Focus = propagateFutureEventsEx (const True) from to focus focus
isEnterOrLeave :: EventMouse -> Bool
isEnterOrLeave (MouseEnter _ _) = True
isEnterOrLeave (MouseLeave _ _) = True
isEnterOrLeave _ = False
isMouseMotion :: EventMouse -> Bool
isMouseMotion (MouseMotion _ _) = True
isMouseMotion _ = False
isMouseWheel :: EventMouse -> Bool
isMouseWheel (MouseWheel _ _ _) = True
isMouseWheel _ = False
propagateFutureEventsEx
:: (t -> Bool)
-> fromWidget
-> toWidget
-> Event fromWidget (t -> IO ())
-> Event toWidget (t -> IO ())
-> IO ()
propagateFutureEventsEx propagateThisEvent fromWidget toWidget fromEvent toEvent =
set fromWidget [ on fromEvent := \evt -> if propagateThisEvent evt
then propagateWxEvent toWidget toEvent evt
else propagateEvent
]
propagateWxEvent :: toWindow -> Event toWindow (inEvt -> IO a) -> inEvt -> IO a
propagateWxEvent toWindow toEvent evt =
do evtHandler <- get toWindow (on toEvent)
evtHandler evt