packages feed

barrie 0.4 → 0.4.1

raw patch · 29 files changed

+867/−122 lines, 29 files

Files

+ Makefile view
@@ -0,0 +1,15 @@+all:+	runhaskell Setup.lhs build+#	(cd demos ; make)++config:+	runhaskell Setup.lhs configure++install:+	runhaskell Setup.lhs install+clean:+	rm -f `find . -name "*.o" -print`+	rm -f `find . -name "*.hi" -print`+	rm -f `find . -name "*~" -print`+	(cd demos ; make clean)+	rm -rf dist OME
barrie.cabal view
@@ -1,37 +1,61 @@ Name:                   barrie-Version:                0.4-Synopsis:               Pure Gtk GUI library+Version:                0.4.1+Synopsis:               Declarative Gtk GUI library Description:     Implementation of an idea for supporting certain kinds of GUI:     that is state based, user-driven ones.  The GUI is intended to     manipulate a state, and it is responsive rather than active.-    Configuration is an example.  Category:               GUI License:                GPL License-file:           LICENSE Author:                 Fraser Wilson-Maintainer:             blancolioni@gmail.com-Copyright:              (c) Fraser Wilson+Maintainer:             Fraser Wilson <blancolioni@gmail.com>+Homepage:               http://thewhitelion.org/haskell/barrie+Copyright:              (c) 2009 Fraser Wilson Stability:              unstable cabal-version: >= 0.2 build-type: Simple+Tested-With:    GHC==6.10.0+Extra-Source-Files:+        Makefile+        doc/barrie.tex+        demos/AutoCalc.hs+        demos/BarrieCalc.hs+        demos/ButtonDemo.hs+        demos/CalcGadget.hs+        demos/CalcState.hs+        demos/CalcWidget.hs+        demos/ChooserDemo.hs+        demos/DynamicLabelDemo.hs+        demos/FileChooserDemo.hs+        demos/InnerDemo.hs+        demos/LabelDemo.hs+        demos/LauncherDemo.hs+        demos/LayoutDemo.hs+        demos/Layout.hs+        demos/ListDemo.hs+        demos/MultiColumnList.hs+        demos/SliderDemo.hs+        demos/TextBoxDemo.hs  Library    Build-Depends:       base,filepath,gtk>=0.10.0,glib>=0.10.0,containers-   Exposed-modules:     Barrie-   ghc-options:         -Wall -optl-Wl,s-   ghc-prof-options:    -prof -auto-all-   other-modules:-        Barrie.Config+   Exposed-modules:+        Barrie         Barrie.DrawPrimitive         Barrie.Gadgets-        Barrie.Gadgets.Connections+        Barrie.Packing         Barrie.Render         Barrie.Render.Gtk         Barrie.Style         Barrie.Trace         Barrie.Widgets+   ghc-options:         -Wall -optl-Wl,s,-O2+   ghc-prof-options:    -prof -auto-all+   other-modules:+        Barrie.Config+        Barrie.Gadgets.Connections   extensions:           MultiParamTypeClasses,FunctionalDependencies,                         GeneralizedNewtypeDeriving,RankNTypes,ExistentialQuantification   hs-source-dirs:       src
+ demos/AutoCalc.hs view
@@ -0,0 +1,15 @@+--  Calculator demo for Barrie 0.3++module Main where++import Barrie++import CalcState+import CalcGadget++--  The style lets you change colours, fonts, etc+calcStyle :: Style+calcStyle = emptyStyle++main = do mapM_ putStrLn $ widgetToLines (createLayout calcGUI)+          gtkMain calcGUI (createLayout calcGUI) startState
+ demos/BarrieCalc.hs view
@@ -0,0 +1,15 @@+--  Calculator demo for Barrie 0.3++module Main where++import Barrie++import CalcState+import CalcGadget+import CalcWidget++--  The style lets you change colours, fonts, etc+calcStyle :: Style+calcStyle = emptyStyle++main = gtkMain calcGUI calcLayout startState
+ demos/ButtonDemo.hs view
@@ -0,0 +1,18 @@+module Main where++import Barrie++demoWidget :: Widget+demoWidget = vbox [ui "demo label" (textLabel ""),+                   ui "demo command" (labelButton "click me")]++type DemoState = String++type DemoGadget = Gadget DemoState++demoGUI :: DemoGadget+demoGUI = sectionG "demo gui" [displayG "demo label" id,+                               commandG "demo command" reverse]++main = gtkMain demoGUI demoWidget "Hello, world"+
+ demos/CalcGadget.hs view
@@ -0,0 +1,47 @@+module CalcGadget (CalcState, Operator(..),+                   digitButtonName, operatorButtonName,+                   startState, calcGUI)  where++import Barrie++import CalcState++--  Names for various calculator gadgets+digitButtonName :: Int -> String+digitButtonName = show++operatorButtonName :: Operator -> String+operatorButtonName = show++--  CalcGadget puts the calculator operations into a gadget.+type CalcGadget = Gadget CalcState++data Operator = Plus | Minus | Multiply | Divide | Equals | Clear+              deriving (Eq, Ord, Enum, Bounded, Read, Show)++opFn :: Operator -> CalcState -> CalcState+opFn Plus     = op (+)+opFn Minus    = op (-)+opFn Multiply = op (*)+opFn Divide   = op div+opFn Equals   = eval+opFn Clear    = clear++calcGUI :: CalcGadget+calcGUI = sectionG "calculator" [display, buttons]++display :: CalcGadget+display = displayG "display" (\ st -> showBase (calcBase st) (calcValue st))+    where showBase _ 0 = "0"+          showBase b n = reverse $ sb n+              where sb 0 = ""+                    sb x = toEnum (x `mod` b + 48) : sb (x `div` b)+buttons :: CalcGadget+buttons = sectionG "buttonArea" [sectionG "ops" (map mkCmd [minBound ..]),+                                 sectionG "digits" (map mkDigit [0 .. 9]),+                                 sectionG "base" [base8]]+    where mkDigit d = enabled (\ st -> d < calcBase st) $+                      commandG (digitButtonName d) (addDigit d)+          mkCmd op  = commandG (operatorButtonName op) (opFn op)+          base8 = editorG "base8" (\ st -> calcBase st == 8)+                  (\ v st -> if v then setBase 8 st else setBase 10 st)
+ demos/CalcState.hs view
@@ -0,0 +1,45 @@+module CalcState (CalcState, startState,+                  calcValue, addDigit, op, eval, clear,+                  calcBase, setBase)+where++--  This is the state of the calculator: the current value, the current+--  partial function, and a flag to tell us whether the next digit will+--  start a new number (actually, the sense is reversed from that, but you+--  get the idea)++data CalcState = CS { calcValue :: Int,+                      calcOp    :: Int -> Int,+                      startNew  :: Bool,+                      calcBase  :: Int+                    }++startState :: CalcState+startState = CS 0 id False 10++--  Add a single digit to the state.  Depending on the boolean value,+--  this could be the start of a new number, or the new rightmost digit+--  of the existing number+addDigit :: Int -> CalcState -> CalcState+addDigit n (CS r f True base)  = CS n f False base+addDigit n (CS r f False base) = CS (r * base + n) f False base++--  Apply an operation to the calculator.  In fact, this partially applies+--  the operation to what's already there.  The current partial operation+--  is applied to the current number.+op :: (Int -> Int -> Int) -> CalcState -> CalcState+op f (CS r g _ base) = CS (g r) (f (g r)) True base++--  Evaluate the state.  That is, apply the current partial operation to+--  the current number, resetting everything else+eval :: CalcState -> CalcState+eval (CS r f _ base) = CS (f r) id True base++--  Clear the state.+clear :: CalcState -> CalcState+clear = const startState++setBase :: Int -> CalcState -> CalcState+setBase newBase cs = cs { calcBase = newBase }++
+ demos/CalcWidget.hs view
@@ -0,0 +1,20 @@+module CalcWidget where++import Barrie++import CalcState+import CalcGadget++--  Widgets are layout, without regard for underlying semantics.+--  Here, we put some buttons into a table+calcLayout :: Widget+calcLayout = vbox [ui "display" $ textLabel ""+                        ,hbox $ map digit [1,2,3] ++ [op "+" Plus]+                        ,hbox $ map digit [4,5,6] ++ [op "-" Minus]+                        ,hbox $ map digit [7,8,9] ++ [op "*" Multiply]+                        ,hbox $ digit 0 : [op "=" Equals, op "C" Clear,+                                              op "/" Divide]+                        ,hbox $ [textLabel "base 8", ui "base8" checkButton]+                  ]+     where digit n = ui (digitButtonName n) (labelButton (show n))+           op lbl fn = ui (operatorButtonName fn) (labelButton lbl)
+ demos/ChooserDemo.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Main where++import Data.Maybe+import Data.Typeable++import Barrie++demoWidget :: Widget+demoWidget = vbox [ui "demo chooser" dropList,+                   ui "demo chooser" listView,+                   ui "choice" (textLabel "Nothing chosen")]++data Option = Trains | Planes | Automobiles+        deriving (Read, Show, Enum, Bounded, Typeable)++type DemoState = Option++type DemoGadget = Gadget DemoState++demoGUI :: DemoGadget+demoGUI = sectionG "demo gui" [enumChooserG "demo chooser" id const,+                               displayG "choice" show]++main = gtkMain demoGUI demoWidget Trains+
+ demos/DynamicLabelDemo.hs view
@@ -0,0 +1,16 @@+module Main where++import Barrie++demoLayout :: Widget+demoLayout = vbox [ui "demo label" (textLabel "")]++type DemoState = String++type DemoGadget = Gadget DemoState++demoGUI :: DemoGadget+demoGUI = displayG "demo label" id++main = gtkMain demoGUI demoLayout "Hello, world"+
+ demos/FileChooserDemo.hs view
@@ -0,0 +1,20 @@+module Main where++import Barrie++demoWidget :: Widget+demoWidget = hbox [ui "demo entry" textBox,+                   ui "browse" $ fileOpen "Open",+                   ui "save" $ fileSave "Save"]++type DemoState = String++type DemoGadget = Gadget DemoState++demoGUI :: DemoGadget+demoGUI = sectionG "demo gui" [editorG "demo entry" id const,+                               initG "browse" id,+                               displayG "save" id]++main = gtkMain demoGUI demoWidget "Hello, world"+
+ demos/InnerDemo.hs view
@@ -0,0 +1,31 @@+module Main where++import Barrie++demoWidget :: Widget+demoWidget = vbox [ui "fst label" (textLabel "fst label"),+                   ui "snd label" (textLabel "snd label"),+                   innerWidget]++innerWidget :: Widget+innerWidget = ui "textEditor" textBox++type DemoState = (String, String)++type DemoGadget = Gadget DemoState++type InnerState = String+type InnerGadget = Gadget InnerState++demoGUI :: DemoGadget+demoGUI = sectionG "demo gui" [displayG "fst label" fst,+                               displayG "snd label" snd,+                               childG "demo inner" fst (\ x (_,y) -> (x,y))+                                      innerGUI]++innerGUI :: InnerGadget+innerGUI = editorG "textEditor" id (\ s _ -> s)++main = do mapM_ putStrLn $ widgetToLines demoWidget+          --  print $ abstract demoGUI+          gtkMain demoGUI demoWidget ("change me", "can't change me")
+ demos/LabelDemo.hs view
@@ -0,0 +1,19 @@+module Main where++import Barrie++demoStyle :: Style+demoStyle = emptyStyle++demoLayout :: Widget+demoLayout = vbox [ui "display" (textLabel "Hello, world")]++type DemoState = ()++type DemoGadget = Gadget DemoState++demoGUI :: DemoGadget+demoGUI = displayG "demo" id++main = gtkMain demoGUI demoLayout ()+
+ demos/LauncherDemo.hs view
@@ -0,0 +1,33 @@+module Main where++import Barrie++demoWidget :: Widget+demoWidget = vbox [ui "fst label" (textLabel "fst label"),+                   ui "snd label" (textLabel "snd label"),+                   mkPopup "demo popup" popupWidget (labelButton "click me")]++popupWidget :: Widget+popupWidget = vbox [ui "textEditor" textBox,+                    ui "close" $ labelButton "Close"]++type DemoState = (String, String)++type DemoGadget = Gadget DemoState++type PopupState = String+type PopupGadget = Gadget PopupState++demoGUI :: DemoGadget+demoGUI = sectionG "demo gui"+             [displayG "fst label" fst,+              displayG "snd label" snd,+              childG "demo popup" fst (\ x (_,y) -> (x,y)) popupGUI]++popupGUI :: PopupGadget+popupGUI = sectionG "popup" [editorG "textEditor" id (\ s _ -> s),+                             returnG "close"+                            ]++main = do mapM_ putStrLn (abstract demoGUI)+          gtkMain demoGUI demoWidget ("change me", "can't change me")
+ demos/Layout.hs view
@@ -0,0 +1,2 @@+module Layout where+
+ demos/LayoutDemo.hs view
@@ -0,0 +1,35 @@+module Main where++import Barrie++demoWidget :: Widget+demoWidget = vbox [ui "entry" textBox+                  ,hbox [ui "clear" (labelButton "clear")+                        ,ui "set" (labelButton "set")+                        ,ui "reverse" (labelButton "reverse")+                        ]+                  ,ui "label" (textLabel "Hello, world!")]++data DemoState = S { first :: String,+                     second :: String }++setFirst, setSecond :: String -> DemoState -> DemoState+setFirst s st = st { first = s }+setSecond s st = st { second = s }++update :: (a -> b) -> (b -> a -> a) -> a -> a+update get set state = set (get state) state++type DemoGadget = Gadget DemoState++demoGUI :: DemoGadget+demoGUI = sectionG "demo gui" [editorG "entry" first setFirst+                               ,commandG "clear" (setSecond "")+                               ,commandG "set" (update first setSecond)+                               ,commandG "reverse" (update (reverse . first)+                                                          setSecond)+                               ,displayG "label" second+                               ]++main = gtkMain demoGUI demoWidget $ S "Type Here" "Hello, world"+
+ demos/ListDemo.hs view
@@ -0,0 +1,41 @@+module Main where++import Data.List+import Data.Maybe++import Barrie++demoWidget :: Widget+demoWidget = vbox [ui "demo list" listView,+                   ui "selected" (textLabel ""),+                   hbox [ui "newname" textBox, ui "add" (labelButton "Add")]+                  ]++listItems :: [String]+listItems = ["Planes", "Trains", "Automobiles"]++type DemoState = ([String], Maybe String, String)++getList :: DemoState -> [String]+getList (items, _, _) = items++addItem :: DemoState -> DemoState+addItem (items, sel, item) = (item:items, sel, "")++type DemoGadget = Gadget DemoState++demoGUI :: DemoGadget+demoGUI = sectionG "demo gui" [chooseEqG "demo list" get set getList,+                               displayG "selected" get,+                               editorG "newname" getname setname,+                               commandG "add" addItem]+    where set sel (items, _, new) = (items, Just sel, new)+          selected (_, Nothing, _) = -1+          selected (items, Just s, _)  = maybe (-1) id (elemIndex s items)+          getname (_, _, nm) = nm+          setname nm (x, y, _) = (x,y,nm)+          get (_, Just v, _) = v+          get (_, Nothing, _) = ""++main = gtkMain demoGUI demoWidget (listItems, Nothing, "")+
+ demos/MultiColumnList.hs view
@@ -0,0 +1,34 @@+module Main where++import Data.List+import Data.Maybe++import Barrie+import Barrie.Packing++demoWidget :: Widget+demoWidget = vbox [treeHeaderVisible True $ ui "demo list" listView+                  ,ui "selected" (textLabel "")+                  ]++listItems :: [(String, Int)]+listItems = [("Planes", 29), ("Trains", 5), ("Automobiles", 52)]++type DemoState = ([(String, Int)], Int)++getList :: DemoState -> [(String, Int)]+getList (items, _) = items++type DemoGadget = Gadget DemoState++demoGUI :: DemoGadget+demoGUI = sectionG "demo gui" [columnTitles ["Product", "Price"] $+                               chooserG' "demo list" selected set fst unpack,+                               displayG "selected" getSelStr]+    where set sel (items, _) = (items, sel)+          selected (_, sel) = sel+          getSelStr (items, n) | n < 0 = ""+                               | otherwise = fst (items !! n)++main = gtkMain demoGUI demoWidget (listItems, 0)+
+ demos/SliderDemo.hs view
@@ -0,0 +1,13 @@+module Main where++import Barrie++sliderW = vbox [ui "x" $ hslider 0 100 1,+                ui "100 - x" $ hslider 0 100 1,+                ui "100 - x" $ textLabel ""+               ]++sliderG = sectionG "slider demo" [editorG "x" id const,+                                  displayG "100 - x" (100-)]++main = gtkMain sliderG sliderW (50 :: Double)
+ demos/TextBoxDemo.hs view
@@ -0,0 +1,18 @@+module Main where++import Barrie++demoWidget :: Widget+demoWidget = vbox [ui "demo entry" textBox,+                   ui "demo command" (labelButton "click me")]++type DemoState = String++type DemoGadget = Gadget DemoState++demoGUI :: DemoGadget+demoGUI = sectionG "demo gui" [editorG "demo entry" id const,+                               commandG "demo command" reverse]++main = gtkMain demoGUI demoWidget "Hello, world"+
+ doc/barrie.tex view
@@ -0,0 +1,38 @@+\documentclass{article}+\usepackage{verbatim}+\usepackage{listings}+\title{The Barrie GUI}+\author{Fraser Wilson}+\begin{document}++\maketitle+\tableofcontents++\section{Introduction}++Last year, I read the Fudgets thesis.  It was intriguing, and I+started thinking about connecting it to Gtk, so it would be prettier.+That was attempt number one.++I decided that mixing layout with widget definitions was a bad idea,+so I replaced layouts with connections to Glade XML.  This was attempt+number two.++A thread on Haskell Caf\'{e} got me thinking more about the separation+of layout and widgets.  This is attempt number three.++\section{Gadgets}++\subsection{Editor}++\subsection{Display}++\subsection{Initialiser}++\subsection{Choosers}++\subsection{Return}+++\end{document}+
src/Barrie/Config.hs view
@@ -1,12 +1,19 @@ {-# OPTIONS_GHC -XMultiParamTypeClasses -XFunctionalDependencies #-} -module Barrie.Config where+module Barrie.Config (Config, defaultConfig, transformConfig,+                      enabledCfg, isEnabled,+                      quitConfig, configQuits,+                      labelConfig, configHasLabel, configLabel,+                      titleConfig, configTitles)+    where  import Data.Typeable  data Config a = Cfg {            cEnabled :: a -> Bool,-           cLabel   :: Maybe (a -> String)+           cQuits   :: Bool,+           cLabel   :: Maybe (a -> String),+           cTitle   :: [String]            }  instance (Typeable a) => Typeable (Config a) where@@ -15,7 +22,11 @@                            typeOf (cLabel cfg)]  defaultConfig :: Config a-defaultConfig = Cfg { cEnabled = const True, cLabel = Nothing }+defaultConfig = Cfg { cEnabled = const True,+                      cQuits = False,+                      cLabel = Nothing,+                      cTitle = []+                    }  transformConfig :: (a -> b) -> Config b -> Config a transformConfig get cfg = cfg { cEnabled = cEnabled cfg . get,@@ -25,13 +36,18 @@                      Nothing -> Nothing                      Just f  -> Just $ f . get - enabledCfg :: (a -> Bool) -> Config a -> Config a enabledCfg f config = config { cEnabled = f }  isEnabled :: Config a -> a -> Bool isEnabled config state = cEnabled config state +quitConfig :: Bool -> Config a -> Config a+quitConfig q config = config { cQuits = q }++configQuits :: Config a -> Bool+configQuits config = cQuits config+ labelConfig :: (a -> String) -> Config a -> Config a labelConfig f config = config { cLabel = Just f } @@ -44,3 +60,8 @@ configLabel _ _ =     error "tried to get a label from a config which has none" +configTitles :: Config a -> [String]+configTitles = cTitle++titleConfig :: [String] -> Config a -> Config a+titleConfig ts config = config { cTitle = ts }
src/Barrie/Gadgets.hs view
@@ -1,10 +1,14 @@ module Barrie.Gadgets (Gadget, Behaviour,                        displayG, editorG, commandG, sectionG,-                       chooserG, enumChooserG, chooseEqG, childG,+                       chooserG, chooserG', enumChooserG, chooseEqG,+                       childG, initG, returnG,                        gadgetDisplay, gadgetUpdate, gadgetCommand,                        gadgetChooser, gadgetChild,                        findGadget, gadgetName, flatName,+                       gadgetElementType,                        gadgetConfig, gadgetEnabled, enabled, dynamicLabel,+                       columnTitles,+                       renderWith, gadgetRenderer,                        gadgets, abstract,                        createLayout) where@@ -23,7 +27,7 @@ data Gadget a = G { gadgetName     :: [String],                     gadgetConfig   :: Config a,                     gadgetElement  :: Maybe (Element a),-                    gadgetInner    :: Maybe (Interface a),+                    gadgetInner    :: Maybe (Gadget a),                     gadgetLayout   :: AutoLayoutFunction a,                     gadgetChildren :: [Gadget a]                   }@@ -40,12 +44,10 @@ data Element a = E { elementType      :: TypeRep,                      elementGet       :: a -> Dynamic,                      elementSet       :: Dynamic -> a -> a,-                     elementChoices   :: Maybe (a -> [(Dynamic, Dynamic)]),-                     elementRender    :: Dynamic -> Dynamic+                     elementChoices   :: Maybe (a -> [Dynamic]),+                     elementRender    :: [Dynamic -> Dynamic]                    } -data Interface a = IF { ifGadget :: Gadget a }- instance (Typeable a) => Typeable (Element a) where     typeOf e = mkTyConApp (mkTyCon "Barrie.Gadgets.Element") [elementType e] @@ -61,7 +63,7 @@              (a -> b)           -> (b -> a -> a)           -> Element a-mkElement get set = E tyrep (toDyn . get) (\ x -> set (get' x)) Nothing id+mkElement get set = E tyrep (toDyn . get) (\ x -> set (get' x)) Nothing [id]     where get' x = case fromDynamic x of                      Nothing -> error $ "'impossible' type error detected: " ++                                         show x ++ " " ++ show (typeOf (get' x))@@ -73,16 +75,34 @@                            Nothing -> g                            Just e  -> g { gadgetElement = Just $ update e } -renderWith :: (Dynamic -> Dynamic) -> Gadget a -> Gadget a-renderWith r = updateElement (\ e -> e { elementRender = r })+renderWith :: (Typeable b) =>+              ([b -> Dynamic]) -> Gadget a -> Gadget a+renderWith rs = updateElement+                  (\ e -> e { elementRender = map (. fromJust . fromDynamic) rs+                            }) -setChoices :: (a -> [(Dynamic, Dynamic)]) -> Gadget a -> Gadget a+gadgetRenderer :: Gadget a -> [Dynamic -> Dynamic]+gadgetRenderer G { gadgetElement = Nothing } = []+gadgetRenderer G { gadgetElement = Just e } = elementRender e++setChoices :: (a -> [Dynamic]) -> Gadget a -> Gadget a setChoices getChoices =     updateElement (\ e -> e { elementChoices = Just getChoices })  autoLayout :: AutoLayoutFunction a -> Gadget a -> Gadget a autoLayout f g = g { gadgetLayout = f } +lowLevelGadget :: (Typeable b) =>+                  String+               -> (a -> b)+               -> (b -> a -> a)+               -> TypeRep+               -> Gadget a+lowLevelGadget name get set ty = mkGadget name elmt { elementType = ty }+    where elmt = mkElement get set+++ displayG :: (Typeable b) => String -> (a -> b) -> Gadget a displayG name get = autoLayout (typeableLayout (typeOf $ get undefined)) $                        mkGadget name (mkElement get (\ _ st -> st))@@ -95,9 +115,18 @@ commandG name update = autoLayout buttonLayout $                           mkGadget name (mkElement (const ()) (\ () -> update)) +initG :: (Typeable b) => String -> (b -> a) -> Gadget a+initG name initfn = autoLayout textLayout $+                        mkGadget name (mkElement initError (\ x _ -> initfn x))+    where initError _ = error "can't get value from an init gadget"+ sectionG :: String -> [Gadget a] -> Gadget a sectionG name gs = G [name] defaultConfig Nothing Nothing boxLayout gs +returnG :: String -> Gadget a+returnG name = G [name] (quitConfig True defaultConfig)+                        Nothing Nothing buttonLayout []+ childG :: String            -- ^ gadget name        -> (a -> b)          -- ^ get child state        -> (b -> a -> a)     -- ^ update parent state with child state@@ -107,7 +136,7 @@    G { gadgetName     = [name],        gadgetConfig   = defaultConfig,        gadgetElement  = Nothing,-       gadgetInner    = Just $ IF $ transform get set child,+       gadgetInner    = Just $ transform get set child,        gadgetLayout   = boxLayout,        gadgetChildren = []      }@@ -117,18 +146,11 @@     G { gadgetName     = gadgetName g,         gadgetConfig   = transformConfig get (gadgetConfig g),         gadgetElement  = liftM (transformE get set) (gadgetElement g),-        gadgetInner    = liftM (transformI get set) (gadgetInner g),+        gadgetInner    = liftM (transform get set) (gadgetInner g),         gadgetLayout   = boxLayout,         gadgetChildren = map (transform get set) (gadgetChildren g)       } --- transformL :: (a -> b) -> (b -> a -> a) -> AutoLayoutFunction b---            -> AutoLayoutFunction a--- transformL get set f = \ layout gs = map--transformI :: (a -> b) -> (b -> a -> a) -> Interface b -> Interface a-transformI get set (IF g) = IF (transform get set g)- transformE :: (a -> b) -> (b -> a -> a) -> Element b -> Element a transformE get set e = e { elementGet = elementGet e . get,                            elementSet = xfset (elementSet e),@@ -146,20 +168,32 @@ chooserG :: (Typeable b) =>             String          -> (a -> Int)-         -> (b -> a -> a)+         -> (Int -> a -> a)          -> (a -> [b])          -> Gadget a chooserG name get set getChoices =-    autoLayout chooserLayout $ setChoices choices $ editorG name get' set'+    chooserG' name get set getChoices [toDyn]++chooserG' :: (Typeable b) =>+             String+          -> (a -> Int)+          -> (Int -> a -> a)+          -> (a -> [b])+          -> ([b -> Dynamic])+          -> Gadget a+chooserG' name get set getChoices renderer =+    autoLayout chooserLayout $ setChoices choices $ renderWith renderer $+               lowLevelGadget name get' set'+                                  (typeOf (head (getChoices undefined)))         where get' st = (choices st, get st)-              set' (vs, v) = if v >= length vs+              set' (_, v) = set v+              {- if v >= length vs                              then error ("chooser index " ++ show v ++                                          " was not in value list " ++                                          show vs)-                             else set (getValues vs !! v)-              choices st = zip (map toDyn (getChoices st))-                               (map toDyn [0 :: Int ..])-              getValues ds = map (fromJust . fromDynamic . fst) ds+                             else set (getValues vs !! v) -}+              choices st = map toDyn (getChoices st)+              --  getValues ds = map (fromJust . fromDynamic) ds  enumChooserG :: (Enum b, Bounded b, Read b, Show b) =>                 String@@ -168,17 +202,17 @@              -> Gadget a enumChooserG name get set =     autoLayout enumLayout $-    setChoices elems $ renderWith toStr $ editorG name get' set'+    setChoices elems $ renderWith [renderEnum] $ editorG name get' set'         where get' st = (elems st, fromEnum $ get st)-              set' (_, v) = set $ toEnum v-              elems st = let vs = [minBound ..] `asTypeOf` [get st]-                             is = map fromEnum vs-                             ts = map show vs-                         in zip (map toDyn ts) (map toDyn is)-              toStr d = let (xs, v) = fromDyn d ([], -100)-                            e = toEnum ((v :: Int))-                            _ = xs :: [(Dynamic,Dynamic)]-                        in toDyn (show (e `asTypeOf` get undefined))+              set' (_, v) = if v < 0+                              then error ("not setting enum to " ++ show v)+                              else set $ toEnum v+              elems st = let vs = [minBound .. maxBound] `asTypeOf` [get st]+                             ts = map fromEnum vs+                         in map toDyn ts+              renderEnum v = let e = toEnum v+                                 str = show (e `asTypeOf` get undefined)+                             in toDyn str  chooseEqG :: (Typeable b, Eq b) =>              String@@ -186,18 +220,24 @@          -> (b -> a -> a)          -> (a -> [b])          -> Gadget a-chooseEqG name get set choices = chooserG name get' set choices+chooseEqG name get set choices = chooserG name get' set' choices     where get' st = case elemIndex (get st) (choices st) of                       Nothing -> -1                       Just n  -> n+          set' v st = set (choices st !! v) st -findGadget :: [String] -> Behaviour a -> Maybe (Gadget a)-findGadget name (B gs) = case filter (match name) gs of-                           []  -> Nothing-                           g:_ -> Just g-    where match [] _ = False-          match nm G { gadgetName = gnm } =-              isPrefixOf (reverse nm) (reverse gnm)+findGadget :: [String] -> Gadget a -> Maybe (Gadget a)+findGadget [] = Just+findGadget (name:names) = \ top -> case filter fst (tries top) of+                                     []        -> Nothing+                                     (_,g):_   -> findGadget names g+    where tries g = [match g, matchInner g] +++                    map match (gadgetChildren g) +++                    concatMap tries (gadgetChildren g)+          match g = ([name] == gadgetName g, g)+          matchInner g = case gadgetInner g of+                           Nothing -> (False, g)+                           Just inner -> match inner  -- |Gadgets can change their properties based on the value of their state. -- Currently, the following configurations are implemented:@@ -222,12 +262,15 @@ dynamicLabel :: (a -> String) -> Gadget a -> Gadget a dynamicLabel f = addConfig (labelConfig f) +columnTitles :: [String] -> Gadget a -> Gadget a+columnTitles ts = addConfig (titleConfig ts)+ walk :: [String] -> ([String] -> Gadget a -> [b]) -> Gadget a -> [b] walk prefix f gadget@(G nm _ _ inner _ gs) =     f (prefix ++ nm) gadget ++ innerg ++ concatMap (walk (prefix ++ nm) f) gs         where innerg = case inner of                          Nothing -> []-                         Just (IF g) -> walk (prefix ++ nm) f g+                         Just g -> walk (prefix ++ nm) f g  gadgets :: Gadget a -> Behaviour a gadgets = B . walk [] getGadget@@ -236,6 +279,9 @@ abstract :: Gadget a -> [String] abstract = map flatName . walk [] (\ name g -> [g { gadgetName = name }]) +gadgetElementType :: Gadget a -> Maybe TypeRep+gadgetElementType g = gadgetElement g >>= return . elementType+ gadgetCommand :: Gadget a -> a -> a gadgetCommand G { gadgetElement = Just e } = elementSet e (toDyn ()) gadgetCommand _ = id@@ -250,7 +296,7 @@ gadgetUpdate g = error $ "Can't connect an update to empty gadget " ++                           flatName g -gadgetChooser :: Gadget a -> a -> [(Dynamic, Dynamic)]+gadgetChooser :: Gadget a -> a -> [Dynamic] gadgetChooser g = case getChoices of                     Nothing -> error $ "Can't connect a chooser to gadget " ++                                        flatName g@@ -259,9 +305,9 @@  gadgetChild :: Gadget a -> Gadget a gadgetChild g = case gadgetInner g of-                  Just (IF child) -> child-                  Nothing         -> error $ "Gadget " ++ flatName g ++-                                             " has no inner child"+                  Just child -> child+                  Nothing    -> error $ "Gadget " ++ flatName g +++                                        " has no inner child"  startLayout :: AutoLayout startLayout = AL { alDirection = Vertical,@@ -269,8 +315,8 @@                    alNames     = []                  } -editableLayout :: AutoLayout -> AutoLayout-editableLayout al = al { alEditable = True }+-- editableLayout :: AutoLayout -> AutoLayout+-- editableLayout al = al { alEditable = True }  type AutoLayoutFunction a = AutoLayout -> [Gadget a] -> Widget
src/Barrie/Gadgets/Connections.hs view
@@ -1,6 +1,7 @@ module Barrie.Gadgets.Connections (connectChooser,                                    connectCommand,                                    connectDisplay,+                                   connectUpdater,                                    connectEditor,                                    connectChild) where @@ -9,7 +10,6 @@ import Data.Dynamic  import Barrie.Gadgets-import Barrie.Trace  connectCommand :: (IO () -> IO ())    -- ^ connection creator                -> IO a                -- ^ state retriever@@ -40,19 +40,30 @@                                                   apply $ set curr st))    connect (gadgetDisplay gadget) (gadgetUpdate gadget) +connectUpdater :: (IO () -> IO ())     -- ^ connection creator+               -> IO a                 -- ^ gui state retriever+               -> IO Dynamic           -- ^ current value of GUI element+               -> Gadget a             -- ^ gadget representing the editor+               -> (a -> IO ())         -- ^ state change applier+               -> IO ()++connectUpdater onAction getState getValue gadget apply =+   onAction (do st <- getState+                curr <- getValue+                apply $ gadgetUpdate gadget curr st)+ -- |Connect a chooser to the GUI.  Elements of the chooser are stored -- |in a tuple; as (renderable value, state value). -connectChooser :: ([(Dynamic, Dynamic)] -> IO ())   -- ^ Set list of options+connectChooser :: ([Dynamic] -> IO ())   -- ^ Set list of options                -> (Int -> IO ())         -- ^ choose value-               -> IO Dynamic             -- ^ get value                -> Gadget a               -- ^ gadget representing the chooser                -> a -> IO ()-connectChooser setChoices setValue getValue gadget = do-  let update getChoices get set st =+connectChooser setChoices setValue gadget = do+  let update getChoices get st =           (setChoices (getChoices st) >>-           setValue (snd $ fromDyn (get st) ([(get st, get st)],-12)))-  update (gadgetChooser gadget) (gadgetDisplay gadget) (gadgetUpdate gadget)+           setValue (snd $ fromDyn (get st) ([get st],-12)))+  update (gadgetChooser gadget) (gadgetDisplay gadget)  connectChild :: (IO () -> IO ())         --  ^ show child              -> (Gadget a -> a -> IO a)  --  ^ child runner@@ -62,7 +73,5 @@              -> IO () connectChild onLaunch inner getState gadget setState = do   onLaunch (do st <- getState-               traceMessage $ "connecting: " ++ flatName gadget                st' <- inner (gadgetChild gadget) st-               traceMessage $ "finished: " ++ flatName gadget                setState st')
+ src/Barrie/Packing.hs view
@@ -0,0 +1,41 @@+module Barrie.Packing where++import Data.Dynamic+import Data.Typeable++class (Typeable a) => Packed a where+    unpack :: [a -> Dynamic]+    unpack = [toDyn]++instance Packed Int where++instance Packed Char where++instance (Packed a) => Packed [a] where++instance (Packed a, Packed b) => Packed (a,b) where+    unpack = [toDyn . fst, toDyn . snd]++instance (Packed a, Packed b, Packed c) => Packed (a,b,c) where+    unpack = [toDyn . get31, toDyn . get32, toDyn . get33]+        where get31 (x,_,_) = x+              get32 (_,x,_) = x+              get33 (_,_,x) = x++instance (Packed a, Packed b, Packed c, Packed d) => Packed (a,b,c,d) where+    unpack = [toDyn . get41, toDyn . get42, toDyn . get43, toDyn.get44]+        where       get41 (x,_,_,_) = x+                    get42 (_,x,_,_) = x+                    get43 (_,_,x,_) = x+                    get44 (_,_,_,x) = x++instance (Packed a, Packed b, Packed c, Packed d, Packed e) =>+    Packed (a,b,c,d,e) where+    unpack = [toDyn . get51, toDyn . get52, toDyn . get53,+                    toDyn.get54, toDyn.get55]+        where get51 (x,_,_,_,_) = x+              get52 (_,x,_,_,_) = x+              get53 (_,_,x,_,_) = x+              get54 (_,_,_,x,_) = x+              get55 (_,_,_,_,x) = x+
src/Barrie/Render.hs view
@@ -71,16 +71,21 @@ -- grouping, although in practice it will often look similar to the -- widget layout. -renderWidget :: Behaviour w -> Widget -> RenderF r w+renderWidget :: [String]         -- ^ name prefix for gadgets+             -> Gadget w         -- ^ top gadget+             -> Widget           -- ^ rendered widget+             -> RenderF r w      -- ^ GUI rendering action              -> IO (RunnableGUI r w)-renderWidget behaviour widget render = go widget-    where --  go :: StyleSheet -> Layout -> RunnableGUI r w-          go w = do let elmt = widgetElementName w+renderWidget prefix behaviour widget render = go widget+    where go w = do let elmt = widgetElementName w                         style = widgetStyle w-                        gadget = findGadget (uiElementName w) behaviour+                        gadget = if (not . null . uiElementName) w+                                    then findGadget (uiElementName w)+                                                    behaviour+                                    else Nothing                     traceMessage ("rendering element: " ++ elmt);                     traceMessage ("ui name = " ++-                                  intercalate "." (uiElementName w))+                                 intercalate "." (uiElementName w))                     traceMessage ("gadget = " ++                                   maybe "Nothing" flatName gadget)                     ws <- mapM go $ widgetChildren w@@ -99,7 +104,7 @@               [(typeOf "", flip fromDyn "")               ,(typeOf (0::Int), show . flip fromDyn (0::Int))               ,(typeOf (0::Double), show . flip fromDyn (0::Double))-                           ]+              ]  renderBool :: Dynamic -> Bool renderBool = getRenderer "bool" knownBoolTypes
src/Barrie/Render/Gtk.hs view
@@ -1,6 +1,7 @@ module Barrie.Render.Gtk (gtkMain, initGtk, renderGtk, runGtk) where  import Data.Dynamic+import Data.Maybe  import qualified Graphics.UI.Gtk as Gtk import System.Glib.Attributes@@ -21,7 +22,6 @@ import Barrie.Style import Barrie.Gadgets import Barrie.Gadgets.Connections-import Barrie.Trace import Barrie.Widgets  @@ -47,7 +47,6 @@                    -> Maybe (Gadget a)                    -> IO (RunnableGUI GtkGUI a) - -- |Convenience function for launching a gadget/widget pair, with a -- given state.  It should only be called once, at the top level, -- since it initialises Gtk (although I think multiple calls are@@ -56,7 +55,8 @@ gtkMain :: Gadget a -> Widget -> a -> IO a gtkMain gadget widget state = do   initGtk-  gui <- renderWidget (gadgets gadget) widget renderGtk+  gui <- renderWidget (gadgetName gadget) gadget+                      widget renderGtk   runGtk gui state False  @@ -120,7 +120,9 @@              ("hslider", renderScale Gtk.hScaleNewWithRange),              ("vslider", renderScale Gtk.vScaleNewWithRange),              ("vbox", renderBox Gtk.vBoxNew),-             ("hbox", renderBox Gtk.hBoxNew)]+             ("hbox", renderBox Gtk.hBoxNew),+             ("fileChooser", renderFileChooser)+            ]  -- Currently, we only do popup buttons, but it should be easily -- generalisable.@@ -218,7 +220,8 @@   btn <- Gtk.buttonNew   applyStyle (Gtk.buttonSetLabel btn) (getCaption style)   let onClicked = \ handler -> Gtk.onClicked btn handler >> return ()-      inner = \ g st -> do gui <- renderWidget (gadgets g) popup renderGtk+      inner = \ g st -> do gui <- renderWidget (gadgetName g) g+                                               popup renderGtk                            runGtk gui st True       clickUpdate = \ gets -> case gadget of                                 Nothing -> \ _ -> return ()@@ -234,6 +237,9 @@   let cfg = gadgetConfig gadget   when (configHasLabel cfg) $ do     Gtk.buttonSetLabel btn (configLabel cfg state)+  when (configQuits cfg) $ do+    let closeCurrent w = Gtk.widgetGetToplevel w >>= Gtk.widgetDestroy+    Gtk.onClicked btn (closeCurrent btn) >> return ()   configureWidget btn style (Just gadget) update state  configureButton _ _ _ update state = update state@@ -324,13 +330,15 @@           configureWidget cb style gadget updateValue,           changeUpdate) +{- traceGadget :: Maybe (Gadget a) -> String -> IO () traceGadget Nothing msg = traceMessage $ "<no gadget>: " ++ msg traceGadget (Just g) msg = traceMessage $ (flatName g) ++ msg+-}  -- |ModelRender: a record for rendering models. -data ModelRender = MR { mrSetChoices   :: [(Dynamic, Dynamic)] -> IO (),+data ModelRender = MR { mrSetChoices   :: [Dynamic] -> IO (),                         mrSetSelection :: Int -> IO (),                         mrGetValue     :: IO Dynamic,                         mrHasChanged   :: Dynamic -> IO Bool@@ -339,37 +347,30 @@ -- |The function renderModel uses the Gtk combo box/list/tree -- |abstraction to do some abstracting of its own. --- |Currently, we only render single-column lists. This makes the--- |implementation almost trivial.  Yay!--renderSingleColumnModel :: IO (Gtk.ListStore (Dynamic, Dynamic)) -- ^ get model from widget-                        -> (IO () -> IO ())     -- ^ selection change handler-                        -> IO Int        -- ^ current selection from widget-                        -> (Int -> IO ()) -- ^ set selection-                        -> IO ModelRender-renderSingleColumnModel getModel onChanged getCursor setCursor = do-  --  needUpdateRef <- newIORef True-  currentChoices <- newIORef ([] :: [(Dynamic, Dynamic)])+renderListModel :: IO (Gtk.ListStore Dynamic) -- ^ get model from widget+                -> (IO () -> IO ())     -- ^ selection change handler+                -> IO Int        -- ^ current selection from widget+                -> (Int -> IO ()) -- ^ set selection+                -> IO ModelRender+renderListModel getModel onChanged getCursor setCursor = do+  currentChoices <- newIORef ([] :: [Dynamic])   let setChoices xs = do-        --  needUpdate <- readIORef needUpdateRef-        --  writeIORef needUpdateRef False         model <- getModel         es <- Gtk.listStoreToList model-         --  Note that we don't have a very good way of deciding         --  when to update the list elements.         when (length es /= length xs) $ do             Gtk.listStoreClear model             mapM_ (Gtk.listStoreAppend model) xs-            writeIORef currentChoices (xs :: [(Dynamic, Dynamic)])+            writeIORef currentChoices (xs :: [Dynamic])       getValue = do         cursor <- getCursor         model  <- getModel         values <- Gtk.listStoreToList model         return $ toDyn (values, cursor)       hasChanged d = do-        let (_, x) = fromDyn d ([(d,d)], -100)-            s = fromDyn d "not a string"+        let (_, x) = fromDyn d ([d], -100)+        when (x == (-100)) (putStrLn $ "trouble converting " ++ show d)         curr <- getCursor         return (x /= curr)   return MR { mrSetChoices = setChoices,@@ -380,21 +381,23 @@  renderChooser :: GtkRenderFn a renderChooser _ style gadget = do-  store <- Gtk.listStoreNew ([] :: [(Dynamic, Dynamic)])+  store <- Gtk.listStoreNew ([] :: [Dynamic])   chooser <- Gtk.comboBoxNewWithModel store   r <- Gtk.cellRendererTextNew   Gtk.cellLayoutPackStart chooser r True-  Gtk.cellLayoutSetAttributes chooser r store $-                         \ row -> [ Gtk.cellText := renderText $ fst row ]+  case gadget of+    Nothing -> return ()+    Just g -> Gtk.cellLayoutSetAttributes chooser r store $+                         \ row -> [ Gtk.cellText := renderText (head (gadgetRenderer g) row) ]   let getModel = return store       onChanged = \ handler -> Gtk.on chooser Gtk.changed handler >> return ()       getSel = Gtk.comboBoxGetActive chooser       setSel = Gtk.comboBoxSetActive chooser-  mr <- renderSingleColumnModel getModel onChanged getSel setSel+  mr <- renderListModel getModel onChanged getSel setSel   let connect = case gadget of                   Nothing -> \ _ -> return ()-                  Just g -> connectChooser (mrSetChoices mr) (mrSetSelection mr)-                               (mrGetValue mr) g+                  Just g -> connectChooser (mrSetChoices mr)+                               (mrSetSelection mr) g       update getSt = case gadget of                        Nothing -> \ _-> return ()                        Just g -> connectEditor onChanged getSt@@ -414,16 +417,30 @@                      Just g  -> connectDisplay setDynText g   return (Gtk.castToWidget label, updateText, \ _ _ -> return ()) -renderSingleColumnList :: GtkRenderFn a-renderSingleColumnList children style gadget = do-  store <- Gtk.listStoreNew []-  list <- Gtk.treeViewNewWithModel store++addTextColumn :: Gtk.TreeView         -- ^ view that gets the column+              -> Gtk.ListStore Dynamic+              -> (Dynamic -> Dynamic) -- ^ column data fetcher+              -> IO ()+addTextColumn view store fetch = do   col <- Gtk.treeViewColumnNew   r <- Gtk.cellRendererTextNew   Gtk.cellLayoutPackStart col r True   Gtk.cellLayoutSetAttributes col r store $-         \ row -> [ Gtk.cellText := renderText (fst row) ]-  Gtk.treeViewAppendColumn list col+         \ row -> [ Gtk.cellText := renderText (fetch row) ]+  Gtk.treeViewAppendColumn view col+  return ()++renderSingleColumnList :: GtkRenderFn a+renderSingleColumnList _ style gadget = do+  store <- Gtk.listStoreNew []+  list <- Gtk.treeViewNewWithModel store+  case gadget of+    Nothing -> return ()+    Just g -> do mapM_ (addTextColumn list store) (gadgetRenderer g)+                 cols <- Gtk.treeViewGetColumns list+                 mapM_ (\ (c,t) -> Gtk.treeViewColumnSetTitle c t)+                           (zip cols (configTitles (gadgetConfig g)))   let getModel = return store       onChanged = \ handler -> Gtk.onCursorChanged list handler >>                                                return ()@@ -434,11 +451,11 @@                     _   -> error $ "can't render tree view "       setSel n | n < 0 = Gtk.treeViewSetCursor list [] Nothing                | otherwise = Gtk.treeViewSetCursor list [n] Nothing-  mr <- renderSingleColumnModel getModel onChanged getSel setSel+  mr <- renderListModel getModel onChanged getSel setSel   let connect = case gadget of                   Nothing -> \ _ -> return ()-                  Just g -> connectChooser (mrSetChoices mr) (mrSetSelection mr)-                                           (mrGetValue mr) g+                  Just g -> connectChooser (mrSetChoices mr)+                                        (mrSetSelection mr) g       update getSt = case gadget of                        Nothing -> \ _-> return ()                        Just g -> connectEditor onChanged getSt@@ -447,3 +464,66 @@   return (Gtk.castToWidget list,           configureTreeView list style gadget connect,           update)++renderFileChooser :: GtkRenderFn a+renderFileChooser ws style gadget = do+  case fileChooserAction style of+    FileOpen -> renderFileOpen ws style gadget+    FileSave -> renderFileSave ws style gadget++renderFileOpen :: GtkRenderFn a+renderFileOpen _ style gadget = do+  chooser <- Gtk.fileChooserDialogNew (getCaption style) Nothing+                                      Gtk.FileChooserActionOpen+                                      [("Open", Gtk.ResponseOk),+                                       ("Cancel", Gtk.ResponseCancel)]+  Gtk.fileChooserSetDoOverwriteConfirmation chooser True+  let runChooseFile = do response <- Gtk.dialogRun chooser+                         Gtk.widgetHide chooser+                         if response == Gtk.ResponseOk+                            then do+                              fname <- Gtk.fileChooserGetFilename chooser+                              case fname of+                                Nothing -> return (toDyn "")+                                Just name -> readFile name >>= return . toDyn+                            else return (toDyn "")++  btn <- Gtk.buttonNew+  applyStyle (Gtk.buttonSetLabel btn) (getCaption style)+  let onClicked = \ handler -> Gtk.onClicked btn handler >> return ()+      clickUpdate = \ gets -> case gadget of+                                Just g -> connectUpdater onClicked gets+                                                         runChooseFile g+                                Nothing -> const (return ())+  return (Gtk.castToWidget btn,+          configureButton btn style gadget (const (return ())),+          clickUpdate)++renderFileSave :: GtkRenderFn a+renderFileSave _ style gadget = do+  chooser <- Gtk.fileChooserDialogNew (getCaption style) Nothing+                                      Gtk.FileChooserActionSave+                                      [("Save", Gtk.ResponseOk),+                                       ("Cancel", Gtk.ResponseCancel)]++  let runSaveFile gets getStrVal =+          do response <- Gtk.dialogRun chooser+             Gtk.widgetHide chooser+             when (response == Gtk.ResponseOk) $ do+               fname <- Gtk.fileChooserGetFilename chooser+               case fname of+                 Nothing -> return ()+                 Just name -> do+                   st <- gets+                   writeFile name (renderText (getStrVal st))++  btn <- Gtk.buttonNew+  applyStyle (Gtk.buttonSetLabel btn) (getCaption style)+  let onClicked = \ handler -> Gtk.onClicked btn handler >> return ()+      clickUpdate = \ gets _ -> case gadget of+                                  Just g -> onClicked $+                                             runSaveFile gets (gadgetDisplay g)+                                  Nothing -> return ()+  return (Gtk.castToWidget btn,+          configureButton btn style gadget (const (return ())),+          clickUpdate)
src/Barrie/Style.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-}  module Barrie.Style (Style, Styled(..), addStyle, emptyStyle,+                     mkStyle, styleValue,                      caption, getCaption,                      hideDisabled, getHideDisabled,                      homogenous, getHomogenous,@@ -41,7 +42,7 @@ caption :: (Styled a) => String -> a -> a caption text = addStyle $ mkStyle "caption" text -getCaption :: (Styled a) => a -> Maybe StyleValue+getCaption :: (Styled a) => a -> Maybe String getCaption = styleValue "caption"  textValue :: (Styled a) => String -> a -> a
src/Barrie/Widgets.hs view
@@ -7,7 +7,9 @@      vbox, hbox, menu, menuItem, button, labelButton, checkButton,      textLabel, slider, hslider, vslider,      staticDropList, dropList, listView, radioButtonList,-     textBox, textBoxWithValue)+     textBox, textBoxWithValue,+     FileChooserAction(..),+     fileChooserAction, fileChooser, fileOpen, fileSave)     where  import Data.List@@ -121,3 +123,17 @@  textBoxWithValue :: String -> Widget textBoxWithValue text  = textValue text textBox++data FileChooserAction = FileOpen | FileSave deriving (Read, Show)++fileChooser :: FileChooserAction -> String -> Widget+fileChooser action label =+     addStyle (mkStyle "fileChooserAction" (show action)) $+     caption label $ mkWidget "fileChooser" []++fileOpen, fileSave :: String -> Widget+fileOpen = fileChooser FileOpen+fileSave = fileChooser FileSave++fileChooserAction :: (Styled a) => a -> FileChooserAction+fileChooserAction = maybe FileOpen read . styleValue "fileChooserAction"