{-# LANGUAGE ExistentialQuantification, FlexibleContexts, FlexibleInstances, FunctionalDependencies , MultiParamTypeClasses, RankNTypes, TypeSynonymInstances #-} {-# OPTIONS -Wall #-} -- |Module to ease composing zero-to-many widgets to a larger -- composite widget. module Graphics.UI.WxGeneric.Composite ( -- * Composite type Composite, pickPanel, pickLayout, pickUser , compose, singleComposite, singleCompositeEx -- * Mapping attributes , mapPanelAttr, forAllChildren , mapUserAttr, mapInheritedAttr -- * Mapping events , mapEventF, mapPanelEvent, mapInheritedEvent -- * Event propagation , propagateFutureEvents, EventToken(..), allEvents , propagateFutureEventsEx, propagateWxEvent -- * Is Some Event , isEnterOrLeave, isMouseMotion, isMouseWheel -- * Other , ValuedWidget, widgetValue , updateUser, updateInherited , Inherit(..), CompositeInherit ) where import Graphics.UI.WX import Graphics.UI.WXCore hiding (Event) import qualified Graphics.UI.XTC as XTC -- What about Styled, Dockable, and Pictured classes? -- |Data type which contains a composite widget data Composite user = forall w. Composite { pickPanel :: Window w -- ^ Contains the widget, which this Composite represent. -- The term widget is used broadly here. It can either refer to -- some basic widget, like a text-box, or to a panel containing -- multiple sub-widgets. , pickLayout :: Layout , pickUser :: user } -- | A marker type, which indicates that we want to derive or inherit all -- wxHaskell type classes possible. newtype Inherit super = Inherit { unInherit :: super } -- Ugly name CompositeInherit - but could not figure out a better one. type CompositeInherit super = Composite (Inherit super) {- |Composes zero-to-many widgets to a larger composite widget The composite will automatically implement the following classes: * Widget * Able * Bordered * Child * Dimensions * Identity * Literate * Parent * Sized * Visible * Reactive (event class) if the user type = (Inherit x) and x implements one of the following classes, then so will the Composite: * Items * Observable * Selection * Selections * Textual * Commanding (event class) * Selecting (event class) * ValuedWidget if the composite needs to implement more classes it should be done as follows: @ type MyComposite = Composite user instance Foo MyComposite where ... @ -} 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 -- |Encapsulate a single 'Window w' in the composite type singleComposite :: Window w -> user -> Composite user singleComposite w u = Composite w (widget w) u -- |Encapsulate a single 'Window w' in the composite type singleCompositeEx :: Window w -> Layout -> user -> Composite user singleCompositeEx = Composite -- |Used when an attribute should apply to the panel 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 ] -- |Used when an attribute should apply to the panel and all of its -- children 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 -- |Used when an attribute should apply to the "usertype" mapUserAttr :: Attr user attr -> Attr (Composite user) attr mapUserAttr = mapAttrW pickUser -- |Used when an attribute should apply to the inherited "usertype" mapInheritedAttr :: Attr super attr -> Attr (CompositeInherit super) attr mapInheritedAttr = mapAttrW (unInherit . pickUser) -- *** Inherit from Widget w 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 -- Does this instance declaration make sense? 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 -- fullRepaintOnResize unfortunately do not make any sense, -- it must be set at creation time, but the panel has no -- attributes set at creation time :( -- *** Inherit from super 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 -- if we change String into just "a", then we also need the flag -- -fallow-undecidable-instances, which we do not want to do. 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 -- We need to use (super a) to make this instance decidable instance ValuedWidget a (super a) => ValuedWidget a (Composite (Inherit (super a))) where widgetValue = mapInheritedAttr widgetValue -- *** Events -- | Mapping events from the Panel () 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 ] -- |Mapping events from the inherited "usertype" mapInheritedEvent :: Event super event -> Event (CompositeInherit super) event mapInheritedEvent event = mapEventF (unInherit . pickUser) event -- | Mapping events using a mapper function 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 -- We should also do Paint -- Should properly rename ValuedWidget to Valued, but there is already -- a type class called Valued in WxHaskell. However, WxHaskell's -- definition do not really work for widgets. It only seems to work -- for Var-s. class ValuedWidget value widget | widget -> value where -- |An attribute for the value of a widget. The value should have as precise -- a type as possible. For example a slider should properly have type Attr Slider Int. widgetValue :: Attr widget value -- GHC error message: -- Record update for the non-Haskell-98 data type `Composite' is not (yet) supported -- Use pattern-matching instead -- -- Thus we avoid pattern matching here. 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) -- *** Event propagation {- Which to propagate mouse Yes keyboard Yes closing No, as we already know when the panel is closing idle No, as we can already attach that to the panel resize No, as we can already attach that to the panel focus Yes activate (when a frame is (de)-activated, an activiate event is sent) No, as it only applies to frames and dialogs. -} data EventToken = Mouse | Keyboard | Focus allEvents :: [EventToken] allEvents = [ Mouse, Keyboard, Focus ] -- | 'propagateFutureEvents' is an easy to use wrapper around -- 'propagateFutureEvents'. -- -- 'propagateFutureEvents' propagates future events from one widget to -- another, based on a list of 'EventToken's. The from widget will -- usually be a normal wxHaskell widget or some 'Composite'. The to -- widget will usually be a panel or a frame. -- propagateFutureEvents :: (Reactive from, Reactive to) => [EventToken] -> from -> to -> IO () propagateFutureEvents events from to = sequence_ $ map propHelper events where -- We do not want to propagate enter/leave events, as only want these widgets -- when leaving/entering the hole widgets. 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 -- | Transmit future events from one wxHaskell widget to a -- parent-widget. All events, where 'propagateThisEvent' returns -- 'True' is propagated to the parent-widget. If 'False' is returned, -- then we call 'Graphics.UI.WX.Events.propagateEvent', so the -- form-widgets normal event handling code will recieve the -- event. E.g. a button should not propagate click-events to the -- parent-widget, but the button should handle the click-event itself. -- -- However, it is essential to note that 'propagateThisEvent' _cannot_ -- be used to decide if the from-widget should have some events -- blocked. It is only usefull for deciding if events should be -- propagated to the parent 'Window w'. Even if an event is propagated -- to a parent-widget, then the parent-widget's event handling code -- may call 'Graphics.UI.WX.Events.propagateEvent', and then propagate -- the event back to the from-widget. -- -- Note that we need two Event inputs, otherwise the 'fromWidget' and 'toWidget' -- must be of the same type. -- -- See 'propagateFutureEvents' for an easier to use version of -- 'propagateFutureEventsEx'. propagateFutureEventsEx :: (t -> Bool) -- ^ Only propagates events where this function returns true. -> fromWidget -- ^ The Window w to propagate from -> toWidget -- ^ The Window w to propagate from -> Event fromWidget (t -> IO ()) -- ^ From event -> Event toWidget (t -> IO ()) -- ^ To Event -> IO () propagateFutureEventsEx propagateThisEvent fromWidget toWidget fromEvent toEvent = set fromWidget [ on fromEvent := \evt -> if propagateThisEvent evt then propagateWxEvent toWidget toEvent evt else propagateEvent ] -- | Propagate an event to a 'Window w'. propagateWxEvent :: toWindow -> Event toWindow (inEvt -> IO a) -> inEvt -> IO a propagateWxEvent toWindow toEvent evt = do evtHandler <- get toWindow (on toEvent) evtHandler evt