WxGeneric 0.5.2 → 0.6.0
raw patch · 15 files changed
+846/−303 lines, 15 filesdep +containersdep ~SybWidget
Dependencies added: containers
Dependency ranges changed: SybWidget
Files
- WxGeneric.cabal +20/−10
- examples/AlarmSpecialized.hs +33/−6
- examples/EventPropagation/AllEventsComposite.hs +1/−1
- examples/EventPropagation/makefile +6/−1
- examples/Examples.hs +26/−10
- examples/TupleExample.hs +4/−1
- examples/makefile +12/−18
- src/Graphics/UI/WxGeneric.hs +5/−2
- src/Graphics/UI/WxGeneric/Composite.hs +104/−44
- src/Graphics/UI/WxGeneric/GenericClass.hs +177/−122
- src/Graphics/UI/WxGeneric/GenericList.hs +98/−38
- src/Graphics/UI/WxGeneric/GenericWidget.hs +97/−50
- src/Graphics/UI/WxGeneric/GenericWidget/Parameters.hs +99/−0
- src/Graphics/UI/WxGeneric/GenericWidget/WidgetTree.hs +64/−0
- src/Graphics/UI/WxGeneric/Layout.hs +100/−0
WxGeneric.cabal view
@@ -1,27 +1,37 @@ Name: WxGeneric-Version: 0.5.2+Version: 0.6.0 Copyright: Mads Lindstrøm <mads_lindstroem@yahoo.dk>-license: LGPL+License: LGPL License-file: wxWidgetsLicense.txt Author: Mads Lindstrøm <mads_lindstroem@yahoo.dk> Maintainer: Mads Lindstrøm <mads_lindstroem@yahoo.dk>+Homepage: http://www.haskell.org/haskellwiki/WxGeneric Category: GUI-Build-Depends: SybWidget>=0.4,base,haskell98,mtl,xtc>=1.0,wx>=0.10.3+Build-Depends: SybWidget>=0.5.2,base,haskell98,mtl,xtc>=1.0,wx>=0.10.3,containers>0.2 ,wxcore>=0.10.3-Tested-with: GHC==6.8.2-Synopsis: Library which constructing generic (SYB3-based) widgets for WxHaskell+Tested-with: GHC==6.10.1,GHC==6.10.2+Synopsis: Generic (SYB3) construction of wxHaskell widgets Build-type: Simple Stability: experimental Description:- Constructs widgets for WxHaskell using SybWidget.+ Using an algebraic data types structure and field names, this library constructs+ widgets for wxHaskell. It can handle data types with single or multiple+ constructors, as well as recursive data types.+ .+ The library is designed to integrate smoothly with wxHaskell. First, by making it+ easy to integrate WxGeneric-widgets into existing wxHaskell programs. Second, by+ letting a user extend WxGeneric using mostly wxHaskell function. Ghc-options: -Wall Exposed-modules: Graphics.UI.WxGeneric- , Graphics.UI.WxGeneric.GenericClass- , Graphics.UI.WxGeneric.Composite , Graphics.UI.WxGeneric.GenericWidget- , Graphics.UI.WxGeneric.GenericList+ , Graphics.UI.WxGeneric.Composite+ , Graphics.UI.WxGeneric.Layout other-modules:+ Graphics.UI.WxGeneric.GenericList+ , Graphics.UI.WxGeneric.GenericClass+ , Graphics.UI.WxGeneric.GenericWidget.Parameters+ , Graphics.UI.WxGeneric.GenericWidget.WidgetTree Extra-Source-Files: examples/makefile , examples/Alarm.hs@@ -34,7 +44,7 @@ , examples/EventPropagation/AllEventsComposite.hs , examples/EventPropagation/IntEntry.hs , examples/EventPropagation/PropagateEvents.hs-Extensions: +Extensions: hs-source-dirs: src
examples/AlarmSpecialized.hs view
@@ -1,6 +1,17 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses , TemplateHaskell, UndecidableInstances #-} +{- | The example shows two things.++1) How to specialize a widget. See instance WxGen Minutes.++2) Show that WxGeneric (and Composite) behaves nicely with respect to+ enabledness. That is it remembers the enabledness of the+ minutes-widget, even if we disable/enbale of the hole generic+ widget. But of cause, 'minutes' is only enabled when both the hole+ generic widget is enbaled and when the minutes-widget itself is+ enabled.+-} module AlarmSpecialized where import Graphics.UI.WxGeneric@@ -21,22 +32,31 @@ instance WxGen Minutes where mkWid m' = toOuter (valuedCompose helper)- where helper p = - do changeVar <- varCreate (return ())+ where helper genWidParms = + do let p = getParent genWidParms+ changeVar <- varCreate (return ()) hours <- hslider p True 0 23 [ selection := fst $ minutes2Clock m' ]- minutes <- hslider p True 0 23 [ selection := snd $ minutes2Clock m' ]+ minutes <- hslider p True 0 59 [ selection := snd $ minutes2Clock m' ]+ ableMinutes <- button p + [ text := "(Dis/En)able minutes"+ , on command := set minutes [ enabled :~ not ]+ ] let setChangeVar x = do set hours [ on command := x ] set minutes [ on command := x ]- lay = grid 10 10 [ [ label "Hours: ", fill $ widget hours ]- , [ label "Minutes: ", fill $ widget minutes ] ]+ lay = column 5 [ grid 10 10 [ [ label "Hours: ", fill $ widget hours ]+ , [ label "Minutes: ", fill $ widget minutes ]+ ]+ , hfloatCenter $ widget ableMinutes+ ] getVal = liftM2 clock2Minutes (get hours selection) (get minutes selection) setVal ys = do let (h, m) = minutes2Clock ys set hours [selection := h] set minutes [selection := m] return ( lay, getVal, setVal , varGet changeVar, setChangeVar+ , leafWidTree [WxWindow hours, WxWindow minutes] ) minutes2Clock (Minutes m) = (m `div` 60, m `mod` 60) clock2Minutes h m = Minutes (60*h + m)@@ -48,5 +68,12 @@ en <- genericWidget p (Alarm "My alarm" $ Minutes 117) b <- button p [ text := "&Print alarm" , on command := get en widgetValue >>= print ]- set f [ layout := container p $ row 10 [ fill $ widget en, widget b ]+ ableAll <- button p + [ text := "(Dis/En)able all"+ , on command := set en [ enabled :~ not ]+ ]+ let lay = row 10 [ fill $ widget en+ , vfloatCenter $ column 10 [ widget b, widget ableAll ]+ ]+ set f [ layout := container p lay , size := Size 550 165 ]
examples/EventPropagation/AllEventsComposite.hs view
@@ -20,7 +20,7 @@ ch <- comboBox p [ items := [ "One", "Two", "Three" ] , selection := 0 ]- propagate allEvents ch p+ propagateFutureEvents allEvents ch p return (column 10 [ widget intEn, glue, widget ch ], (ch, intEn)) where handleInput (KeyChar c) =
examples/EventPropagation/makefile view
@@ -12,7 +12,12 @@ .PHONY: clean remake -remake:clean all+remake:+# It is wrong to specify these as targets, as they must be run in specified order.+# Though, you will only see this problem with parallel make (-j).+ $(MAKE) clean+ $(MAKE) all+ clean: - rm *.hi *.o *~ $(EXAMPLES)
examples/Examples.hs view
@@ -23,19 +23,29 @@ $(derive [''MyTree]) instance WxGen MyTree -data Person = Person { name :: String, age :: Int, children :: [Person] } deriving Show--- data Person = Person { name :: String, children :: [String], age :: Int }+data Age = Age { unAge :: Int } deriving Show+data Person = Person { name :: String, age :: Age, children :: [Person] } deriving Show -$(derive [''Person])+aPerson :: Person+aPerson = Person "Bob" (Age 17) []++$(derive [''Person,''Age]) instance WxGen Person+instance WxGen Age where+ mkWid x = mapValue Age (const unAge) $+ setOuterLabel (userDefinedLabel "Line one\nLine two\nLine Three") $+ mkWid (unAge x) +main :: IO () main = setOuterLabelTest +someTree :: MyTree someTree = Leaf 5 5.2 -x :: Int-x = 17+someInt :: Int+someInt = 17 +tree :: IO () tree = start $ do f <- frame [] p <- panel f []@@ -50,6 +60,7 @@ ] ] +tree' :: IO () tree' = start $ do f <- frame [] -- p <- panel f []@@ -64,21 +75,23 @@ , widget b1 ] ] -+person :: IO () person = start $ do f <- frame [] p <- panel f []- -- en <- genericWidget p (Person "Bob" [] 17)- en <- genericWidget p (Person "Bob" 17 [])+ -- en <- genericWidget p aPerson+ en <- genericWidget p aPerson set f [ layout := container p $ fill $ widget en ] +anyInt :: IO () anyInt = start $ do f <- frame []- intEntry <- genericWidget f x+ intEntry <- genericWidget f someInt set intEntry [ on change := get intEntry widgetValue >>= print ] set f [ layout := widget intEntry ] +mai3 :: IO () mai3 = start $ do f <- frame [] p <- panel f []@@ -86,12 +99,14 @@ set f [ layout := widget p ] -- must also have fill set p [ layout := fill $ widget en ] +enum :: IO () enum = start $ do f <- frame [] myEnum <- genericWidget f Enum1 set myEnum [ on change := get myEnum widgetValue >>= print ] set f [ layout := widget myEnum ] +listTest :: IO () listTest = start $ do f <- frame [] p <- panel f []@@ -99,10 +114,11 @@ set listWid [ on change := get listWid widgetValue >>= print ] set f [ layout := container p $ fill $ widget listWid ] +setOuterLabelTest :: IO () setOuterLabelTest = start $ do f <- frame [] p <- panel f []- en <- fromOuter p $ setOuterLabel (userDefinedLabel "User-set label") $ mkWid (Person "Bob" 17 [])+ en <- genericWidgetEx id (setOuterLabel (userDefinedLabel "User-set label")) p aPerson set f [ layout := container p $ fill $ widget en ]
examples/TupleExample.hs view
@@ -7,7 +7,10 @@ main = start $ do f <- frame [ text := "Tuple Example" ] p <- panel f []- en <- genericWidget p (3 :: Int, "Hans", 5.5 :: Double)+ en <- genericWidgetEx (\x -> x { joinLayout = twoColumnLayout -- Force two column layout+ , labelTransform = idLabel -- No label shortcuts+ })+ id p (3 :: Int, "Hans", 5.5 :: Double) b <- button p [ text := "&Print tuple" , on command := get en widgetValue >>= print ] set f [ layout := container p $ row 10 [ widget en, widget b ] ]
examples/makefile view
@@ -1,32 +1,26 @@ HC = ghc HC_MAKE = $(HC) -Wall --make $< -o $@ -main-is $(notdir $@) $(HC_OPTIONS)-EXAMPLES=Examples TupleExample Alarm AlarmSpecialized AlarmMapValue-SCREENSHOT_DIR=screenshots+EXAMPLES=WidgetList Alarm AlarmSpecialized TupleExample Examples all:$(EXAMPLES) %: %.hs $(HC_MAKE) -Examples:Examples.hs TupleExample.hs+WidgetList:WidgetList.hs+Alarm:Alarm.hs+AlarmSpecialized:AlarmSpecialized.hs+TupleExample:TupleExample.hs+Examples:Examples.hs .PHONY: clean remake -remake:clean all+remake:+# It is wrong to specify these as targets, as they must be run in specified order.+# Though, you will only see this problem with parallel make (-j).+ $(MAKE) clean+ $(MAKE) all+ clean: - rm *.hi *.o *~ $(EXAMPLES) -define makeScreenshot- echo "Doing $(1) screenshot"- ./$(1) &- sleep 2 && import -frame -window $(2) $(SCREENSHOT_DIR)/$(1)Screenshot.png- killall $(1)-endef--screenshots: all- - rm -rf $(SCREENSHOT_DIR)- mkdir $(SCREENSHOT_DIR)- $(call makeScreenshot,TupleExample,"Tuple Example")- $(call makeScreenshot,Alarm,"Alarm Example")- $(call makeScreenshot,AlarmSpecialized,"Alarm Specialized Example")- $(call makeScreenshot,AlarmMapValue,"Alarm Map Value")
src/Graphics/UI/WxGeneric.hs view
@@ -2,11 +2,14 @@ ( module Graphics.UI.WxGeneric.GenericClass , module Graphics.UI.WxGeneric.GenericWidget , module Graphics.UI.WxGeneric.Composite- , module Graphics.UI.WxGeneric.GenericList+ , module Graphics.UI.WxGeneric.Layout ) where import Graphics.UI.WxGeneric.GenericClass import Graphics.UI.WxGeneric.GenericWidget import Graphics.UI.WxGeneric.Composite-import Graphics.UI.WxGeneric.GenericList+import Graphics.UI.WxGeneric.Layout++-- Getting WxGen instances+import Graphics.UI.WxGeneric.GenericList()
src/Graphics/UI/WxGeneric/Composite.hs view
@@ -6,16 +6,18 @@ -- composite widget. module Graphics.UI.WxGeneric.Composite ( -- * Composite type- Composite, pickPanel, pickUser- , compose, singleComposite+ Composite, pickPanel, pickLayout, pickUser+ , compose, singleComposite, singleCompositeEx -- * Mapping attributes , mapPanelAttr, forAllChildren , mapUserAttr, mapInheritedAttr -- * Mapping events , mapEventF, mapPanelEvent, mapInheritedEvent -- * Event propagation- , propagate, EventToken(..), allEvents- , attachEventPropagation, propagateWxEvent+ , propagateFutureEvents, EventToken(..), allEvents+ , propagateFutureEventsEx, propagateWxEvent+ -- * Is Some Event+ , isEnterOrLeave, isMouseMotion, isMouseWheel -- * Other , ValuedWidget, widgetValue , updateUser, updateInherited@@ -25,22 +27,23 @@ import Graphics.UI.WX import Graphics.UI.WXCore hiding (Event)-import Graphics.UI.XTC+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.+ 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. - , pickUser :: user+ , 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 { inherit :: super }+newtype Inherit super = Inherit { unInherit :: super } -- Ugly name CompositeInherit - but could not figure out a better one. type CompositeInherit super = Composite (Inherit super)@@ -63,10 +66,15 @@ * 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: @@ -104,27 +112,31 @@ do p <- panel w [] (lay, user) <- f p set p [ layout := lay ]- let composite = Composite p user+ 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 = Composite w+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 ]+ 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 =+ 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@@ -136,11 +148,11 @@ -- |Used when an attribute should apply to the inherited "usertype" mapInheritedAttr :: Attr super attr -> Attr (CompositeInherit super) attr-mapInheritedAttr = mapAttrW (inherit . pickUser)+mapInheritedAttr = mapAttrW (unInherit . pickUser) -- *** Inherit from Widget w instance Widget (Composite user) where- widget (Composite w _) = widget w+ widget (Composite _ lay _) = lay instance Able (Composite user) where enabled = mapPanelAttr enabled@@ -178,14 +190,22 @@ 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+ 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@@ -195,8 +215,8 @@ instance Help super => Help (CompositeInherit super) where help = mapInheritedAttr help -instance Observable super => Observable (CompositeInherit super) where- change = mapInheritedEvent change+instance XTC.Observable super => XTC.Observable (CompositeInherit super) where+ change = mapInheritedEvent XTC.change instance Tipped super => Tipped (CompositeInherit super) where tooltip = mapInheritedAttr tooltip@@ -207,9 +227,9 @@ itemCount = mapInheritedAttr itemCount items = mapInheritedAttr items item x = mapInheritedAttr (item x)- itemDelete w x = itemDelete (inherit $ pickUser w) x- itemsDelete w = itemsDelete (inherit $ pickUser w)- itemAppend w x = itemAppend (inherit $ pickUser w) 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@@ -229,12 +249,12 @@ -- | 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 ]+ 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 (inherit . pickUser) event+mapInheritedEvent event = mapEventF (unInherit . pickUser) event -- | Mapping events using a mapper function mapEventF :: (to -> from) -> Event from event -> Event to event@@ -276,10 +296,10 @@ -- -- Thus we avoid pattern matching here. updateUser :: (user -> user') -> Composite user -> Composite user'-updateUser f (Composite panel' user) = Composite panel' (f user)+updateUser f (Composite panel' lay user) = Composite panel' lay (f user) updateInherited :: (super -> super') -> CompositeInherit super -> CompositeInherit super'-updateInherited f (Composite panel' super) = Composite panel' (Inherit $ f $ inherit super)+updateInherited f (Composite panel' lay super) = Composite panel' lay (Inherit $ f $ unInherit super) -- *** Event propagation@@ -299,35 +319,75 @@ -data EventToken = Mouse +data EventToken = Mouse | Keyboard | Focus allEvents :: [EventToken] allEvents = [ Mouse, Keyboard, Focus ] --- | Propagates events from one widget to another, based on a list of 'EventToken's.-propagate :: (Reactive from, Reactive to) => [EventToken] -> from -> to -> IO ()-propagate events from to = sequence_ $ map propHelper events- where propHelper Mouse = attachEventPropagation from to mouse mouse- propHelper Keyboard = attachEventPropagation from to keyboard keyboard- propHelper Focus = attachEventPropagation from to focus 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 all future events from one wxHaskell 'Window w' to--- another 'Window w'.++-- | 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 'from' and 'to'+-- Note that we need two Event inputs, otherwise the 'fromWidget' and 'toWidget' -- must be of the same type.-attachEventPropagation- :: from -- ^ The Window w to propagate from- -> to -- ^ The Window w to propagate from- -> Event from (t -> IO t1) -- ^ From event- -> Event to (t -> IO t1) -- ^ To Event+--+-- 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 ()-attachEventPropagation fromWindow toWindow fromEvent toEvent =- set fromWindow [ on fromEvent := \evt -> propagateWxEvent toWindow toEvent evt+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'.
src/Graphics/UI/WxGeneric/GenericClass.hs view
@@ -1,15 +1,16 @@ {-# LANGUAGE ExistentialQuantification, FlexibleContexts , FlexibleInstances, FunctionalDependencies, KindSignatures- , MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeSynonymInstances #-}+ , MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeSynonymInstances+ , ImpredicativeTypes #-} {-# OPTIONS -Wall #-} module Graphics.UI.WxGeneric.GenericClass ( -- * Turning datatypes into widgets- genericWidget, modalValuedDialog+ genericWidget, genericWidgetEx, modalValuedDialog -- * Outer type , Outer(..)- , toOuter, withLabel, fromOuter, getUnlabeld, setOuterLabel+ , toOuter, withLabel, fromOuter, getUnlabeld, setOuterLabel, replacePoorConstrLabel -- * Generic class (WxGen) and making instancs of WxGen , WxGen(..), WxGenD(..), wxGenCtx@@ -19,20 +20,34 @@ where import Graphics.UI.WX as Wx hiding (when)-import Graphics.UI.XTC+import qualified Graphics.UI.XTC as XTC -import Graphics.UI.SybWidget-import Graphics.UI.WxGeneric.GenericWidget-import Graphics.UI.WxGeneric.Composite+import qualified Graphics.UI.SybWidget as SW+import qualified Graphics.UI.WxGeneric.GenericWidget as GW+import Graphics.UI.WxGeneric.GenericWidget (GenWid, GenWidIO)+import qualified Graphics.UI.WxGeneric.Composite as C+import qualified Graphics.UI.WxGeneric.Layout as L import Control.Monad.Reader-import List (partition) import Maybe+import qualified Data.Either as Either -- |Creates a widget from any type that implements WxGen.-genericWidget :: (WxGen a) => Wx.Window w -> a -> IO (GenWid a)-genericWidget w x = fromOuter w $ mkWid x+genericWidget :: (WxGen a) => Wx.Window w -> a+ -> IO (GenWid a)+genericWidget = genericWidgetEx id id +-- |Creates a widget from any type that implements WxGen.+genericWidgetEx+ :: (WxGen a) =>+ (GW.GenWidParameters -> GW.GenWidParameters)+ -> (Outer a -> Outer a)+ -> Wx.Window w -> a+ -> IO (GenWid a)+genericWidgetEx parmsFunc outerFunc w x =+ do parms <- GW.toParms w $ GW.defaultParms parmsFunc+ fromOuter parms $ outerFunc $ mkWid x+ -- |Creates a modal dialog containing the 'x' value, an -- ok-buuton and a cancel-button. modalValuedDialog :: WxGen a =>@@ -49,14 +64,14 @@ do p <- panel d [] wid <- genericWidget p x ok <- button p [ text := okText- , on command := do val <- get wid widgetValue+ , on command := do val <- get wid C.widgetValue endModalForm (Just val) ] cancel <- button p [ text := "&Cancel" , on command := endModalForm Nothing ] set p [ layout := column 10 [ widget wid- , row 10 [ widget ok, widget cancel ]+ , hfloatCenter $ row 10 [ widget ok, widget cancel ] ] ] return () @@ -64,194 +79,233 @@ data WxGenD a = WxGenD { mkWidD :: a -> Outer a } -data Outer a = Outer PriLabel (Either (GenWidIO a) (String -> GenWidIO a))+data Outer a = Outer SW.PriLabel (Either (GenWidIO a) (String -> GenWidIO a)) -instance MapValue Outer where+instance GW.MapValue Outer where mapValue oldToNew newToOld (Outer lbl (Left genWidIO)) =- Outer lbl (Left (\w -> genWidIO w >>= return . mapValue oldToNew newToOld))+ Outer lbl (Left (\w -> genWidIO w >>= return . GW.mapValue oldToNew newToOld)) mapValue oldToNew newToOld (Outer lbl (Right genWidIO)) =- Outer lbl (Right (\s w -> genWidIO s w >>= return . mapValue oldToNew newToOld))+ Outer lbl (Right (\s w -> genWidIO s w >>= return . GW.mapValue oldToNew newToOld)) -- |Creates an 'Outer' type. The encapsulated widget is labelless.-toOuter :: forall a. (WxGen a) => (forall w. Window w -> IO (GenWid a)) -> Outer a+toOuter :: forall a. (WxGen a) => GenWidIO a -> Outer a toOuter f = let priLabel = generateLabel (error "WxGeneric call to generateLabel (1)" :: a) in Outer priLabel (Left f) -- |Creates an 'Outer' type. The encapsulated widget has a label.-withLabel :: forall a. (WxGen a) => (String -> forall w. Window w -> IO (GenWid a)) -> Outer a+withLabel :: forall a. (WxGen a) => (String -> GenWidIO a) -> Outer a withLabel f = let priLabel = generateLabel (error "WxGeneric call to generateLabel (2)" :: a) in Outer priLabel (Right f) -- |Unpacks an 'Outer' type and returns the encapsulated 'GenWid'.-fromOuter :: Window w -> Outer a -> IO (GenWid a)+fromOuter :: GW.Parms w -> Outer a -> IO (GenWid a) fromOuter w (Outer _ (Left f)) = f w-fromOuter w (Outer lbl (Right f)) = f (labelString $ humanizeLabel lbl) w+fromOuter w (Outer lbl (Right f)) = f (SW.labelString $ SW.humanizeLabel lbl) w -- |Returns label if the widget do not show it itself getUnlabeld :: Outer a -> Maybe String-getUnlabeld (Outer lbl (Left _)) = Just $ labelString $ humanizeLabel lbl+getUnlabeld (Outer lbl (Left _)) = Just $ SW.labelString $ SW.humanizeLabel lbl getUnlabeld (Outer _ (Right _)) = Nothing -- |Sets the label on an 'Outer' type.-setOuterLabel :: PriLabel -> Outer a -> Outer a-setOuterLabel newLbl = updateLabel (const newLbl)+setOuterLabel :: SW.PriLabel -> Outer a -> Outer a+setOuterLabel newLbl = SW.updateLabel (const newLbl) +replacePoorConstrLabel :: String -> Outer a -> Outer a+replacePoorConstrLabel = setOuterLabel . SW.goodConstrLabel+ -- |Instantiation of the Sat class-instance WxGen a => Sat (WxGenD a)+instance WxGen a => SW.Sat (WxGenD a) where dict = WxGenD { mkWidD = mkWid } -- |The context for generic autoform-wxGenCtx :: Proxy WxGenD+wxGenCtx :: SW.Proxy WxGenD wxGenCtx = error "wxGenCtx" -instance Labeled Constr where- toLabel = show--instance OuterWidget Outer where+instance SW.OuterWidget Outer where updateLabel f (Outer lbl wid) = Outer (f lbl) wid -class ( Data WxGenD a ) => WxGen a+class ( SW.Data WxGenD a ) => WxGen a where mkWid :: a -> Outer a mkWid x =- case constrRep (toConstr wxGenCtx x) of- AlgConstr _ -> if isSingleConstructor wxGenCtx x- then singleConstr x- else polyConstr x- IntConstr _ -> toOuter (\w -> anyNum ('-':['0'..'9']) x w)- FloatConstr _ -> toOuter (\w -> anyNum ('-':'.':['0'..'9']) x w)- StringConstr [_] -> error "WxFormImplementation: Char not implemented yet" -- FIXME- StringConstr _ -> error "WxFormImplementation: No StringConstr constructors for other than Char."- generateLabel :: a -> PriLabel- generateLabel x = typeLabel wxGenCtx x+ case SW.constrRep (SW.toConstr wxGenCtx x) of+ SW.AlgConstr _ -> genericOuter True x+ SW.IntConstr _ -> toOuter (\w -> anyNum ('-':['0'..'9']) x w)+ SW.FloatConstr _ -> toOuter (\w -> anyNum ('-':'.':['0'..'9']) x w)+ SW.StringConstr [_] -> error "GenericClass: Char not implemented yet" -- FIXME+ SW.StringConstr _ -> error "GenericClass: No StringConstr constructors for other than Char."+ generateLabel :: a -> SW.PriLabel+ generateLabel x = SW.typeLabel wxGenCtx x -data LabeledWid a = LabeledWid { lblWid :: (GenWid a), lblLabel :: Maybe String }+-- LabeledWid is only used in this module, as a temporary data structure.+-- data LabeledWid a = LabeledWid { lblWid :: (GenWid a), lblLabel :: Maybe String }+data LabeledWid a = LabeledWid (GenWid a) (Maybe (StaticText ())) L.SizedLayout +pickGenWid :: LabeledWid a -> GenWid a+pickGenWid (LabeledWid genWid _ _) = genWid+ -- |Creates an 'Outer' type for a type with a single constructor.-singleConstr :: WxGen a => a -> Outer a-singleConstr x = genericCompose $ mkSpliterSingleConstr wxGenCtx (mkWidD dict) x+singleConstr :: WxGen a => Bool -> a -> Outer a+singleConstr flatten x = genericCompose $ SW.mkSpliterSingleConstr wxGenCtx (mkWidD SW.dict) x where- genericCompose :: forall a. WxGen a => Spliter Outer a a+ genericCompose :: forall a. WxGen a => SW.Spliter Outer a a -> Outer a- genericCompose spliter = withLabel (\s -> valuedCompose $ f spliter s)- toGenWid p outer =- do wid' <- fromOuter p outer- return (LabeledWid wid' (getUnlabeld outer))- f spliter lbl p =- do changeVar <- varCreate (return ())- innerSpliter <- mapPartsMDelay (isNothing . getUnlabeld) (toGenWid p) spliter- let toLayoutAndLabel wid = (fill $ widget $ lblWid wid, lblLabel wid)- layoutList = spliterToList toLayoutAndLabel innerSpliter- (withLabelsAsString, withoutLabels) = partitionWidgets layoutList- withLabels <- mapM (\wid -> do txt <- staticText p [ text := fst wid ]- return (txt, snd wid))- withLabelsAsString- mapM_ (\wid -> propagate allEvents wid p) $ map fst withLabels- let innerSpliter' = mapParts lblWid innerSpliter- setChange y = do sequence_ $ spliterToList (\i -> set i [ on change := y ]) innerSpliter'+ genericCompose spliter+ = case (flatten, SW.mkFullSpliter wxGenCtx spliter) of+ (True, (SW.Part onlyPart (SW.Constructor c)))+ -> GW.mapValue c (const (SW.partGetter onlyPart)) (SW.partWidget onlyPart)+ _ -> withLabel (\s -> GW.valuedCompose $ f spliter s)+ toGenWid genWidParms outer =+ do let p = GW.getParent genWidParms+ createLabel lbl = do newLbl <- GW.transformLabel genWidParms lbl+ txt <- staticText p [ text := newLbl ]+ return $ Just txt+ -- A label must be created just prior to the widget it+ -- labels, otherwise keyboard accelerators will not work.+ lbl <- maybe (return Nothing) createLabel (getUnlabeld outer)+ wid' <- fromOuter (GW.subParms genWidParms) outer+ sLay <- L.toSizedLayout wid'+ return (LabeledWid wid' lbl sLay)+ f spliter lbl genWidParms =+ do let p = GW.getParent genWidParms+ changeVar <- varCreate (return ())+ innerSpliter <- SW.mapPartsMDelay (isNothing . getUnlabeld) (toGenWid genWidParms) spliter+ let (withLabels, withoutLabels) =+ partitionWidgets (\_ -> (,)) (curry snd) innerSpliter+ mapM_ (\wid -> C.propagateFutureEvents C.allEvents wid p) $ map fst withLabels+ let innerSpliter' = SW.mapParts pickGenWid innerSpliter+ setChange y = do sequence_ (SW.spliterToList (\i -> set i [ on XTC.change := y ])+ innerSpliter') varSet changeVar y- (g, s) = mkGetterSetter wxGenCtx (\w -> get w widgetValue) - (\w y -> set w [ widgetValue := y ]) innerSpliter'- lay = if (null withLabels && null withoutLabels)- then fill $ boxed "" $ label "no contents"- else boxed lbl $ column 10 $- (if null withLabels- then []- else [grid 20 10 $ map (\y -> [widget $ fst y, snd y]) withLabels]- )- ++ withoutLabels- return (lay, g, s, varGet changeVar, setChange)+ (g, s) = SW.mkGetterSetter wxGenCtx (\w -> get w C.widgetValue) + (\w y -> set w [ C.widgetValue := y ]) innerSpliter'+ lay = (GW.getJoinLayout genWidParms) lbl withLabels withoutLabels+ getWidTree =+ do let toWxWid w = get w GW.widgetTree+ (l, r) = partitionWidgets (\w _ _ -> toWxWid w) (\w _ -> toWxWid w) innerSpliter+ xs <- sequence (l ++ r)+ return $ GW.mkWidTree [] xs+ return (lay, g, s, varGet changeVar, setChange, getWidTree) -partitionWidgets :: [(Layout, Maybe String)] -> ([(String, Layout)], [Layout])-partitionWidgets layoutsAndLabels =- let sortedWidgets = partition (isJust . snd) layoutsAndLabels- withLabels = map (\(lay, name) -> (lay, fromJust name)) (fst sortedWidgets)- withoutLabels = map fst (snd sortedWidgets)- in (map (\(lay,name) -> (name, lay)) withLabels, withoutLabels)+genericOuter :: (WxGen a) => Bool -> a -> Outer a+genericOuter flatten x+ = if SW.isSingleConstructor wxGenCtx x+ then singleConstr flatten x+ else polyConstr x ++partitionWidgets :: (forall a. GenWid a -> StaticText () -> L.SizedLayout -> l)+ -> (forall a. GenWid a -> L.SizedLayout -> r)+ -> SW.Spliter LabeledWid b c+ -> ([l], [r])+partitionWidgets withLabelFunc withoutLabelFunc s =+ Either.partitionEithers $ SW.spliterToList helper s where+ helper (LabeledWid wid (Just lbl) sLay) = Left $ withLabelFunc wid lbl sLay+ helper (LabeledWid wid Nothing sLay) = Right $ withoutLabelFunc wid sLay+ -- |Creates an 'Outer' type for a type with more than one constructor.-polyConstr :: forall a. (WxGen a, Data WxGenD a) =>+polyConstr :: forall a. (WxGen a, SW.Data WxGenD a) => a -> Outer a-polyConstr x = withLabel (\s -> valuedCompose (f s)) where- f lbl p =- do getValueProxy <- varCreate (return x)+polyConstr x = withLabel (\s -> GW.valuedCompose (f s)) where+ f lbl genWidParms =+ do let p = GW.getParent genWidParms+ getValueProxy <- varCreate (return x) changeVar <- varCreate (return ()) setChangeProxy <- varCreate (\_ -> return ())- valueMemory <- mkConstrValMap wxGenCtx x+ subGenWid <- varCreate (error "Panic! Should not happen. Sub-GenWid not created yet.")+ valueMemory <- SW.mkConstrValMap wxGenCtx x let getter = join $ varGet getValueProxy setChange y = do chg <- varGet setChangeProxy chg y varSet changeVar y- radioV <- mkRadioView p Vertical (constructors wxGenCtx x)- [ typedSelection := toConstr wxGenCtx x+ --+ -- Radio-view items do not short keyboard shortcuts. Thus no need to+ -- do GW.transformLabel.+ radioV <- XTC.mkRadioViewEx p show Vertical (SW.constructors wxGenCtx x)+ [ XTC.typedSelection := SW.toConstr wxGenCtx x , text := "Choose constructor" ]- propagate allEvents radioV p+ C.propagateFutureEvents C.allEvents radioV p+ --+ editLbl <- GW.transformLabel genWidParms "Edit in Dialog"+ editButton <- button p [ text := editLbl ]+ -- widPanel <- panel p []- propagate allEvents widPanel p+ C.propagateFutureEvents C.allEvents widPanel p let deleteOldWidgets = get widPanel children >>= mapM_ objectDelete- makeChild y = do t <- genericWidget' widPanel y- varSet setChangeProxy (\z -> set t [ on change := z] )- set t [ on change := join $ varGet changeVar ]- set widPanel [ layout := dynamic $ fill $ widget t ]- varSet getValueProxy (get t widgetValue)+ makeChild y = do -- We do not use GW.subParms here, as we want the internal child widget+ -- constructed as if it was a single constructor widget. That is,+ -- we keep two-column layout if present.+ t <- genericWidget' (GW.setParent widPanel genWidParms) y+ varSet subGenWid t+ varSet setChangeProxy (\z -> set t [ on XTC.change := z] )+ set t [ on XTC.change := join $ varGet changeVar ]+ set widPanel [ layout := widget t ]+ varSet getValueProxy (get t C.widgetValue) refit widPanel- genericWidget' w y = fromOuter w $ setOuterLabel labelless $ singleConstr y- setter y = do getter >>= updateConstrValMap valueMemory+ genericWidget' w y = fromOuter w $ setOuterLabel SW.labelless $ singleConstr False y+ setter y = do getter >>= SW.updateConstrValMap valueMemory deleteOldWidgets makeChild y join $ varGet changeVar- set radioV [ typedSelection := toConstr wxGenCtx y ]+ set radioV [ XTC.typedSelection := SW.toConstr wxGenCtx y ]+ getWidTree = + do genWid <- varGet subGenWid+ fmap (GW.updateChildren (GW.WxWindow radioV:)) $ get genWid GW.widgetTree makeChild x- set radioV [ on select := do newCon <- get radioV typedSelection+ set radioV [ on select := do newCon <- get radioV XTC.typedSelection lastVal <- getter- when (newCon /= toConstr wxGenCtx lastVal)- (alwaysValue valueMemory newCon >>= setter)+ when (newCon /= SW.toConstr wxGenCtx lastVal)+ (SW.alwaysValue valueMemory newCon >>= setter) ]- let lay = boxed lbl $ dynamic $ column 10 [ hfill $ widget radioV- , dynamic $ fill $ widget widPanel- ]- return (lay, getter, setter, varGet changeVar, setChange)+ set editButton [ on command := + do lastVal <- getter+ res <- modalValuedDialog p "Edit value" "OK" lastVal+ case res of+ Just z -> setter z+ _ -> return ()+ ]+ let lay = boxed lbl $ column 10 [ row 10 [ hfill $ widget radioV, vfloatCenter $ widget editButton ]+ , fill $ widget widPanel+ ]+ return (lay, getter, setter, varGet changeVar, setChange, getWidTree) -- ********** AnyNum **************************************** -anyNum :: (Data WxGenD a) => String -> a -> GenWidIO a-anyNum legalChars initial p =- do (sybGet, sybSet) <- numericGetSet wxGenCtx initial+anyNum :: (SW.Data WxGenD a) => String -> a -> GenWidIO a+anyNum legalChars initial genWidParms =+ do let p = GW.getParent genWidParms+ (sybGet, sybSet) <- SW.numericGetSet wxGenCtx initial intEn <- textEntry p [ processEnter := True- , on anyKey := handleInput+ , on keyboard := handleInput p ] let getter = get intEn text >>= sybGet setter x = do stringX <- sybSet x set intEn [ text := stringX ] setter initial- propagate [Mouse, Focus] intEn p- return $ mkSingleObservable intEn getter setter+ C.propagateFutureEvents [C.Mouse, C.Focus] intEn p+ return $ GW.mkSingleObservableEx intEn hfill getter setter (GW.singleChild intEn) where- -- We currently do not propagate unused keyevents, as they make other chars- -- than the ones specified in legalChars, appear in the text-entry. I _think_- -- it because event handles call propagateEvent.- --- -- We could propagate non-KeyChar events though. FIXME: Should we?- --- -- handleInput (evt@(EventKey (KeyChar c) _ _)) =- handleInput (KeyChar c) =- do if c `elem` legalChars- then propagateEvent- else return ()- -- propagateWxEvent p keyboard evt >> return ()- handleInput _ = return ()+ handleInput _ (EventKey (KeyChar c) mods _)+ | not (altDown mods || controlDown mods || metaDown mods)+ = if c `elem` legalChars+ then propagateEvent+ else return ()+ handleInput p evt = C.propagateWxEvent p keyboard evt -- propagateEvent+ -- Why do we need C.propagateWxEvent?+ -- GenericList's String should also propagate ALT (and like) events. -- *********** extOuter ************************************* -- |Makes it possible to choose between competing instances without -- allowing overlapping instances.-extOuter :: (Typeable a, Typeable b) =>+extOuter :: (SW.Typeable a, SW.Typeable b) => (a -> Outer a) -> (b -> Outer b) -> a -> Outer a-extOuter fn spec_fn arg = case gcast (M spec_fn) of+extOuter fn spec_fn arg = case SW.gcast (M spec_fn) of Just (M spec_fn') -> spec_fn' arg Nothing -> fn arg newtype M a = M (a -> Outer a)@@ -263,6 +317,7 @@ instance WxGen Integer instance WxGen Float instance WxGen Double+instance WxGen () instance (WxGen a, WxGen b) => WxGen (a, b) instance (WxGen a, WxGen b, WxGen c) => WxGen (a, b, c)
src/Graphics/UI/WxGeneric/GenericList.hs view
@@ -1,68 +1,128 @@+{-# OPTIONS -fno-warn-orphans #-}++{-++No warning about orhpans?++About orhpan instances see:++* http://lukepalmer.wordpress.com/2009/01/25/a-world-without-orphans/+(read comments too) - this links gives the easiest to understand+introduction to orhpan instances.+* http://www.haskell.org/ghc/docs/latest/html/users_guide/separate-compilation.html#orphan-modules++We could remove this warning by moving the WxGen [a] instance to+GenericClass. But GenericClass is already big enough.++We cannot just move:++instance (GC.WxGen a, Show a) => GC.WxGen [a] where+ mkWid xs = (mkDefaultListOuter `GC.extOuter` mkStringOuter) xs++to GenericClass, as mkDefaultListOuter depends upon WxGen. Thus we+will have circular dependencies: GenericClass -> GenericList+GenericClass. I would prefer orhpan instances to circular dependencies+any day.++However, it is important that GenericList is always (indirectly)+imported when people use the WxGen class. Otherwise people will not+see the WxGen [a] implementation. And worse they might create their+own implementation of WxGen [a], which will waste work and lead to+bigger issues in the long run (see Luke's blogpost above). But+GenericList do not have to be in any export list, as instances are+exported without being in export list.++The sure way to force the importation of WxGen [a] is to:++* Graphics.UI.WxGeneric.GenericClass is not a public module+* Graphics.UI.WxGeneric exports everything from GenericClass+* Graphics.UI.WxGeneric imports GenericList++-}+ -- |Exports an instance for 'WxGen' [a]. It handles [Char] instances specially. module Graphics.UI.WxGeneric.GenericList- ( - )+ ( ) where -import Graphics.UI.SybWidget.MySYB(gToString)-import Graphics.UI.SybWidget.InstanceCreator+import Graphics.UI.SybWidget(gToString)+import qualified Graphics.UI.SybWidget.InstanceCreator as InstanceCreator -import Graphics.UI.WxGeneric.GenericClass-import Graphics.UI.WxGeneric.GenericWidget-import Graphics.UI.WxGeneric.Composite+import qualified Graphics.UI.WxGeneric.GenericClass as GC+import qualified Graphics.UI.WxGeneric.GenericWidget as GW+import qualified Graphics.UI.WxGeneric.Composite as C import Graphics.UI.WX as Wx-import Graphics.UI.XTC+import qualified Graphics.UI.XTC as XTC import Data.Maybe import Control.Monad import Data.List(partition) -instance (WxGen a, Show a) => WxGen [a] where- mkWid xs = (mkListOuter `extOuter` mkStringOuter) xs+instance (GC.WxGen a, Show a) => GC.WxGen [a] where+ mkWid xs = (mkDefaultListOuter `GC.extOuter` mkStringOuter) xs -mkStringOuter :: String -> Outer String-mkStringOuter x = toOuter helper where- helper p = do te <- textEntry p [ text := x ]- propagate [Mouse, Focus] te p- return $ mkSingleObservable te (get te text) (\val -> set te [ text := val ])+mkStringOuter :: String -> GC.Outer String+mkStringOuter x = GC.replacePoorConstrLabel "String" $ GC.toOuter helper where+ helper genWidParms = + do let p = GW.getParent genWidParms+ te <- textEntry p [ text := x ]+ C.propagateFutureEvents [C.Mouse, C.Focus] te p+ let getter = get te text+ setter val = set te [ text := val ]+ return $ GW.mkSingleObservableEx te hfill getter setter + (GW.singleChild te) -mkListOuter :: (WxGen a, Show a) => [a] -> Outer [a]-mkListOuter xs = toOuter (valuedCompose helper) where- helper p =- do let shortenLongLines ys = if length ys > maxListWidth++-- A function to show lists in a GUI.+mkDefaultListOuter :: (GC.WxGen a, Show a) => [a] -> GC.Outer [a]+mkDefaultListOuter xs = GC.toOuter (GW.valuedCompose helper) where+ helper genWidParms =+ do let p = GW.getParent genWidParms+ shortenLongLines ys = if length ys > maxListWidth then take (maxListWidth - 4) ys ++ " ..." else ys maxListWidth = 20 changeVar <- varCreate (return ())- ls <- mkMultiListViewEx p (shortenLongLines . gToString) [ typedItems := xs ]- up <- button p [ text := "&Up" ]- down <- button p [ text := "&Down" ]- remove <- button p [ text := "&Remove" ]- edit <- button p [ text := "&Edit" ]- add <- button p [ text := "&Add" ]- mapM_ (\w -> propagate allEvents w p) [up, down, remove, edit, add]- propagate allEvents ls p- let lay = column 10 [ fill $ widget ls- , row 5 $ map widget [up, down, remove, edit, add]+ ls <- XTC.mkMultiListViewEx p (shortenLongLines . gToString) [ XTC.typedItems := xs ]+ let mkButton lbl = do newLbl <- GW.transformLabel genWidParms lbl+ button p [ text := newLbl ]+ up <- mkButton "Up"+ down <- mkButton "Down"+ remove <- mkButton "Remove"+ edit <- mkButton "Edit"+ add <- mkButton "Add"+ let allButtons = [up, down, remove, edit, add]+ mapM_ (\w -> C.propagateFutureEvents [C.Keyboard, C.Focus] w p) allButtons+ -- We do not propagate any mouse events, as they should be used by the buttons+ let mouseEvts x = C.isMouseMotion x || C.isMouseWheel x+ attachMouse w = C.propagateFutureEventsEx mouseEvts w p mouse mouse+ mapM_ attachMouse allButtons+ ++ C.propagateFutureEvents C.allEvents ls p+ let -- The minimum size for list is somewhat arbitrary. Maybe it should be+ -- a tuning parameter?+ lay = column 10 [ minsize (sz 100 80) $ fill $ widget ls+ , hfloatCenter $ row 5 $ map widget allButtons ] whenOne [y] f = f y whenOne _ _ = False updateEnabledness = do selected <- get ls selections- ys <- get ls typedItems+ ys <- get ls XTC.typedItems set up [ enabled := whenOne selected (> 0) ] set down [ enabled := whenOne selected (< (length ys - 1)) ] set remove [ enabled := (length selected > 0) ] set edit [ enabled := (length selected == 1) ] setCmd wid f = set wid [ on command := do selected <- get ls selections- items' <- get ls typedItems+ items' <- get ls XTC.typedItems res <- f selected items' case res of Nothing -> return () Just (newItems, newSel) ->- do set ls [ typedItems := newItems+ do set ls [ XTC.typedItems := newItems , selections := newSel ] updateEnabledness@@ -82,18 +142,18 @@ setCmd remove removeCmd let addCmd Nothing = errorDialog p "Internal error" "Could not create base instance"- addCmd (Just x) = do y <- modalValuedDialog p "Adding element" "&Add" x+ addCmd (Just x) = do y <- GC.modalValuedDialog p "Adding element" "&Add" x case y of Nothing -> return ()- Just y' -> do set ls [ typedItems :~ (++ [y'])+ Just y' -> do set ls [ XTC.typedItems :~ (++ [y']) , selections := [] ] updateEnabledness join (varGet changeVar)- set add [ on command := addCmd (createInstance' wxGenCtx (head xs)) ]+ set add [ on command := addCmd (InstanceCreator.createInstance' GC.wxGenCtx (head xs)) ] let editCmd [s] items' =- do x <- modalValuedDialog p "Editng element" "&Ok" (items' !! s)+ do x <- GC.modalValuedDialog p "Editng element" "&Ok" (items' !! s) case x of Nothing -> return Nothing Just x' -> return $ Just (replace x' s items', [s])@@ -102,8 +162,8 @@ set ls [ on select := updateEnabledness >> propagateEvent ] updateEnabledness- return ( lay, get ls typedItems, \ys -> set ls [typedItems := ys]- , varGet changeVar, varSet changeVar)+ return ( lay, get ls XTC.typedItems, \ys -> set ls [XTC.typedItems := ys]+ , varGet changeVar, varSet changeVar, GW.singleChild ls) -- |Splits a list in two parts, according to the indices -- parameter. The first is the indices, the second are the rest of
src/Graphics/UI/WxGeneric/GenericWidget.hs view
@@ -10,80 +10,94 @@ GenWid contains a valued version of 'Composite'. -} module Graphics.UI.WxGeneric.GenericWidget- ( fromWidget, valuedCompose- , mkGenWid, mkSingleObservable, GenWid, GenWidIO+ ( valuedCompose+ , mkGenWid, mkSingleObservable, mkSingleObservableEx, GenWid, GenWidIO , MapValue(..)+ , module Graphics.UI.WxGeneric.GenericWidget.Parameters+ , module Graphics.UI.WxGeneric.GenericWidget.WidgetTree ) where -import Graphics.UI.WX as Wx-import Graphics.UI.XTC-import Graphics.UI.WxGeneric.Composite--type GenWidIO a = forall w. Window w -> IO (GenWid a)---- |Makes a GenWid from a an ordinary WxHaskell 'Window w' (widget)--- that implements Observable and ValuedWidget.-fromWidget :: forall w a. (Observable (Window w), ValuedWidget a (Window w)) =>- (forall w'. Window w' -> IO (Window w))- -> GenWidIO a-fromWidget wid = fromWidget' widgetValue change wid+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 --- |Similar to fromWidget, except you explicitly gives the widgetValue--- (ValuedWidget) attribute and change (Observable) event.-fromWidget' :: forall w a.- Attr (Window w) a- -> Event (Window w) (IO ())- -> (forall w'. Window w' -> IO (Window w))- -> GenWidIO a-fromWidget' valueAttr observable toWindowW w- = do windowW <- toWindowW w- return $ mkGenWid windowW (get windowW valueAttr) (\x -> set windowW [ valueAttr := x ])- (get windowW (on observable)) (\x -> set windowW [ on observable := x ])+type GenWidIO a = forall w. Parms w -> IO (GenWid a) -- |Composing multiple widgets into a composite GenWid. It is similar--- to 'Composite.compose'.-valuedCompose :: (Panel () -> IO (Layout, IO a, a -> IO(), IO (IO ()), IO() -> IO()))+-- to 'C.compose'.+valuedCompose :: (Parms (WXCore.CPanel ())+ -> IO (Layout, IO a, a -> IO(), IO (IO ()), IO() -> IO(), IO WidTree)+ ) -> GenWidIO a-valuedCompose f w =- do p <- panel w []- propagate allEvents p w- (lay, getter, setter, getChange, setChange) <- f p- set p [ layout := fill lay ]- return $ mkGenWid p getter setter getChange setChange+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 +-- *** ValuedCmds+ data ValuedCmds a = ValuedCmds- { pickGetValue :: IO a- , pickSetValue :: a -> IO ()- , pickGetChange :: IO (IO ())- , pickSetChange :: IO() -> IO()+ { pickGetValue :: IO a+ , pickSetValue :: a -> IO ()+ , pickGetChange :: IO (IO ())+ , pickSetChange :: IO() -> IO()+ , pickGetWidTree :: IO WidTree }-instance Observable (ValuedCmds a) where+instance XTC.Observable (ValuedCmds a) where change = newEvent "change" pickGetChange pickSetChange -instance ValuedWidget a (ValuedCmds a) where+instance C.ValuedWidget a (ValuedCmds a) where widgetValue = newAttr "valued" pickGetValue pickSetValue -newtype GenWid a = GenWid (CompositeInherit (ValuedCmds a))- deriving ( Widget, Able, Bordered, Child, Dimensions, Identity, Literate, Visible, Reactive- , Observable, ValuedWidget a+-- *** GenWid++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 ) -- |Creates a GenWid using monadic actions. mkGenWid :: forall w a.- Window w -> IO a -> (a -> IO ()) -> IO (IO ()) -> (IO() -> IO())+ Window w -> IO a -> (a -> IO ()) -> IO (IO ()) -> (IO() -> IO()) -> (IO WidTree) -> GenWid a-mkGenWid w getVal setVal getChg setChg = - GenWid $ singleComposite w (Inherit (ValuedCmds getVal setVal getChg setChg))+mkGenWid w getVal setVal getChg setChg getWidTree = + GenWid $ C.singleComposite w (C.Inherit (ValuedCmds getVal setVal getChg setChg getWidTree)) +-- |Creates a GenWid using monadic actions.+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))+ -- |Creates a GenWid using an Observable widget, a get-value action -- and a set-value action.-mkSingleObservable :: forall w a. (Observable (Window w)) =>- Window w -> IO a -> (a -> IO ())+mkSingleObservable :: forall w a. (XTC.Observable (Window w)) =>+ Window w -> IO a -> (a -> IO ()) -> IO WidTree -> GenWid a-mkSingleObservable wid getter setter =- mkGenWid wid getter setter (get wid (on change)) (\x -> set wid [on change := x])+{-# DEPRECATED mkSingleObservable "Use mkSingleObservableEx in stead" #-}+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] +-- |Creates a GenWid using an Observable widget, a get-value action+-- and a set-value action.+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]+ -- *** MapValue class class MapValue (valued :: * -> *) where@@ -101,4 +115,37 @@ , pickSetValue = \x -> do old <- pickGetValue valuedCmds pickSetValue valuedCmds (newToOld old x) }- in GenWid $ updateInherited updateCmds composite+ in GenWid $ C.updateInherited updateCmds composite++-- *** WidTree++instance WidgetTree (GenWid a) where+ widgetTree = readAttr "widgetTree"+ (pickGetWidTree . C.unInherit . C.pickUser . unGenWid)+++++{- Wonder if anybody is missing these two functions?++-- |Makes a GenWid from a an ordinary WxHaskell 'Window w' (widget)+-- that implements Observable and ValuedWidget.+fromWidget :: forall w a. (Observable (Window w), ValuedWidget a (Window w)) =>+ (forall w'. Window w' -> IO (Window w))+ -> GenWidIO a+fromWidget wid = fromWidget' widgetValue change wid++-- |Similar to fromWidget, except you explicitly gives the widgetValue+-- (ValuedWidget) attribute and change (Observable) event.+fromWidget' :: forall w a.+ Attr (Window w) a+ -> Event (Window w) (IO ())+ -> (forall w'. Window w' -> IO (Window w))+ -> IO WidTree+ -> GenWidIO a+fromWidget' valueAttr observable toWindowW getWidTree w+ = do windowW <- toWindowW w+ return $ mkGenWid windowW (get windowW valueAttr) (\x -> set windowW [ valueAttr := x ])+ (get windowW (on observable)) (\x -> set windowW [ on observable := x ])+ getWidTree+-}
+ src/Graphics/UI/WxGeneric/GenericWidget/Parameters.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE ExistentialQuantification, FlexibleContexts, ImpredicativeTypes, RankNTypes #-}+{-# OPTIONS -Wall #-}++{- | Parameters to functions creating 'GenWid'-s. ++If a 'GenWid' has sub-'GenWid' the parameters will be passed on to those.++-}+module Graphics.UI.WxGeneric.GenericWidget.Parameters+ ( Parms+ , subParms+ , getParent, setParent+ , getJoinLayout, transformLabel+ -- * Initial parameters+ , GenWidParameters(..), defaultParms, toParms+ -- * Labels+ , TransformLabel, mkTransformLabel, idLabel, greedyShortcuts+ )+where++import Graphics.UI.WX+import qualified Graphics.UI.WxGeneric.Layout as L+import qualified Data.Set as Set+import qualified Data.Char as Char+import Control.Monad.State as St++data GenWidParameters = GenWidParameters+ { joinLayout :: L.JoinLayout+ , labelTransform :: TransformLabel+ }++defaultParms :: (GenWidParameters -> GenWidParameters) -> GenWidParameters+defaultParms f = f (GenWidParameters L.smartLayout (greedyShortcuts []))++-- | Initial parameters. Should only be called at the top-level. If+-- already in a 'GenWid' function then use 'subParms'.+toParms :: Window w -> GenWidParameters -> IO (Parms w)+toParms w parms = do lblTrans <- varCreate (labelTransform parms)+ return $ Parms w True (joinLayout parms) L.oneColumnLayout lblTrans++data Parms w = Parms+ { pickParent :: Window w+ , pickIsTop :: Bool+ , pickTopLayout :: L.JoinLayout+ , pickLayout :: L.JoinLayout+ , pickLabelTransform :: Var TransformLabel+ }++-- | When a 'GenWid' has sub-'GenWid' use this function to update+-- 'GenWidParms'.+-- +-- Currently, only GenericClass.singleConstr uses this function. But,+-- in principle, it should be called by functions using sub-widget.+subParms :: Parms w -> Parms w+subParms parms+ = parms { pickIsTop = False }++setParent :: Window w -> Parms w' -> Parms w+setParent w parms+ = parms { pickParent = w }++-- | Use this parent when constructing new widgets.+getParent :: Parms w -> Window w+getParent = pickParent++getJoinLayout :: Parms w -> L.JoinLayout+getJoinLayout p =+ case pickIsTop p of+ True -> pickTopLayout p+ False -> pickLayout p++-- *** Label handling++transformLabel :: Parms w -> String -> IO String+transformLabel parms lbl+ = do lblTrans <- varGet $ pickLabelTransform parms+ case lblTrans of+ TL s f -> do let (newLbl, newSt) = runState (f lbl) s+ varSet (pickLabelTransform parms) $ TL newSt f+ return newLbl++data TransformLabel = forall s. TL s (String -> State s String)++mkTransformLabel :: s -> (String -> State s String) -> TransformLabel+mkTransformLabel = TL++idLabel :: TransformLabel+idLabel = mkTransformLabel () return++greedyShortcuts :: [Char] -> TransformLabel+greedyShortcuts usedShortcutLetters = mkTL+ where + mkTL = mkTransformLabel (Set.fromList usedShortcutLetters) (State . newLbl)+ newLbl lbl used + = case span (\x -> Set.member (Char.toLower x) used || (not $ Char.isAlpha x)) lbl of+ (_, []) -> (lbl, used) -- no available shortcut letter+ (alreadyUsed, (x:xs)) -> (alreadyUsed ++ ('&':x:xs), Set.insert (Char.toLower x) used)+ +
+ src/Graphics/UI/WxGeneric/GenericWidget/WidgetTree.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# OPTIONS -Wall #-}++{- | Functions to get the tree of wxHaskell widgets, from a 'GenWid'.+-}+module Graphics.UI.WxGeneric.GenericWidget.WidgetTree+ ( WidTree, WxWindow(..)+ , WidgetTree(..)+ -- * WidTree constructors+ , mkWidTree, singleChild, leafWidTree+ -- * Update/get ops+ , getChildren, updateChildren, getSubTrees, updateSubTrees+ -- * Traversal+ , depthFirstTraversal+ )+where++import Graphics.UI.WX++type Update a = a -> a+data WidTree = WidTree [WxWindow] [WidTree]+data WxWindow = forall w. WxWindow (Window w)++getChildren :: WidTree -> [WxWindow]+getChildren (WidTree x _) = x++updateChildren :: Update [WxWindow] -> Update WidTree+updateChildren f (WidTree x y) = (WidTree (f x) y) ++getSubTrees :: WidTree -> [WidTree]+getSubTrees (WidTree _ x) = x++updateSubTrees :: Update [WidTree] -> Update WidTree+updateSubTrees f (WidTree x y) = WidTree x (f y)++-- | Construct 'WidTree'+mkWidTree :: [WxWindow] -> [WidTree] -> WidTree+mkWidTree = WidTree++-- |Construct 'WidTree' leaf node.+leafWidTree :: [WxWindow] -> IO WidTree+leafWidTree cs = return $ WidTree cs []++-- |Construct 'WidTree' from a single WxHaskell widget.+singleChild :: Window w -> IO WidTree+singleChild w = leafWidTree [WxWindow w]++-- |Depth first traversal of 'WidTree'+-- FIXME: Is not really, or atleast do not seem like a depth first traversal to the+-- the user of WxGeneric.+depthFirstTraversal :: WidTree -> [Window ()]+depthFirstTraversal (WidTree wids cs)+ = concatMap depthFirstTraversal cs ++ map toWindowOOClass wids++-- |Converts to 'Window ()' - that is high up in the wxWidgets OO (Object Oriented)+-- type hierarchy.+toWindowOOClass :: WxWindow -> Window ()+toWindowOOClass (WxWindow c) = objectCast c++class WidgetTree w where+ -- | Get all wxHaskell widgets (Window w) which are inputable.+ -- That is, we get widgets like text-entries and slides, but not widgets like labels.+ widgetTree :: ReadAttr w WidTree+
+ src/Graphics/UI/WxGeneric/Layout.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE FlexibleContexts, RankNTypes #-}+{-# OPTIONS -Wall #-}++{- | Handles joining of many 'Graphics.UI.WX.Layout' into one+ 'Graphics.UI.WX.Layout'.+-}+module Graphics.UI.WxGeneric.Layout+ ( smartLayout, oneColumnLayout, twoColumnLayout+ , JoinLayout, SizedLayout+ , toSizedLayout+ )+where++import Graphics.UI.WX+import Data.List++smartMaxHorizontalSize :: Int+smartMaxHorizontalSize = 400++-- |Used for debug. See 'toHeader'.+showWidgetSizeInHeadings :: Bool+showWidgetSizeInHeadings = False++type JoinLayout = String -> FromWxGenLayout Layout+type SizedLayout = (Int, Layout)+type FromWxGenLayout a = [(StaticText (), SizedLayout)] -> [SizedLayout] -> a+type WxGenLayout = ([(StaticText (), SizedLayout)], [SizedLayout])++estimateSize :: Dimensions w => w -> IO Int+estimateSize w = get w bestSize >>= return . sizeH++toSizedLayout :: (Widget w, Dimensions w) => w -> IO SizedLayout+toSizedLayout wid = do s <- estimateSize wid+ return (s, widget wid)+ +smartLayout :: JoinLayout+smartLayout topHeading withLabels withoutLabels+ | sum (sizes withLabels withoutLabels) > smartMaxHorizontalSize+ = twoColumnLayout topHeading withLabels withoutLabels+ | otherwise+ = oneColumnLayout topHeading withLabels withoutLabels++-- |Normally, just copies the header. But for debug purposes 'showWidgetSizeInHeadings'+-- can be set to True.+toHeader :: String -> FromWxGenLayout String+toHeader header withLabels withoutLabels =+ case showWidgetSizeInHeadings of+ False -> header+ True -> header ++ ", sizes=" ++ (show $ sizes withLabels withoutLabels)++sizes :: FromWxGenLayout [Int]+sizes withLabels withoutLabels+ = map fst (map snd withLabels ++ withoutLabels)++oneColumnLayout :: JoinLayout+oneColumnLayout topHeading withLabels withoutLabels =+ if (null withLabels && null withoutLabels)+ then fill $ boxed "" $ label "no contents"+ else let h = toHeader topHeading withLabels withoutLabels+ in boxed h $ layoutColumn withLabels withoutLabels++-- |Makes a layout in two columns. If there is less than two Layout's+-- to join, it will diverge to 'oneColumnLayout'.+twoColumnLayout :: JoinLayout+twoColumnLayout topHeading withLabels withoutLabels+ = case splitMiddle withLabels withoutLabels of+ (_, ([], [])) -> divergeOneColumn+ (([], []), _) -> divergeOneColumn+ (leftLay, rightLay)+ -> let columnLayout lay = column 1 [ uncurry layoutColumn lay, glue ]+ h = toHeader topHeading withLabels withoutLabels+ in boxed h $ row 10 [ columnLayout leftLay+ , columnLayout rightLay ]+ where divergeOneColumn = oneColumnLayout topHeading withLabels withoutLabels++splitMiddle :: FromWxGenLayout (WxGenLayout, WxGenLayout)+splitMiddle labeled unlabeled =+ let xs = sizes labeled unlabeled+ middlePixel = sum xs `div` 2+ middle = length $ takeWhile (< middlePixel) $ map sum $ tail $ inits xs+ splitLabeled = splitAt middle labeled+ splitUnlabeled = splitAt (middle - length labeled) unlabeled+ in ((fst splitLabeled, fst splitUnlabeled)+ ,(snd splitLabeled, snd splitUnlabeled))++layoutColumn :: FromWxGenLayout Layout+layoutColumn withLabels withoutLabels+ = column 10 $+ (if null withLabels+ then []+ else [grid 20 10 $ map toLayout withLabels ]+ ) ++ map snd withoutLabels+ where+ toLayout (lbl, (s, w)) =+ case showWidgetSizeInHeadings of+ True -> [alignLeft $ widget lbl, label $ show s, w]+ False -> [alignLeft $ widget lbl, w]+++