diff --git a/WxGeneric.cabal b/WxGeneric.cabal --- a/WxGeneric.cabal +++ b/WxGeneric.cabal @@ -1,27 +1,37 @@ Name: WxGeneric -Version: 0.5.2 +Version: 0.6.0 Copyright: Mads Lindstrøm -license: LGPL +License: LGPL License-file: wxWidgetsLicense.txt Author: Mads Lindstrøm Maintainer: Mads Lindstrøm +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 diff --git a/examples/AlarmSpecialized.hs b/examples/AlarmSpecialized.hs --- a/examples/AlarmSpecialized.hs +++ b/examples/AlarmSpecialized.hs @@ -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 ] diff --git a/examples/EventPropagation/AllEventsComposite.hs b/examples/EventPropagation/AllEventsComposite.hs --- a/examples/EventPropagation/AllEventsComposite.hs +++ b/examples/EventPropagation/AllEventsComposite.hs @@ -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) = diff --git a/examples/EventPropagation/makefile b/examples/EventPropagation/makefile --- a/examples/EventPropagation/makefile +++ b/examples/EventPropagation/makefile @@ -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) diff --git a/examples/Examples.hs b/examples/Examples.hs --- a/examples/Examples.hs +++ b/examples/Examples.hs @@ -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 ] diff --git a/examples/TupleExample.hs b/examples/TupleExample.hs --- a/examples/TupleExample.hs +++ b/examples/TupleExample.hs @@ -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 ] ] diff --git a/examples/makefile b/examples/makefile --- a/examples/makefile +++ b/examples/makefile @@ -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") diff --git a/src/Graphics/UI/WxGeneric.hs b/src/Graphics/UI/WxGeneric.hs --- a/src/Graphics/UI/WxGeneric.hs +++ b/src/Graphics/UI/WxGeneric.hs @@ -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() diff --git a/src/Graphics/UI/WxGeneric/Composite.hs b/src/Graphics/UI/WxGeneric/Composite.hs --- a/src/Graphics/UI/WxGeneric/Composite.hs +++ b/src/Graphics/UI/WxGeneric/Composite.hs @@ -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'. diff --git a/src/Graphics/UI/WxGeneric/GenericClass.hs b/src/Graphics/UI/WxGeneric/GenericClass.hs --- a/src/Graphics/UI/WxGeneric/GenericClass.hs +++ b/src/Graphics/UI/WxGeneric/GenericClass.hs @@ -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) diff --git a/src/Graphics/UI/WxGeneric/GenericList.hs b/src/Graphics/UI/WxGeneric/GenericList.hs --- a/src/Graphics/UI/WxGeneric/GenericList.hs +++ b/src/Graphics/UI/WxGeneric/GenericList.hs @@ -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 diff --git a/src/Graphics/UI/WxGeneric/GenericWidget.hs b/src/Graphics/UI/WxGeneric/GenericWidget.hs --- a/src/Graphics/UI/WxGeneric/GenericWidget.hs +++ b/src/Graphics/UI/WxGeneric/GenericWidget.hs @@ -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 +-} diff --git a/src/Graphics/UI/WxGeneric/GenericWidget/Parameters.hs b/src/Graphics/UI/WxGeneric/GenericWidget/Parameters.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WxGeneric/GenericWidget/Parameters.hs @@ -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) + + diff --git a/src/Graphics/UI/WxGeneric/GenericWidget/WidgetTree.hs b/src/Graphics/UI/WxGeneric/GenericWidget/WidgetTree.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WxGeneric/GenericWidget/WidgetTree.hs @@ -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 + diff --git a/src/Graphics/UI/WxGeneric/Layout.hs b/src/Graphics/UI/WxGeneric/Layout.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WxGeneric/Layout.hs @@ -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] + + +