WxGeneric (empty) → 0.2.0
raw patch · 14 files changed
+1089/−0 lines, 14 filesdep +SybWidgetdep +basedep +haskell98setup-changed
Dependencies added: SybWidget, base, haskell98, mtl, wx, wxcore, xtc
Files
- COPYRIGHT.txt +20/−0
- Setup.lhs +4/−0
- WxGeneric.cabal +35/−0
- examples/Alarm.hs +29/−0
- examples/AlarmMapValue.hs +39/−0
- examples/AlarmSpecialized.hs +52/−0
- examples/Examples.hs +105/−0
- examples/TupleExample.hs +13/−0
- examples/makefile +32/−0
- src/Graphics/UI/WxGeneric.hs +12/−0
- src/Graphics/UI/WxGeneric/Composite.hs +274/−0
- src/Graphics/UI/WxGeneric/GenericClass.hs +251/−0
- src/Graphics/UI/WxGeneric/GenericList.hs +125/−0
- src/Graphics/UI/WxGeneric/GenericWidget.hs +98/−0
+ COPYRIGHT.txt view
@@ -0,0 +1,20 @@+SybWidget - A library to ease the constructions of user interfaces.++Copyright (C) 2006 Mads Lindstrøm++This library is free software; you can redistribute it and/or+modify it under the terms of the GNU Lesser General Public+License as published by the Free Software Foundation; either+version 2.1 of the License, or (at your option) any later version.++This library is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+Lesser General Public License for more details.++You should have received a copy of the GNU Lesser General Public+License along with this library; if not, write to the Free Software+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA+++The author can be contacted at mads_lindstroem@yahoo.dk
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ WxGeneric.cabal view
@@ -0,0 +1,35 @@+Name: WxGeneric+Version: 0.2.0+Copyright: Mads Lindstrøm <mads_lindstroem@yahoo.dk>+License: LGPL+License-file: COPYRIGHT.txt+Author: Mads Lindstrøm <mads_lindstroem@yahoo.dk>+Maintainer: Mads Lindstrøm <mads_lindstroem@yahoo.dk>+Category: GUI+Build-Depends: SybWidget>=0.4,base,haskell98,mtl,xtc>=1.0,wx>=0.10.3+ ,wxcore>=0.10.3+Tested-with: GHC==6.8.2+Synopsis: Library which constructing generic (SYB3-based) widgets for WxHaskell+Build-type: Simple+Stability: experimental+Description:+ Constructs widgets for WxHaskell using SybWidget.+Ghc-options: -Wall+Exposed-modules:+ Graphics.UI.WxGeneric+ , Graphics.UI.WxGeneric.GenericClass+ , Graphics.UI.WxGeneric.Composite+ , Graphics.UI.WxGeneric.GenericWidget+ , Graphics.UI.WxGeneric.GenericList+other-modules:+Extra-Source-Files:+ examples/makefile+ , examples/Alarm.hs+ , examples/AlarmMapValue.hs+ , examples/AlarmSpecialized.hs+ , examples/Examples.hs+ , examples/TupleExample.hs+Extensions: +hs-source-dirs: src++
+ examples/Alarm.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses+ , TemplateHaskell, UndecidableInstances #-}++module Alarm where++import Graphics.UI.WxGeneric+import Graphics.UI.SybWidget.MySYB++import Graphics.UI.WX+import Graphics.UI.WXCore++data Minutes = Minutes Int deriving (Show, Eq)+data Alarm = Alarm { name :: String+ , timeOfDay :: Minutes+ } deriving (Show, Eq)++$(derive [''Minutes,''Alarm])++instance WxGen Alarm+instance WxGen Minutes++main :: IO ()+main = start $+ do f <- frame [ text := "Alarm Example" ]+ p <- panel f []+ 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 [ widget en, widget b ] ]
+ examples/AlarmMapValue.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses+ , TemplateHaskell, UndecidableInstances #-}++module AlarmMapValue where++import Graphics.UI.WxGeneric+import Graphics.UI.SybWidget.MySYB++import Graphics.UI.WX+import Graphics.UI.WXCore++data Minutes = Minutes Int deriving (Show, Eq)+data Alarm = Alarm { name :: String+ , timeOfDay :: Minutes+ } deriving (Show, Eq)+data UserTime = UserTime { hour :: Int+ , minute :: Int+ } deriving (Show, Eq)++$(derive [''Minutes,''UserTime,''Alarm])++instance WxGen UserTime+instance WxGen Alarm++instance WxGen Minutes where+ mkWid m' =+ let minutes2UserTime (Minutes m) = UserTime (m `div` 60) (m `mod` 60)+ userTime2Minutes (UserTime h m) = Minutes (60*h + m)+ in mapValue userTime2Minutes (const minutes2UserTime) (mkWid (minutes2UserTime m'))++main :: IO ()+main = start $+ do f <- frame [ text := "Alarm Map Value" ]+ p <- panel f []+ 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 [ widget en, widget b ]+ , size := Size 275 165 ]
+ examples/AlarmSpecialized.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses+ , TemplateHaskell, UndecidableInstances #-}++module AlarmSpecialized where++import Graphics.UI.WxGeneric+import Graphics.UI.SybWidget.MySYB++import Graphics.UI.WX+import Graphics.UI.WXCore++import Control.Monad++data Minutes = Minutes Int deriving (Show, Eq)+data Alarm = Alarm { name :: String+ , timeOfDay :: Minutes+ } deriving (Show, Eq)+$(derive [''Minutes,''Alarm])++instance WxGen Alarm++instance WxGen Minutes where+ mkWid m' = toOuter (valuedCompose helper)+ where helper p = + do changeVar <- varCreate (return ())+ + hours <- hslider p True 0 23 [ selection := fst $ minutes2Clock m' ]+ minutes <- hslider p True 0 23 [ selection := snd $ minutes2Clock m' ]+ + 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 ] ]+ 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+ )+ minutes2Clock (Minutes m) = (m `div` 60, m `mod` 60)+ clock2Minutes h m = Minutes (60*h + m)++main :: IO ()+main = start $+ do f <- frame [ text := "Alarm Specialized Example" ]+ p <- panel f []+ 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 ]+ , size := Size 550 165 ]
+ examples/Examples.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE FlexibleContexts, FlexibleInstances+ , MultiParamTypeClasses, TemplateHaskell, UndecidableInstances #-}++-- Why is UndecidableInstances neccesary? as derive requires it. +-- Otherwise we get "Constraint is no smaller than the instance head"-error.+-- This is a general problem with using SYB.++module Examples where++import Graphics.UI.WxGeneric++import Graphics.UI.XTC+import Graphics.UI.WX+import Graphics.UI.WXCore+++import Graphics.UI.SybWidget.MySYB++data MyTree = Branch { left :: MyTree, right :: MyTree }+ | Leaf Int Double+ deriving Show++$(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 }++$(derive [''Person])+instance WxGen Person++main = listTest++someTree = Leaf 5 5.2++x :: Int+x = 17++tree = start $+ do f <- frame []+ p <- panel f []+ en <- genericWidget p someTree+ set en [ on change := get en widgetValue >>= print ]+ b1 <- button p [ text := "&Make simple tree"+ , on command := set en [ widgetValue := someTree ] ]+ b2 <- button p [ text := "&Show tree"+ , on command := get en widgetValue >>= print ]+ set f [ layout := container p $ column 10 [ fill $ widget en+ , row 10 [ glue, widget b1, widget b2 ]+ ] ]+ ++tree' = start $+ do f <- frame []+ -- p <- panel f []+ scWin <- scrolledWindow f [ scrollRate := sz 10 10, virtualSize := sz 500 500, fullRepaintOnResize := False ]+ scrolledWindowEnableScrolling scWin True True+ b1 <- button f [ text := "&Do stuff"+ , on command := set scWin [ virtualSize := sz 1000 1000 ] ]+ en <- genericWidget scWin someTree+ set scWin [ layout := fill $ widget en ]+ set f [ layout := column 1 [ hfill $ hrule 1+ , fill (widget scWin)+ , widget b1+ ] ]+ ++person = start $+ do f <- frame []+ p <- panel f []+ -- en <- genericWidget p (Person "Bob" [] 17)+ en <- genericWidget p (Person "Bob" 17 [])+ set f [ layout := container p $ fill $ widget en ]+ ++anyInt = start $+ do f <- frame []+ intEntry <- genericWidget f x+ set intEntry [ on change := get intEntry widgetValue >>= print ]+ set f [ layout := widget intEntry ]++mai3 = start $+ do f <- frame []+ p <- panel f []+ en <- textEntry p []+ set f [ layout := widget p ] -- must also have fill+ set p [ layout := fill $ widget en ]++enum = start $+ do f <- frame []+ myEnum <- genericWidget f Enum1+ set myEnum [ on change := get myEnum widgetValue >>= print ]+ set f [ layout := widget myEnum ]++listTest = start $+ do f <- frame []+ p <- panel f []+ listWid <- genericWidget p [1::Int, 2, 8]+ set listWid [ on change := get listWid widgetValue >>= print ]+ set f [ layout := container p $ fill $ widget listWid ]+ +data MyEnum = Enum1 | Enum2 | Enum3 deriving Show+$(derive [''MyEnum])+instance WxGen MyEnum+
+ examples/TupleExample.hs view
@@ -0,0 +1,13 @@+module TupleExample where++import Graphics.UI.WxGeneric+import Graphics.UI.WX++main :: IO ()+main = start $+ do f <- frame [ text := "Tuple Example" ]+ p <- panel f []+ en <- genericWidget 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
@@ -0,0 +1,32 @@+HC = ghc+HC_MAKE = $(HC) -Wall --make $< -o $@ -main-is $(notdir $@) $(HC_OPTIONS)+EXAMPLES=Examples TupleExample Alarm AlarmSpecialized AlarmMapValue+SCREENSHOT_DIR=screenshots++all:$(EXAMPLES)++%: %.hs+ $(HC_MAKE)++Examples:Examples.hs TupleExample.hs++.PHONY: clean remake++remake:clean 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
@@ -0,0 +1,12 @@+module Graphics.UI.WxGeneric+ ( module Graphics.UI.WxGeneric.GenericClass+ , module Graphics.UI.WxGeneric.GenericWidget+ , module Graphics.UI.WxGeneric.Composite+ , module Graphics.UI.WxGeneric.GenericList+ )+where++import Graphics.UI.WxGeneric.GenericClass+import Graphics.UI.WxGeneric.GenericWidget+import Graphics.UI.WxGeneric.Composite+import Graphics.UI.WxGeneric.GenericList
+ src/Graphics/UI/WxGeneric/Composite.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE ExistentialQuantification, FlexibleContexts, FlexibleInstances, FunctionalDependencies+ , MultiParamTypeClasses, RankNTypes, TypeSynonymInstances #-}+{-# OPTIONS -Wall #-}++-- |Module to ease composing zero-to-many widgets to a larger+-- composite widget.+module Graphics.UI.WxGeneric.Composite+ ( -- * Composite type+ Composite, pickPanel, pickSuper, pickUser+ , compose, singleComposite+ -- * Mapping attributes+ , mapFromPanel, forAllChildren+ , mapFromSuper+ , mapFromUser+ -- * Mapping events+ , mapEventF, mapEventSuper, mapEventPanel+ -- * Other+ , ValuedWidget, widgetValue+ , updateSuper, updateUser+ )+where++import Graphics.UI.WX+import Graphics.UI.WXCore hiding (Event)+import Graphics.UI.XTC++-- What about Styled, Dockable, and Pictured classes?++-- |Data type which contains a composite widget+data Composite super user = forall w. + Composite { pickPanel :: Window w+ , pickSuper :: super+ , pickUser :: user+ }++{- |Composes zero-to-many widgets to a larger composite widget++The composite will automatically implement the following classes:++* Widget++* Able++* Bordered++* Child++* Dimensions++* Identity++* Literate++* Visible++* Reactive (event class)++if the supertype implements one of the following classes, so will the+Composite:++* Items++* Observable++* Selection++* Selections++* Textual++* Commanding (event class)++* Selecting (event class)++* ValuedWidget++if the composite needs to implement more classes it should be done as+follows:++@+type MyComposite = Composite super user+ +instance Foo MyComposite where+ ...+@++-}++compose :: (Panel () -> IO (Layout, super, user))+ -> Window w -> [Prop (Composite super user)] -> IO (Composite super user)+compose f w props =+ do p <- panel w []+ (lay, super, user) <- f p+ set p [ layout := lay ]+ let composite = Composite p super user+ set composite props+ return composite++-- |Encapsulate a single 'Window w' in the composite type+singleComposite :: Window w -> super -> user -> Composite super user+singleComposite w = Composite w++-- |Used when an attribute should apply to the panel+mapFromPanel :: (forall w. Attr (Window w) attr) -> Attr (Composite super user) attr+mapFromPanel attr = newAttr (attrName attr) getter setter+ where getter (Composite wid _ _) = get wid attr+ setter (Composite wid _ _) x = set wid [ attr := x ]++-- |Used when an attribute should apply to the panel and all of its+-- children+forAllChildren :: Attr (Window ()) attr -> (forall w. Attr (Window w) attr)+ -> Attr (Composite super user) attr+forAllChildren childAttr panelAttr = newAttr (attrName panelAttr) getter setter+ where getter (Composite wid _ _) = get wid panelAttr+ setter (Composite wid _ _) val =+ do set wid [ panelAttr := val ]+ xs <- get wid children+ mapM_ (\x -> set x [ childAttr := val ]) xs+++-- |Used when an attribute should apply to the "supertype"+mapFromSuper :: Attr super attr -> Attr (Composite super user) attr+mapFromSuper = mapAttrW pickSuper++-- |Used when an attribute should apply to the "usertype"+mapFromUser :: Attr user attr -> Attr (Composite super user) attr+mapFromUser = mapAttrW pickUser++-- *** Inherit from Panel ()+instance Widget (Composite super user) where+ widget (Composite w _ _) = widget w++instance Able (Composite super user) where+ enabled = mapFromPanel enabled++instance Bordered (Composite super user) where+ border = mapFromPanel border++instance Child (Composite super user) where+ parent = mapFromPanel parent++instance Colored (Composite super user) where+ bgcolor = forAllChildren bgcolor bgcolor+ color = forAllChildren color color++-- Does this instance declaration make sense?+instance Dimensions (Composite super user) where+ outerSize = mapFromPanel outerSize+ position = mapFromPanel position+ area = mapFromPanel area+ bestSize = mapFromPanel bestSize+ clientSize = mapFromPanel clientSize+ virtualSize = mapFromPanel virtualSize++instance Identity (Composite super user) where+ identity = mapFromPanel identity++instance Literate (Composite super user) where+ font = forAllChildren font font+ fontSize = forAllChildren fontSize fontSize+ fontWeight = forAllChildren fontWeight fontWeight+ fontFamily = forAllChildren fontFamily fontFamily+ fontShape = forAllChildren fontShape fontShape+ fontFace = forAllChildren fontFace fontFace+ fontUnderline = forAllChildren fontUnderline fontUnderline+ textColor = forAllChildren textColor textColor+ textBgcolor = forAllChildren textBgcolor textBgcolor++instance Visible (Composite super user) where+ visible = mapFromPanel visible+ refresh (Composite w _ _) = refresh w+ fullRepaintOnResize = mapFromPanel 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 (Composite super user) where+ checkable = mapFromSuper checkable+ checked = mapFromSuper checked++instance Help super => Help (Composite super user) where+ help = mapFromSuper help++instance Observable super => Observable (Composite super user) where+ change = mapEventSuper change++instance Tipped super => Tipped (Composite super user) where+ tooltip = mapFromSuper tooltip++-- if we change String into just "a", then we also need the flag+-- -fallow-undecidable-instances, which we do not want to do.+instance Items super String => Items (Composite super user) String where+ itemCount = mapFromSuper itemCount+ items = mapFromSuper items+ item x = mapFromSuper (item x)+ itemDelete w x = itemDelete (pickSuper w) x+ itemsDelete w = itemsDelete (pickSuper w)+ itemAppend w x = itemAppend (pickSuper w) x++instance Selection super => Selection (Composite super user) where+ selection = mapFromSuper selection++instance Selections super => Selections (Composite super user) where+ selections = mapFromSuper selections++instance Textual super => Textual (Composite super user) where+ text = mapFromSuper text++-- We need to use (super a) to make this instance decidable+instance ValuedWidget a (super a) => ValuedWidget a (Composite (super a) user) where+ widgetValue = mapFromSuper widgetValue++-- *** Events++-- | Mapping events from supertype+mapEventSuper :: Event super event -> Event (Composite super user) event+mapEventSuper event = mapEventF pickSuper event++-- | Mapping events from the Panel ()+mapEventPanel :: (forall w. Event (Window w) event) -> Event (Composite super user) event+mapEventPanel event = newEvent "" getter setter where+ getter (Composite w _ _) = get w (on event)+ setter (Composite w _ _) val = set w [ on event := val ]++-- | Mapping events using a mapper function+mapEventF :: (to -> from) -> Event from event -> Event to event+mapEventF f event = newEvent "" getter setter where+ getter w = get (f w) (on event)+ setter w val = set (f w) [ on event := val ]+ ++instance Selecting super => Selecting (Composite super user) where+ select = mapEventSuper select++instance Commanding super => Commanding (Composite super user) where+ command = mapEventSuper command++instance Reactive (Composite super user) where+ mouse = mapEventPanel mouse+ keyboard = mapEventPanel keyboard+ closing = mapEventPanel closing+ idle = mapEventPanel idle+ resize = mapEventPanel resize+ focus = mapEventPanel focus+ activate = mapEventPanel activate++-- We should also do Paint++-- Should properly rename ValuedWidget to Valued, but there is already+-- a type class called Valued in WxHaskell. However, WxHaskell's+-- definition do not really work for widgets. It only seems to work+-- for Var-s.+class ValuedWidget x w | w -> x where+ widgetValue :: Attr w x+++-- GHC error message: +-- Record update for the non-Haskell-98 data type `Composite' is not (yet) supported+-- Use pattern-matching instead+--+-- Thus we avoid pattern matching here.+updateSuper :: (super -> super') -> Composite super user -> Composite super' user+updateSuper f (Composite panel' super user) = Composite panel' (f super) user++-- GHC error message: +-- Record update for the non-Haskell-98 data type `Composite' is not (yet) supported+-- Use pattern-matching instead+--+-- Thus we avoid pattern matching here.+updateUser :: (user -> user') -> Composite super user -> Composite super user'+updateUser f (Composite panel' super user) = Composite panel' super (f user)+
+ src/Graphics/UI/WxGeneric/GenericClass.hs view
@@ -0,0 +1,251 @@+{-# LANGUAGE ExistentialQuantification, FlexibleContexts+ , FlexibleInstances, FunctionalDependencies, KindSignatures+ , MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, TypeSynonymInstances #-}+{-# OPTIONS -Wall #-}++module Graphics.UI.WxGeneric.GenericClass+ ( -- * Turning datatypes into widgets+ genericWidget, modalValuedDialog+ + -- * Outer type+ , Outer(..)+ , toOuter, withLabel, fromOuter, getUnlabeld, setOuterLabel+ + -- * Generic class (WxGen) and making instancs of WxGen+ , WxGen(..), WxGenD(..), wxGenCtx+ , singleConstr, polyConstr+ , extOuter+ )+where++import Graphics.UI.WX as Wx hiding (when)+import Graphics.UI.XTC++import Graphics.UI.SybWidget+import Graphics.UI.WxGeneric.GenericWidget+import Graphics.UI.WxGeneric.Composite++import Control.Monad.Reader+import List (partition)+import Maybe++-- |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++-- |Creates a modal dialog containing the 'x' value, an +-- ok-buuton and a cancel-button.+modalValuedDialog :: WxGen a =>+ Window w+ -> String -- ^Dialog title+ -> String -- ^Text at ok-button+ -> a -- ^Initial value+ -> IO (Maybe a) -- ^Returns Just x if the user presses the ok-button.+ -- Otherwise Nothing is returned.+modalValuedDialog w dialogTitle okText x =+ do d <- dialog w [ resizeable := True, text := dialogTitle ]+ showModal d (helper d)+ where helper d endModalForm =+ do p <- panel d []+ wid <- genericWidget p x+ ok <- button p [ text := okText+ , on command := do val <- get wid 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 ]+ ] ]+ return ()++-- |The dictionary type for the WxEcCreator class+data WxGenD a = + WxGenD { mkWidD :: a -> Outer a }++data Outer a = Outer PriLabel (Either (GenWidIO a) (String -> GenWidIO a))++instance MapValue Outer where+ mapValue oldToNew newToOld (Outer lbl (Left genWidIO)) =+ Outer lbl (Left (\w -> genWidIO w >>= return . mapValue oldToNew newToOld))+ mapValue oldToNew newToOld (Outer lbl (Right genWidIO)) =+ Outer lbl (Right (\s w -> genWidIO s w >>= return . mapValue oldToNew newToOld))++toOuter :: forall a. (WxGen a) => (forall w. Window w -> IO (GenWid a)) -> Outer a+toOuter f = let priLabel = generateLabel (error "WxGeneric call to generateLabel (1)" :: a)+ in Outer priLabel (Left f)++withLabel :: forall a. (WxGen a) => (String -> forall w. Window w -> IO (GenWid a)) -> Outer a+withLabel f = let priLabel = generateLabel (error "WxGeneric call to generateLabel (2)" :: a)+ in Outer priLabel (Right f)++fromOuter :: Window w -> Outer a -> IO (GenWid a)+fromOuter w (Outer _ (Left f)) = f w+fromOuter w (Outer lbl (Right f)) = f (labelString $ 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 _ (Right _)) = Nothing++setOuterLabel :: PriLabel -> Outer a -> Outer a+setOuterLabel newLbl = updateLabel (const newLbl)++-- |Instantiation of the Sat class+instance WxGen a => Sat (WxGenD a)+ where dict = WxGenD { mkWidD = mkWid }++-- |The context for generic autoform+wxGenCtx :: Proxy WxGenD+wxGenCtx = error "wxGenCtx"++instance Labeled Constr where+ toLabel = show++instance OuterWidget Outer where+ updateLabel f (Outer lbl wid) = Outer (f lbl) wid++class ( 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+++data LabeledWid a = LabeledWid { lblWid :: (GenWid a), lblLabel :: Maybe String }++singleConstr :: WxGen a => a -> Outer a+singleConstr x = genericCompose $ mkSpliterSingleConstr wxGenCtx (mkWidD dict) x+ where+ genericCompose :: forall a. WxGen a => 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 innerSpliter' = mapParts lblWid innerSpliter+ setChange y = do sequence_ $ spliterToList (\i -> set i [ on 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 withLabels]+ )+ ++ withoutLabels+ where (withLabels, withoutLabels) = partitionWidgets layoutList+ layoutList = spliterToList toLayoutAndLabel innerSpliter+ toLayoutAndLabel wid = (fill $ widget $ lblWid wid, lblLabel wid)+ return (lay, g, s, varGet changeVar, setChange)++partitionWidgets :: [(Layout, Maybe 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) -> [label name, lay]) withLabels, withoutLabels)++-- |Used for types with more than one constructor+polyConstr :: forall a. (WxGen a, Data WxGenD a) =>+ a -> Outer a+polyConstr x = withLabel (\s -> valuedCompose (f s)) where+ f lbl p =+ do getValueProxy <- varCreate (return x)+ changeVar <- varCreate (return ())+ setChangeProxy <- varCreate (\_ -> return ())+ valueMemory <- 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+ , text := "Choose constructor" ]+ widPanel <- panel 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)+ refit widPanel+ genericWidget' w y = fromOuter w $ setOuterLabel labelless $ singleConstr y+ setter y = do getter >>= updateConstrValMap valueMemory+ deleteOldWidgets+ makeChild y+ join $ varGet changeVar+ set radioV [ typedSelection := toConstr wxGenCtx y ]+ makeChild x+ set radioV [ on select := do newCon <- get radioV typedSelection+ lastVal <- getter+ when (newCon /= toConstr wxGenCtx lastVal)+ (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)+++-- ********** AnyNum ****************************************++anyNum :: (Data WxGenD a) => String -> a -> GenWidIO a+anyNum legalChars initial p =+ do (sybGet, sybSet) <- numericGetSet wxGenCtx initial+ intEn <- textEntry p [ processEnter := True+ , on anyKey := handleInput+ ]+ let getter = get intEn text >>= sybGet+ setter x = do stringX <- sybSet x+ set intEn [ text := stringX ]+ setter initial+ return $ mkSingleObservable intEn getter setter+ where+ handleInput (KeyChar c) =+ do if c `elem` legalChars+ then propagateEvent+ else return ()+ handleInput _ = propagateEvent++-- *********** extOuter *************************************++-- |Makes it possible to choose between competing instances without+-- allowing overlapping instances.+extOuter :: (Typeable a, Typeable b) =>+ (a -> Outer a)+ -> (b -> Outer b)+ -> a -> Outer a+extOuter fn spec_fn arg = case gcast (M spec_fn) of+ Just (M spec_fn') -> spec_fn' arg+ Nothing -> fn arg+newtype M a = M (a -> Outer a)+++-- ************ WxGen instances ****************************************+instance WxGen Char+instance WxGen Int+instance WxGen Integer+instance WxGen Float+instance WxGen Double+instance (WxGen a, WxGen b) => WxGen (a, b)+instance (WxGen a, WxGen b, WxGen c) => WxGen (a, b, c)++instance (WxGen a, WxGen b) => WxGen (Either a b)+instance WxGen a => WxGen (Maybe a)+
+ src/Graphics/UI/WxGeneric/GenericList.hs view
@@ -0,0 +1,125 @@+-- |Exports an instance for 'WxGen' [a]. It handles [Char] (String) instances specially.+module Graphics.UI.WxGeneric.GenericList+ ( + )+where++import Graphics.UI.SybWidget.MySYB(gToString)+import Graphics.UI.SybWidget.InstanceCreator++import Graphics.UI.WxGeneric.GenericClass+import Graphics.UI.WxGeneric.GenericWidget++import Graphics.UI.WX as Wx+import Graphics.UI.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++mkStringOuter :: String -> Outer String+mkStringOuter x = toOuter helper where+ helper p = do te <- textEntry p [ text := x ]+ return $ mkSingleObservable te (get te text) (\val -> set te [ text := val ])++mkListOuter :: (WxGen a, Show a) => [a] -> Outer [a]+mkListOuter xs = toOuter (valuedCompose helper) where+ helper p =+ do let 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" ]+ let lay = column 10 [ fill $ widget ls+ , row 5 $ map widget [up, down, remove, edit, add]+ ]+ whenOne [y] f = f y+ whenOne _ _ = False+ updateEnabledness =+ do selected <- get ls selections+ ys <- get ls 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+ res <- f selected items'+ case res of+ Nothing -> return ()+ Just (newItems, newSel) ->+ do set ls [ typedItems := newItems+ , selections := newSel+ ]+ updateEnabledness+ join (varGet changeVar)+ ]+ let upCmd [i] items' | i > 0 = return $ Just (swapItems i (i-1) items', [i-1])+ upCmd _ _ = return Nothing+ setCmd up upCmd++ let downCmd [i] items' | i < (length items' - 1)+ = return $ Just (swapItems i (i+1) items', [i+1])+ downCmd _ _ = return Nothing+ setCmd down downCmd+ + let removeCmd selected items' =+ return $ Just ( snd $ splitWithIndices selected items', [])+ 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+ case y of+ Nothing -> return ()+ Just y' -> do set ls [ typedItems :~ (++ [y'])+ , selections := []+ ]+ updateEnabledness+ join (varGet changeVar)+ set add [ on command := addCmd (createInstance' wxGenCtx (head xs)) ]++ let editCmd [s] items' =+ do x <- modalValuedDialog p "Editng element" "&Ok" (items' !! s)+ case x of+ Nothing -> return Nothing+ Just x' -> return $ Just (replace x' s items', [s])+ editCmd _ _ = return Nothing+ setCmd edit editCmd+ + set ls [ on select := updateEnabledness >> propagateEvent ]+ updateEnabledness+ return ( lay, get ls typedItems, \ys -> set ls [typedItems := ys]+ , varGet changeVar, varSet changeVar)++-- |Splits a list in two parts, according to the indices+-- parameter. The first is the indices, the second are the rest of+-- list.+splitWithIndices :: [Int] -> [a] -> ([a], [a])+splitWithIndices indices xs = + let (toTake, toLeave) = partition move $ zip [0..] xs+ move (x, _) = elem x indices+ in (map snd toTake, map snd toLeave)+ ++-- |Replaces an item in a list. +replace :: a -- ^ The new item. + -> Int -- ^ Index (starting at 0) to replace. Must be less than the lists length.+ -> [a] -> [a]+replace x index xs = take index xs ++ [x] ++ drop (index + 1) xs++-- |Replaces an item in a list. +swapItems :: Int -- ^ First index (starting at 0) to swap. Must be less than the lists length.+ -> Int -- ^ Second index (starting at 0) to replace. Must be less than the lists length.+ -> [a] -> [a]+swapItems first second xs =+ replace (xs !! second) first $ replace (xs !! first) second xs
+ src/Graphics/UI/WxGeneric/GenericWidget.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE ExistentialQuantification, FlexibleContexts+ , FlexibleInstances, FunctionalDependencies+ , GeneralizedNewtypeDeriving, KindSignatures, MultiParamTypeClasses+ , RankNTypes, ScopedTypeVariables #-}+{-# OPTIONS -Wall #-}++{- |Contains GenWid, which is the type used for the inner widget in WxGeneric. Plus+functions to create GenWid.++GenWid contains a valued version of 'Composite'.+-}+module Graphics.UI.WxGeneric.GenericWidget+ ( fromWidget, valuedCompose+ , mkGenWid, mkSingleObservable, GenWid, GenWidIO+ , MapValue(..)+ )+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++-- |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 ])++-- |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()))+ -> GenWidIO a+valuedCompose f w =+ do p <- panel w []+ (lay, getter, setter, getChange, setChange) <- f p+ set p [ layout := fill lay ]+ return $ mkGenWid p getter setter getChange setChange++data ValuedCmds a = ValuedCmds+ { pickGetValue :: IO a+ , pickSetValue :: a -> IO ()+ , pickGetChange :: IO (IO ())+ , pickSetChange :: IO() -> IO()+ }+instance Observable (ValuedCmds a) where+ change = newEvent "change" pickGetChange pickSetChange++instance ValuedWidget a (ValuedCmds a) where+ widgetValue = newAttr "valued" pickGetValue pickSetValue++newtype GenWid a = GenWid (Composite (ValuedCmds a) ())+ deriving ( Widget, Able, Bordered, Child, Dimensions, Identity, Literate, Visible, Reactive+ , Observable, ValuedWidget a+ )++-- |Creates a GenWid using monadic actions.+mkGenWid :: forall w a.+ Window w -> IO a -> (a -> IO ()) -> IO (IO ()) -> (IO() -> IO())+ -> GenWid a+mkGenWid w getVal setVal getChg setChg = + GenWid $ singleComposite w (ValuedCmds getVal setVal getChg setChg) ()++-- |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 ())+ -> GenWid a+mkSingleObservable wid getter setter =+ mkGenWid wid getter setter (get wid (on change)) (\x -> set wid [on change := x])++-- *** MapValue class++class MapValue (valued :: * -> *) where+ mapValue :: (a -> b) -> (a -> b -> a) -> valued a -> valued b++instance MapValue GenWid where+ mapValue oldToNew newToOld (GenWid composite) =+ let updateCmds valuedCmds =+ valuedCmds { pickGetValue = pickGetValue valuedCmds >>= return . oldToNew+ , pickSetValue = \x -> do old <- pickGetValue valuedCmds+ pickSetValue valuedCmds (newToOld old x)+ }+ in GenWid $ updateSuper updateCmds composite