diff --git a/COPYRIGHT.txt b/COPYRIGHT.txt new file mode 100644 --- /dev/null +++ b/COPYRIGHT.txt @@ -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 diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/WxGeneric.cabal b/WxGeneric.cabal new file mode 100644 --- /dev/null +++ b/WxGeneric.cabal @@ -0,0 +1,35 @@ +Name: WxGeneric +Version: 0.2.0 +Copyright: Mads Lindstrøm +License: LGPL +License-file: COPYRIGHT.txt +Author: Mads Lindstrøm +Maintainer: Mads Lindstrøm +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 + + diff --git a/examples/Alarm.hs b/examples/Alarm.hs new file mode 100644 --- /dev/null +++ b/examples/Alarm.hs @@ -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 ] ] diff --git a/examples/AlarmMapValue.hs b/examples/AlarmMapValue.hs new file mode 100644 --- /dev/null +++ b/examples/AlarmMapValue.hs @@ -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 ] diff --git a/examples/AlarmSpecialized.hs b/examples/AlarmSpecialized.hs new file mode 100644 --- /dev/null +++ b/examples/AlarmSpecialized.hs @@ -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 ] diff --git a/examples/Examples.hs b/examples/Examples.hs new file mode 100644 --- /dev/null +++ b/examples/Examples.hs @@ -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 + diff --git a/examples/TupleExample.hs b/examples/TupleExample.hs new file mode 100644 --- /dev/null +++ b/examples/TupleExample.hs @@ -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 ] ] diff --git a/examples/makefile b/examples/makefile new file mode 100644 --- /dev/null +++ b/examples/makefile @@ -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") diff --git a/src/Graphics/UI/WxGeneric.hs b/src/Graphics/UI/WxGeneric.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WxGeneric.hs @@ -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 diff --git a/src/Graphics/UI/WxGeneric/Composite.hs b/src/Graphics/UI/WxGeneric/Composite.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WxGeneric/Composite.hs @@ -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) + diff --git a/src/Graphics/UI/WxGeneric/GenericClass.hs b/src/Graphics/UI/WxGeneric/GenericClass.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WxGeneric/GenericClass.hs @@ -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) + diff --git a/src/Graphics/UI/WxGeneric/GenericList.hs b/src/Graphics/UI/WxGeneric/GenericList.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WxGeneric/GenericList.hs @@ -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 diff --git a/src/Graphics/UI/WxGeneric/GenericWidget.hs b/src/Graphics/UI/WxGeneric/GenericWidget.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/WxGeneric/GenericWidget.hs @@ -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