packages feed

barrie 0.3.1 → 0.4

raw patch · 21 files changed

+1406/−1288 lines, 21 files

Files

barrie.cabal view
@@ -1,5 +1,5 @@ Name:                   barrie-Version:                0.3.1+Version:                0.4 Synopsis:               Pure Gtk GUI library Description:     Implementation of an idea for supporting certain kinds of GUI:@@ -23,10 +23,10 @@    ghc-options:         -Wall -optl-Wl,s    ghc-prof-options:    -prof -auto-all    other-modules:-        Barrie.AbstractGadgets         Barrie.Config         Barrie.DrawPrimitive         Barrie.Gadgets+        Barrie.Gadgets.Connections         Barrie.Render         Barrie.Render.Gtk         Barrie.Style@@ -34,5 +34,4 @@         Barrie.Widgets   extensions:           MultiParamTypeClasses,FunctionalDependencies,                         GeneralizedNewtypeDeriving,RankNTypes,ExistentialQuantification- --                       ExistentialQualification   hs-source-dirs:       src
+ src/Barrie.hs view
@@ -0,0 +1,19 @@+module Barrie (+               module Barrie.DrawPrimitive,+               module Barrie.Gadgets,+               module Barrie.Render,+               module Barrie.Render.Gtk,+               module Barrie.Style,+               module Barrie.Trace,+               module Barrie.Widgets+              )++where++import Barrie.DrawPrimitive+import Barrie.Gadgets+import Barrie.Render+import Barrie.Render.Gtk+import Barrie.Style+import Barrie.Trace+import Barrie.Widgets
− src/Barrie.lhs 
@@ -1,21 +0,0 @@-> module Barrie (->                module Barrie.AbstractGadgets,->                module Barrie.DrawPrimitive,->                module Barrie.Gadgets,->                module Barrie.Render,->                module Barrie.Render.Gtk,->                module Barrie.Style,->                module Barrie.Trace,->                module Barrie.Widgets->               )--> where--> import Barrie.AbstractGadgets-> import Barrie.DrawPrimitive-> import Barrie.Gadgets-> import Barrie.Render-> import Barrie.Render.Gtk-> import Barrie.Style-> import Barrie.Trace-> import Barrie.Widgets
− src/Barrie/AbstractGadgets.lhs 
@@ -1,24 +0,0 @@-> module Barrie.AbstractGadgets (AbstractGadget,->                                acommand, achoice, atext, alabel,->                                ainner, alocal)-> where--> data AbstractGadget = AG AGadget [String]->         deriving (Read, Show)--> data AGadget = ACommand->              | AChoice->              | AText->              | ALabel->              | AInner->              | ALocal->         deriving (Read, Show)--> acommand, achoice, atext, alabel,->             ainner, alocal :: [String] -> AbstractGadget-> acommand   = AG ACommand-> achoice    = AG AChoice-> atext      = AG AText-> alabel     = AG ALabel-> ainner     = AG AInner-> alocal     = AG ALocal
+ src/Barrie/Config.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS_GHC -XMultiParamTypeClasses -XFunctionalDependencies #-}++module Barrie.Config where++import Data.Typeable++data Config a = Cfg {+           cEnabled :: a -> Bool,+           cLabel   :: Maybe (a -> String)+           }++instance (Typeable a) => Typeable (Config a) where+    typeOf cfg = mkTyConApp (mkTyCon "Barrie.Config.Config")+                          [typeOf (cEnabled cfg),+                           typeOf (cLabel cfg)]++defaultConfig :: Config a+defaultConfig = Cfg { cEnabled = const True, cLabel = Nothing }++transformConfig :: (a -> b) -> Config b -> Config a+transformConfig get cfg = cfg { cEnabled = cEnabled cfg . get,+                                cLabel = label'+                              }+    where label' = case cLabel cfg of+                     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++labelConfig :: (a -> String) -> Config a -> Config a+labelConfig f config = config { cLabel = Just f }++configHasLabel :: Config a -> Bool+configHasLabel Cfg { cLabel = Nothing } = False+configHasLabel _ = True++configLabel :: Config a -> a -> String+configLabel Cfg { cLabel = Just f } st = f st+configLabel _ _ =+    error "tried to get a label from a config which has none"+
− src/Barrie/Config.lhs 
@@ -1,39 +0,0 @@-> {-# OPTIONS_GHC -XMultiParamTypeClasses -XFunctionalDependencies #-}--> module Barrie.Config where--> data Config a = Cfg {->            cEnabled :: a -> Bool,->            cLabel   :: Maybe (a -> String)->            }--> defaultConfig :: Config a-> defaultConfig = Cfg { cEnabled = const True, cLabel = Nothing }--> transformConfig :: (a -> b) -> Config b -> Config a-> transformConfig get cfg = cfg { cEnabled = cEnabled cfg . get,->                                 cLabel = label'->                               }->     where label' = case cLabel cfg of->                      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--> labelConfig :: (a -> String) -> Config a -> Config a-> labelConfig f config = config { cLabel = Just f }--> configHasLabel :: Config a -> Bool-> configHasLabel Cfg { cLabel = Nothing } = False-> configHasLabel _ = True--> configLabel :: Config a -> a -> String-> configLabel Cfg { cLabel = Just f } st = f st-> configLabel _ _ =->     error "tried to get a label from a config which has none"-
+ src/Barrie/DrawPrimitive.hs view
@@ -0,0 +1,131 @@+module Barrie.DrawPrimitive+    (DrawFunction, Picture, Colour,+     background,+     setForeground,+     lineTo, moveTo, line, lineWidth, move, rectangle, polygon,+     multiLine, circle,+     image, showText,+     black, white, fromRGB,+     doDraw)+    where++import qualified Graphics.UI.Gtk as Gtk++type Picture = Gtk.Pixmap++data Colour = RGB Int Int Int deriving (Eq)++black, white :: Colour+black = fromRGB 0 0 0+white = fromRGB 65535 65535 65535++data DrawPrimitive = Background Colour+                   | SetForeground Colour+                   | SetLineThickness Int+                   | Line Int Int+                   | LineTo Int Int+                   | LineWidth Int+                   | Move Int Int+                   | MoveTo Int Int+                   | Polygon Bool [(Int, Int)]+                   | Circle Bool Int+                   | Rectangle Bool Int Int+                   | ShowText String+                   | Image String+                     deriving (Eq)++type DrawFunction = [DrawPrimitive] -> [DrawPrimitive]++background :: Colour -> DrawFunction+lineTo, moveTo, line, move :: Int -> Int -> DrawFunction+lineWidth :: Int -> DrawFunction+rectangle :: Bool -> Int -> Int -> DrawFunction+polygon :: Bool -> [(Int, Int)] -> DrawFunction+circle :: Bool -> Int -> DrawFunction+showText :: String -> DrawFunction+image :: String -> DrawFunction+multiLine :: [(Int,Int)] -> DrawFunction+setForeground :: Colour -> DrawFunction++background colour xs = Background colour : xs+lineTo x y xs = LineTo x y : xs+moveTo x y xs = MoveTo x y : xs+line x y xs = Line x y : xs+lineWidth w xs = LineWidth w : xs+move x y xs = Move x y : xs+rectangle filled width height xs = Rectangle filled width height : xs+polygon filled pts xs = Polygon filled pts : xs+circle filled r xs = Circle filled r : xs+showText text xs = ShowText text : xs+image pic = (:) (Image pic)++multiLine [] = id+multiLine ((x, y):pts) = moveTo x y . foldl (.) id (map (uncurry lineTo) pts)++setForeground col xs = SetForeground col : xs++fromRGB :: Int -> Int -> Int -> Colour+fromRGB = RGB++toGtkColour :: Colour -> IO Gtk.Color+toGtkColour (RGB r g b) = return $ Gtk.Color (cvt r) (cvt g) (cvt b)+                                     where cvt = fromInteger . toInteger++doDraw :: Gtk.Pixmap+       -> Gtk.GC+       -> Gtk.PangoContext+       -> (Int,Int)+       -> [DrawPrimitive]+       -> IO ()+doDraw _ _ _ _ [] = return ()+doDraw win gc context (x,y) (p:ps) = do (newP,newGC) <- drawPrimitive p+                                        doDraw win newGC context newP ps+    where noChange = return ((x,y),gc)+          drawPrimitive (MoveTo x' y') = return ((x', y'), gc)+          drawPrimitive (Move dx dy)   = return ((x + dx, y + dy), gc)+          drawPrimitive (LineTo x' y') = do+            Gtk.drawLine win gc (x,y) (x',y')+            return ((x',y'), gc)+          drawPrimitive (Line dx dy) = do+            let (x',y') = (x + dx, y + dy)+            Gtk.drawLine win gc (x,y) (x', y')+            return ((x',y'), gc)+          drawPrimitive (LineWidth w) = do+            Gtk.gcSetValues gc Gtk.newGCValues { Gtk.lineWidth = w }+            return ((x,y), gc)+          drawPrimitive (Rectangle filled width height) = do+            Gtk.drawRectangle win gc filled x y width height+            noChange+          drawPrimitive (Polygon _ []) = noChange+          drawPrimitive (Polygon filled pts) = do+            Gtk.drawPolygon win gc filled pts+            return (last pts, gc)+          drawPrimitive (Circle filled r) = do+            Gtk.drawArc win gc filled (x - r) (y - r)+                   (r * 2) (r * 2) 0 (360 * 64)+            return ((x,y),gc)+          drawPrimitive (ShowText text) = do+            layout <- Gtk.layoutText context text+            layoutLine <- Gtk.layoutGetLine layout 0+            Gtk.drawLayoutLine win gc x y layoutLine+            return ((x,y),gc)+          drawPrimitive (SetForeground colour) = do+            col <- toGtkColour colour+            Gtk.gcSetValues gc $ Gtk.newGCValues {+              Gtk.foreground = col+              }+            return ((x,y),gc)+          drawPrimitive (Background colour) = do+            backgc <- Gtk.gcNew win+            gtkColour <- toGtkColour colour+            Gtk.gcSetValues backgc Gtk.newGCValues {+              Gtk.foreground = gtkColour+            }+            (width, height) <- Gtk.drawableGetSize win+            Gtk.drawRectangle win backgc True 0 0 width height+            Gtk.drawRectangle win backgc False 0 0 width height+            return ((x,y),gc)+          drawPrimitive (Image pic) = do+            pb <- Gtk.pixbufNewFromFile pic+            Gtk.drawPixbuf win gc pb 0 0 x y (-1) (-1) Gtk.RgbDitherNormal 0 0+            return ((x,y),gc)
− src/Barrie/DrawPrimitive.lhs 
@@ -1,131 +0,0 @@-> module Barrie.DrawPrimitive->     (DrawFunction, Picture, Colour,->      background,->      setForeground,->      lineTo, moveTo, line, lineWidth, move, rectangle, polygon,->      multiLine, circle,->      image, showText,->      black, white, fromRGB,->      doDraw)->     where--> import qualified Graphics.UI.Gtk as Gtk--> type Picture = Gtk.Pixmap--> data Colour = RGB Int Int Int deriving (Eq)--> black, white :: Colour-> black = fromRGB 0 0 0-> white = fromRGB 65535 65535 65535--> data DrawPrimitive = Background Colour->                    | SetForeground Colour->                    | SetLineThickness Int->                    | Line Int Int->                    | LineTo Int Int->                    | LineWidth Int->                    | Move Int Int->                    | MoveTo Int Int->                    | Polygon Bool [(Int, Int)]->                    | Circle Bool Int->                    | Rectangle Bool Int Int->                    | ShowText String->                    | Image String->                      deriving (Eq)--> type DrawFunction = [DrawPrimitive] -> [DrawPrimitive]--> background :: Colour -> DrawFunction-> lineTo, moveTo, line, move :: Int -> Int -> DrawFunction-> lineWidth :: Int -> DrawFunction-> rectangle :: Bool -> Int -> Int -> DrawFunction-> polygon :: Bool -> [(Int, Int)] -> DrawFunction-> circle :: Bool -> Int -> DrawFunction-> showText :: String -> DrawFunction-> image :: String -> DrawFunction-> multiLine :: [(Int,Int)] -> DrawFunction-> setForeground :: Colour -> DrawFunction--> background colour xs = Background colour : xs-> lineTo x y xs = LineTo x y : xs-> moveTo x y xs = MoveTo x y : xs-> line x y xs = Line x y : xs-> lineWidth w xs = LineWidth w : xs-> move x y xs = Move x y : xs-> rectangle filled width height xs = Rectangle filled width height : xs-> polygon filled pts xs = Polygon filled pts : xs-> circle filled r xs = Circle filled r : xs-> showText text xs = ShowText text : xs-> image pic = (:) (Image pic)--> multiLine [] = id-> multiLine ((x, y):pts) = moveTo x y . foldl (.) id (map (uncurry lineTo) pts)--> setForeground col xs = SetForeground col : xs--> fromRGB :: Int -> Int -> Int -> Colour-> fromRGB = RGB--> toGtkColour :: Colour -> IO Gtk.Color-> toGtkColour (RGB r g b) = return $ Gtk.Color (cvt r) (cvt g) (cvt b)->                                      where cvt = fromInteger . toInteger--> doDraw :: Gtk.Pixmap->        -> Gtk.GC->        -> Gtk.PangoContext->        -> (Int,Int)->        -> [DrawPrimitive]->        -> IO ()-> doDraw _ _ _ _ [] = return ()-> doDraw win gc context (x,y) (p:ps) = do (newP,newGC) <- drawPrimitive p->                                         doDraw win newGC context newP ps->     where noChange = return ((x,y),gc)->           drawPrimitive (MoveTo x' y') = return ((x', y'), gc)->           drawPrimitive (Move dx dy)   = return ((x + dx, y + dy), gc)->           drawPrimitive (LineTo x' y') = do->             Gtk.drawLine win gc (x,y) (x',y')->             return ((x',y'), gc)->           drawPrimitive (Line dx dy) = do->             let (x',y') = (x + dx, y + dy)->             Gtk.drawLine win gc (x,y) (x', y')->             return ((x',y'), gc)->           drawPrimitive (LineWidth w) = do->             Gtk.gcSetValues gc Gtk.newGCValues { Gtk.lineWidth = w }->             return ((x,y), gc)->           drawPrimitive (Rectangle filled width height) = do->             Gtk.drawRectangle win gc filled x y width height->             noChange->           drawPrimitive (Polygon _ []) = noChange->           drawPrimitive (Polygon filled pts) = do->             Gtk.drawPolygon win gc filled pts->             return (last pts, gc)->           drawPrimitive (Circle filled r) = do->             Gtk.drawArc win gc filled (x - r) (y - r)->                    (r * 2) (r * 2) 0 (360 * 64)->             return ((x,y),gc)->           drawPrimitive (ShowText text) = do->             layout <- Gtk.layoutText context text->             layoutLine <- Gtk.layoutGetLine layout 0->             Gtk.drawLayoutLine win gc x y layoutLine->             return ((x,y),gc)->           drawPrimitive (SetForeground colour) = do->             col <- toGtkColour colour->             Gtk.gcSetValues gc $ Gtk.newGCValues {->               Gtk.foreground = col->               }->             return ((x,y),gc)->           drawPrimitive (Background colour) = do->             backgc <- Gtk.gcNew win->             gtkColour <- toGtkColour colour->             Gtk.gcSetValues backgc Gtk.newGCValues {->               Gtk.foreground = gtkColour->             }->             (width, height) <- Gtk.drawableGetSize win->             Gtk.drawRectangle win backgc True 0 0 width height->             Gtk.drawRectangle win backgc False 0 0 width height->             return ((x,y),gc)->           drawPrimitive (Image pic) = do->             pb <- Gtk.pixbufNewFromFile pic->             Gtk.drawPixbuf win gc pb 0 0 x y (-1) (-1) Gtk.RgbDitherNormal 0 0->             return ((x,y),gc)
+ src/Barrie/Gadgets.hs view
@@ -0,0 +1,321 @@+module Barrie.Gadgets (Gadget, Behaviour,+                       displayG, editorG, commandG, sectionG,+                       chooserG, enumChooserG, chooseEqG, childG,+                       gadgetDisplay, gadgetUpdate, gadgetCommand,+                       gadgetChooser, gadgetChild,+                       findGadget, gadgetName, flatName,+                       gadgetConfig, gadgetEnabled, enabled, dynamicLabel,+                       gadgets, abstract,+                       createLayout)+where++import Control.Monad++import Data.Dynamic+import Data.List+import Data.Maybe+import Data.Typeable++import Barrie.Config+import Barrie.Style+import Barrie.Widgets++data Gadget a = G { gadgetName     :: [String],+                    gadgetConfig   :: Config a,+                    gadgetElement  :: Maybe (Element a),+                    gadgetInner    :: Maybe (Interface a),+                    gadgetLayout   :: AutoLayoutFunction a,+                    gadgetChildren :: [Gadget a]+                  }++data AutoLayout = AL { alDirection :: LayoutDirection,+                       alEditable  :: Bool,+                       alNames     :: [String]+                     }++instance (Typeable a) => Typeable (Gadget a) where+    typeOf g = mkTyConApp (mkTyCon "Barrie.Gadgets.Gadget")+                          [typeOf (elementType (fromJust (gadgetElement g)))]++data Element a = E { elementType      :: TypeRep,+                     elementGet       :: a -> Dynamic,+                     elementSet       :: Dynamic -> a -> a,+                     elementChoices   :: Maybe (a -> [(Dynamic, 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]++data Behaviour a = B [Gadget a]++flatName :: Gadget a -> String+flatName = intercalate "." . gadgetName++mkGadget :: String -> Element a -> Gadget a+mkGadget name e = G [name] defaultConfig (Just e) Nothing boxLayout []++mkElement :: (Typeable b) =>+             (a -> b)+          -> (b -> a -> a)+          -> Element a+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))+                     Just v  -> v+          tyrep = typeOf (get undefined)++updateElement :: (Element a -> Element a) -> Gadget a -> Gadget a+updateElement update g = case gadgetElement g of+                           Nothing -> g+                           Just e  -> g { gadgetElement = Just $ update e }++renderWith :: (Dynamic -> Dynamic) -> Gadget a -> Gadget a+renderWith r = updateElement (\ e -> e { elementRender = r })++setChoices :: (a -> [(Dynamic, 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 }++displayG :: (Typeable b) => String -> (a -> b) -> Gadget a+displayG name get = autoLayout (typeableLayout (typeOf $ get undefined)) $+                       mkGadget name (mkElement get (\ _ st -> st))++editorG :: (Typeable b) => String -> (a -> b) -> (b -> a -> a) -> Gadget a+editorG name get set = autoLayout (typeableLayout (typeOf $ get undefined)) $+                            mkGadget name (mkElement get set)++commandG :: String -> (a -> a) -> Gadget a+commandG name update = autoLayout buttonLayout $+                          mkGadget name (mkElement (const ()) (\ () -> update))++sectionG :: String -> [Gadget a] -> Gadget a+sectionG name gs = G [name] defaultConfig Nothing Nothing boxLayout gs++childG :: String            -- ^ gadget name+       -> (a -> b)          -- ^ get child state+       -> (b -> a -> a)     -- ^ update parent state with child state+       -> Gadget b          -- ^ child gadget+       -> Gadget a+childG name get set child =+   G { gadgetName     = [name],+       gadgetConfig   = defaultConfig,+       gadgetElement  = Nothing,+       gadgetInner    = Just $ IF $ transform get set child,+       gadgetLayout   = boxLayout,+       gadgetChildren = []+     }++transform :: (a -> b) -> (b -> a -> a) -> Gadget b -> Gadget a+transform get set g =+    G { gadgetName     = gadgetName g,+        gadgetConfig   = transformConfig get (gadgetConfig g),+        gadgetElement  = liftM (transformE get set) (gadgetElement g),+        gadgetInner    = liftM (transformI 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),+                           elementChoices = xfchoices (elementChoices e)+                         }+   where xfset setb = (\ v st -> set (setb v (get st)) st)+         xfchoices Nothing      = Nothing+         xfchoices (Just getcs) = Just $ getcs . get++-- |A gadget that offers a choice between alternatives.  This function+-- creates a gadget that expects an Int representing the index of the+-- chosen item from the state.  If it's more convenient to supply the+-- actual chosen value, use chooseEqG instead.++chooserG :: (Typeable b) =>+            String+         -> (a -> Int)+         -> (b -> a -> a)+         -> (a -> [b])+         -> Gadget a+chooserG name get set getChoices =+    autoLayout chooserLayout $ setChoices choices $ editorG name get' set'+        where get' st = (choices st, get st)+              set' (vs, 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++enumChooserG :: (Enum b, Bounded b, Read b, Show b) =>+                String+             -> (a -> b)+             -> (b -> a -> a)+             -> Gadget a+enumChooserG name get set =+    autoLayout enumLayout $+    setChoices elems $ renderWith toStr $ 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))++chooseEqG :: (Typeable b, Eq b) =>+             String+         -> (a -> b)+         -> (b -> a -> a)+         -> (a -> [b])+         -> Gadget a+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++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)++-- |Gadgets can change their properties based on the value of their state.+-- Currently, the following configurations are implemented:++-- |dynamicLabel: for write-only gadgets like Command, this can add+-- some state read functionality.  It is interpreted by the+-- renderer.++-- |enabled: a function on the state returning Bool.  If False, the+-- gadget is disabled in some widget- or renderer-specific way+-- (e.g. dimmed, hidden).++addConfig :: (Config a -> Config a) -> Gadget a -> Gadget a+addConfig f g = g { gadgetConfig = f (gadgetConfig g) }++enabled :: (a -> Bool) -> Gadget a -> Gadget a+enabled f = addConfig (enabledCfg f)++gadgetEnabled :: Gadget a -> a -> Bool+gadgetEnabled = isEnabled . gadgetConfig++dynamicLabel :: (a -> String) -> Gadget a -> Gadget a+dynamicLabel f = addConfig (labelConfig f)++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++gadgets :: Gadget a -> Behaviour a+gadgets = B . walk [] getGadget+     where getGadget name g = [g { gadgetName = name }]++abstract :: Gadget a -> [String]+abstract = map flatName . walk [] (\ name g -> [g { gadgetName = name }])++gadgetCommand :: Gadget a -> a -> a+gadgetCommand G { gadgetElement = Just e } = elementSet e (toDyn ())+gadgetCommand _ = id++gadgetDisplay :: Gadget a -> a -> Dynamic+gadgetDisplay G { gadgetElement = Just e } = elementGet e+gadgetDisplay g = error $ "Can't connect a display to empty gadget " +++                          flatName g++gadgetUpdate :: Gadget a -> Dynamic -> a -> a+gadgetUpdate G { gadgetElement = Just e } = elementSet e+gadgetUpdate g = error $ "Can't connect an update to empty gadget " +++                          flatName g++gadgetChooser :: Gadget a -> a -> [(Dynamic, Dynamic)]+gadgetChooser g = case getChoices of+                    Nothing -> error $ "Can't connect a chooser to gadget " +++                                       flatName g+                    Just get -> get+    where getChoices = gadgetElement g >>= elementChoices++gadgetChild :: Gadget a -> Gadget a+gadgetChild g = case gadgetInner g of+                  Just (IF child) -> child+                  Nothing         -> error $ "Gadget " ++ flatName g +++                                             " has no inner child"++startLayout :: AutoLayout+startLayout = AL { alDirection = Vertical,+                   alEditable  = False,+                   alNames     = []+                 }++editableLayout :: AutoLayout -> AutoLayout+editableLayout al = al { alEditable = True }++type AutoLayoutFunction a = AutoLayout -> [Gadget a] -> Widget++boxLayout :: AutoLayoutFunction a+boxLayout al = boxLayout' . map (createLayout' al')+    where (boxLayout', al') =+              case alDirection al of+                Vertical   -> (vbox, al { alDirection = Horizontal })+                Horizontal -> (hbox, al { alDirection = Vertical })+++textLayout :: AutoLayoutFunction a+textLayout = \ al _ -> case alEditable al of+                           True -> textBox+                           False -> textLabel ""++intLayout :: Int -> Int -> AutoLayoutFunction a+intLayout lo hi = \ al _ -> case alEditable al of+                              True -> slider (alDirection al) lo hi 1+                              False -> textLabel ""++boolLayout :: AutoLayoutFunction a+boolLayout = \ _ _ -> checkButton++buttonLayout :: AutoLayoutFunction a+buttonLayout = \ al _ -> caption (last (alNames al)) $ button []++enumLayout :: AutoLayoutFunction a+enumLayout = chooserLayout++chooserLayout :: AutoLayoutFunction a+chooserLayout = \ _ _ -> listView++typeableLayout :: TypeRep -> AutoLayoutFunction a+typeableLayout t = case filter ((t==) . fst) typeableLayouts of+                     []      -> textLayout+                     layouts -> snd (head layouts)+    where typeableLayouts = [(typeOf (1::Int), intLayout 0 999),+                             (typeOf False, boolLayout)]++createLayout :: Gadget a -> Widget+createLayout = createLayout' startLayout++createLayout' :: AutoLayout -> Gadget a -> Widget+createLayout' layout g =+    ui' nm $ gadgetLayout g layout' (gadgetChildren g)+        where nm = alNames layout ++ gadgetName g+              layout' = layout { alNames = nm }
− src/Barrie/Gadgets.lhs 
@@ -1,383 +0,0 @@-> module Barrie.Gadgets (Gadget, Behaviour,->                        findGadget, gadgets, abstract, gadgetName,->                        commandG,->                        displayG, displayG', textDisplayG,->                        editorG, editorG', textEditorG,->                        chooserG, chooserG', textChooserG, enumChooserG,->                        localG, innerG,->                        enabled, gadgetEnabled, dynamicLabel,->                        gadgetConfig,->                        connectChooserDisplay,->                        connectDisplayGadget,->                        connectEditorGadget,->                        connectCommandGadget,->                        connectInnerGadget->                       ) where--> import Data.List-> import Control.Monad--> import Barrie.AbstractGadgets-> import Barrie.Config-> import Barrie.Trace--> data Behaviour a = B [Gadget a]--> -- |A gadget is a piece of user interface functionality (as opposed-> -- to a widget, which is a piece of user interface rendering).--> data Gadget a = G { gFullName :: [String],->                     gConfig   :: Config a,->                     gElement  :: Element a->                   }--> -- |The semantics of a gadget are defined by its Element.-> -- Internally, all element manipulation is perform via conversions-> -- to and from String, which is a shame, but there it is.-> -- It is not beyond the bounds of possibility that existential types-> -- are a solution to this problem, but for now, this is where we-> -- are.  The exported constructor functions hide this wart, to some-> -- extent (e.g. you can use showG for an instance of Show, or-> -- showG' to supply your own show function).--> -- |An element comes in five flavours:--> -- |Display: presents a value to the user.  For example: labels,-> -- |read-only text boxes, check boxes, radio buttons -- anything-> -- |with a simple display.--> -- |Editor: a display that can edit, such as a text box, a check-> -- |box, or a slider.--> -- |Command: a gadget that updates the state, sort of like a-> -- |write-only Editor for type (), where the only thing you know is-> -- |that it's been activated (so the () argument can be dropped).-> -- |Can be rendered with buttons, menu items, that sort of thing.--> -- |Chooser: like displays and editors, but the values come from a-> -- |restricted set of possiblities.  The value is a Maybe String,-> -- |because it's possible (and often reasonable) to not choose-> -- |anything.--> -- |Inner: a single gadget placed inside another one.  Used to-> -- |construct nested and pop-up gadgets.--> -- |Local: gadgets nested inside another one.  Sort of a superclass-> -- |of Inner, but it's not possible to make a pop-up out of them.-> -- |Used to structure gadgets (functionally, not in terms of-> -- |layout).--> -- |Constructor functions are used to create gadgets, which is how-> -- |we pretend we're not dealing with Strings only.  In general, for-> -- |a gadget flavour F with signature SF a b, we have:--> -- | fG :: (Show b, Read b) => String -> SF a b -> Gadget a-> -- | textFG :: String -> SF a String -> Gadget a-> -- | fG' :: (b -> String) -> (String -> b) -> SF a b -> Gadget a--> -- |fG uses the built-in Read and Show to perform the conversions-> -- |fStrG uses id for read and show-> -- |fG' allows them to be specified.--> -- |Display gadgets don't need the Read instance (or the-> -- |corresponding function), and Command gadgets don't need either-> -- |instance (so we have commandG but not commandG')--> data Element a = Display (a -> String)->                | Editor  (a -> String) (String -> a -> a)->                | Command (a -> a)->                | Chooser (a -> Maybe String)->                          (String -> a -> a) (a -> [String])->                | Inner (Gadget a)->                | Local [Gadget a]---> --  data InnerElement a = forall b. InnerE (a -> b) (b -> a -> a) (Gadget b)--> -- |Returns the name of the gadget.  Internally (and-> -- slightly externally), the name of a gadget is a list of Strings-> -- containing the full path from the top to the gadget.  This is-> -- converted to a '.'-separated String.--> gadgetName :: Gadget a -> String-> gadgetName = intercalate ['.'] . gFullName--> -- |Create a command gadget--> commandG :: String -> (a -> a) -> Gadget a-> commandG name f = G [name] defaultConfig (Command f)--> -- |Create a display gadget--> displayG :: (Show b) => String -> (a -> b) -> Gadget a-> displayG = displayG' show--> textDisplayG :: String -> (a -> String) -> Gadget a-> textDisplayG = displayG' id--> displayG' :: (b -> String) -> String -> (a -> b) -> Gadget a-> displayG' toString name get = G [name] defaultConfig->                                  (Display (toString . get))--> -- |editorG allows a gadget to show and edit part of the state.--> editorG' :: (b -> String)   -- ^ toString: convert to string->          -> (String -> b)   -- ^ fromString: convert from String->          -> String          -- ^ gadget name->          -> (a -> b)        -- ^ get value from state->          -> (b -> a -> a)   -- ^ update state->          -> Gadget a--> editorG' toString fromString name get set =->     G [name] defaultConfig (Editor (toString . get) (set . fromString))--> editorG :: (Show b, Read b) =>->            String          -- ^ gadget name->         -> (a -> b)        -- ^ get value from state->         -> (b -> a -> a)   -- ^ update state->         -> Gadget a--> editorG = editorG' show read--> textEditorG :: String               -- ^ gadget name->             -> (a -> String)        -- ^ get value from state->             -> (String -> a -> a)   -- ^ update state->             -> Gadget a--> textEditorG = editorG' id id-->-> -- |localG does not perform any state transformation directly, but-> -- can be used to structure a gadget tree.--> localG :: String -> [Gadget a] -> Gadget a-> localG name gs = G [name] defaultConfig (Local gs)---> -- |chooserG--> chooserG' :: (b -> String)        -- ^ toString: convert to string->           -> (String -> b)        -- ^ fromString: convert from String->           -> String               -- ^ the name of the chooser gadget->           -> (a -> Maybe b)       -- ^ current selected value->           -> (b -> a -> a)        -- ^ update the state with a new value->           -> (a -> [b])           -- ^ list of available choices->           -> Gadget a-> chooserG' toString fromString name get set elems =->     G [name] defaultConfig->              (Chooser (liftM toString . get) (set . fromString)->                       (map toString . elems))--> chooserG  :: (Read b, Show b) =>->              String               -- ^ the name of the chooser gadget->           -> (a -> Maybe b)       -- ^ current selected value->           -> (b -> a -> a)        -- ^ update the state with a new value->           -> (a -> [b])           -- ^ list of available choices->           -> Gadget a--> chooserG = chooserG' show read---> textChooserG :: String               -- ^ the name of the chooser gadget->              -> (a -> Maybe String)  -- ^ current selected value->              -> (String -> a -> a)   -- ^ update the state with a new value->              -> (a -> [String])      -- ^ list of available choices->              -> Gadget a--> textChooserG = chooserG' id id--> -- A convenient way to create a choice from a bounded enum.--> enumChooserG :: (Enum b, Read b, Show b) =>->                 String->              -> (a -> Maybe b)->              -> (b -> a -> a)->              -> Gadget a-> enumChooserG name get set = chooserG' show read name get set->                                       (const [toEnum 0 ..])--> innerG :: String -> (a -> b) -> (b -> a -> a) -> Gadget b -> Gadget a-> innerG name get set gadget = G [name] defaultConfig (Inner launch)->     where launch = transform get set gadget--> transform :: (a -> b) -> (b -> a -> a) -> Gadget b -> Gadget a-> transform get set (G name config elmt) =->     G name (transformConfig get config) (transformE get set elmt)--> transformE :: (a -> b) -> (b -> a -> a) -> Element b -> Element a-> transformE get set = xform->    where xform (Display getb) = Display (getb . get)->          xform (Editor getb setb) = Editor (getb . get) (xfset setb)->          xform (Command update) =->                       Command (\ st -> set (update (get st)) st)->          xform (Chooser getb setb getvs) =->                       Chooser (getb . get) (xfset setb)->                               (getvs . get)->          xform (Inner g)  = Inner (transform get set g)->          xform (Local gs) = Local (map (transform get set) gs)->          xfset setb = (\ v st -> set (setb v (get st)) st)---> -- |Gadgets can change their properties based on the value of their state.-> -- Currently, the following configurations are implemented:--> -- dynamicLabel: for write-only gadgets like Command, this can add-> -- some state read functionality.  It is interpreted by the-> -- renderer.--> -- enabled: a function on the state returning Bool.  If False, the-> -- gadget is disabled in some widget- or renderer-specific way-> -- (e.g. dimmed, hidden).--> addConfig :: (Config a -> Config a) -> Gadget a -> Gadget a-> addConfig f g = g { gConfig = f (gConfig g) }--> enabled :: (a -> Bool) -> Gadget a -> Gadget a-> enabled f = addConfig (enabledCfg f)--> dynamicLabel :: (a -> String) -> Gadget a -> Gadget a-> dynamicLabel f = addConfig (labelConfig f)--> gadgetConfig :: Gadget a -> (Config a -> b) -> b-> gadgetConfig gadget config = config $ gConfig gadget--> gadgetEnabled :: Gadget a -> a -> Bool-> gadgetEnabled g = gadgetConfig g isEnabled--> findGadget :: [String] -> Behaviour a -> Maybe (Gadget a)-> findGadget name (B gs) =->     case filter (match name) gs of->              []  -> Nothing->              g:_ -> Just g->     where match name1 (G name2 _ _) =->                       not (null name1) &&->                       isPrefixOf (reverse name1) (reverse name2)--> type Fetch a = a -> String-> type Update a = String -> a -> a--> gadgetEditor :: Gadget a -> (Fetch a, Update a)-> gadgetEditor (G _ _ (Editor get set)) = (get, set)-> gadgetEditor (G _ _ (Chooser get set _ )) = (maybe "" id . get, set)-> gadgetEditor g = error $ "Can't connect an editor to gadget '" ++->                          gadgetName g ++ "'"--> gadgetChooser :: Gadget a -> (a -> [String], Fetch a)-> gadgetChooser (G _ _ (Chooser get _ elems)) = (elems, maybe "" id . get)-> gadgetChooser g = error $ "Can't connect a chooser to gadget '" ++->                          gadgetName g ++ "'"--> gadgetDisplay :: Gadget a -> Fetch a-> gadgetDisplay (G _ _ (Display get)) = get-> gadgetDisplay (G _ _ (Editor get _)) = get-> gadgetDisplay (G _ _ (Chooser get _ _)) = (maybe "" id . get)-> gadgetDisplay g = error $ "Can't connect a display to gadget '" ++->                          gadgetName g ++ "'\n" ++ show (abstract g)--> gadgetCommand :: Gadget a -> (a -> a)-> gadgetCommand (G _ _ (Command update)) = update-> gadgetCommand g = error $ "Can't connect a command to gadget '" ++->                          gadgetName g ++ "'"--> gadgetInner :: Gadget a -> Gadget a-> gadgetInner (G _ _ (Inner g)) = g-> gadgetInner g = error $ "Can't connect a inner to gadget '" ++->                            gadgetName g ++ "'\n" ++ show (abstract g)---> connectEditorGadget :: (IO () -> IO ())  -- ^ connection creator->                     -> IO a              -- ^ gui state retriever->                     -> IO String         -- ^ gadget value retriever->                     -> Maybe (Gadget a)  -- ^ optional gadget->                     -> (a -> IO ())      -- ^ state change applier->                     -> IO ()--> connectEditorGadget onAction getState gadgetValue gadget apply = do->    let connectEditor get set = onAction (do st   <- getState->                                             curr <- gadgetValue->                                             when (get st /= curr) $ do->                                               apply $ set curr st)->    case liftM gadgetEditor gadget of->       Nothing        -> return ()->       Just (get,set) -> connectEditor get set---> connectChooserDisplay :: ([String] -> IO ())->                       -> (Int -> IO ())->                       -> Maybe (Gadget a)->                       -> a -> IO ()-> connectChooserDisplay setChoices setValue gadget = do->    let update getChoices get st = (do->               let choices = getChoices st->                   value   = get st->               setChoices choices->               case elemIndex value choices of->                  Nothing -> setValue (-1)->                  Just index -> setValue index)->    case liftM gadgetChooser gadget of->      Nothing                -> \ _ -> return ()->      Just (getChoices, get) -> update getChoices get--> connectDisplayGadget :: (String -> IO ())   --  GUI element updater->                      -> Maybe (Gadget a)->                      -> a -> IO ()--> connectDisplayGadget update gadget = do->    let connectDisplay get =  update . get->    case liftM gadgetDisplay gadget of->       Nothing   -> \ _ -> return ()->       Just get  -> connectDisplay get--> connectCommandGadget :: (IO () -> IO ())  --  connection creator->                      -> IO a              --  state retriever->                      -> Maybe (Gadget a)->                      -> (a -> IO ())      --  state updater->                      -> IO ()-> connectCommandGadget onCommand getState gadget setState = do->    let connectCommand update = onCommand (do st   <- getState->                                              setState (update st))->    case liftM gadgetCommand gadget of->       Nothing     -> return ()->       Just update -> connectCommand update--> connectInnerGadget :: (IO () -> IO ())         --  launch connector->                       -> (Gadget a -> a -> IO a)  --  inner->                       -> IO a                     --  state retriever->                       -> Maybe (Gadget a)->                       -> (a -> IO ())             --  state updater->                       -> IO ()-> connectInnerGadget onLaunch inner getState gadget setState = do->    let connectInner g =->            onLaunch (do st <- getState->                         traceMessage $ "connecting: " ++->                                        gadgetName g->                         st' <- inner g st->                         traceMessage $ "finished: " ++ gadgetName g->                         setState st')->    case liftM gadgetInner gadget of->       Nothing -> return ()->       Just g  -> connectInner g--> walk :: [String] -> ([String] -> Gadget a -> [b]) -> Gadget a -> [b]-> walk prefix f gadget@(G nm _ e) =->     case e of->       (Local ws) -> f (prefix ++ nm) gadget ++->                       concatMap (walk (prefix ++ nm) f) ws->       (Inner w)  -> f (prefix ++ nm) gadget ++ walk (prefix ++ nm) f w->       _          -> f (prefix ++ nm) gadget---> abstract :: Gadget a -> [AbstractGadget]-> abstract = walk [] abstractElem->     where abstractElem name e = case gElement e of->                                   Display _     -> [alabel name]->                                   Editor _ _    -> [atext name]->                                   Command _     -> [acommand name]->                                   Chooser _ _ _ -> [achoice name]->                                   Inner _       -> [ainner name]->                                   Local _       -> [alocal name]--> gadgets :: Gadget a -> Behaviour a-> gadgets = B . walk [] getGadget->     where getGadget name (G _ cfg elmt) = [G name cfg elmt]-
+ src/Barrie/Gadgets/Connections.hs view
@@ -0,0 +1,68 @@+module Barrie.Gadgets.Connections (connectChooser,+                                   connectCommand,+                                   connectDisplay,+                                   connectEditor,+                                   connectChild) where++import Control.Monad++import Data.Dynamic++import Barrie.Gadgets+import Barrie.Trace++connectCommand :: (IO () -> IO ())    -- ^ connection creator+               -> IO a                -- ^ state retriever+               -> Gadget a            -- ^ gadget representing the command+               -> (a -> IO ())        -- ^ state updater+               -> IO ()+connectCommand onCommand getState gadget setState = do+   onCommand (getState >>= setState . gadgetCommand gadget)++connectDisplay :: (Dynamic -> IO ())  -- ^ GUI element updater+               -> Gadget a            -- ^ gadget representing the display+               -> a                   -- ^ new state+               -> IO ()+connectDisplay update gadget = update . gadgetDisplay gadget++connectEditor :: (IO () -> IO ())     -- ^ connection creator+              -> IO a                 -- ^ gui state retriever+              -> (Dynamic -> IO Bool) -- ^ true if update should happen+              -> IO Dynamic           -- ^ current value of GUI element+              -> Gadget a             -- ^ gadget representing the editor+              -> (a -> IO ())         -- ^ state change applier+              -> IO ()++connectEditor onAction getState doUpdate getValue gadget apply = do+   let connect get set = onAction (do st <- getState+                                      go <- doUpdate (get st)+                                      when go (do curr <- getValue+                                                  apply $ set curr st))+   connect (gadgetDisplay gadget) (gadgetUpdate gadget)++-- |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+               -> (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 =+          (setChoices (getChoices st) >>+           setValue (snd $ fromDyn (get st) ([(get st, get st)],-12)))+  update (gadgetChooser gadget) (gadgetDisplay gadget) (gadgetUpdate gadget)++connectChild :: (IO () -> IO ())         --  ^ show child+             -> (Gadget a -> a -> IO a)  --  ^ child runner+             -> IO a                     --  ^ parent state retriever+             -> Gadget a                 --  ^ parent+             -> (a -> IO ())             --  ^ parent state updater+             -> 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/Render.hs view
@@ -0,0 +1,122 @@+module Barrie.Render (RunnableGUI, RenderF,+                      updates, renderWidget,+                      renderText, renderBool, renderInt, renderDouble) where++import Data.Dynamic+import Data.List+import Data.Maybe++import Barrie.Gadgets+import Barrie.Style+import Barrie.Trace+import Barrie.Widgets++-- |RenderF is the type of rendering functions.  A rendering+-- function should be implmeneted for each backend.  Currently,+-- we have Gtk and IO.++type RenderF a b =  String            --  name of the gui element type+                 -> [RunnableGUI a b] --  children of this gui element+                 -> Style+                 -> Maybe (Gadget b)  --  corresponding implementation+                 -> Maybe Widget      --  possible popup+                 -> IO (RunnableGUI a b)++-- RunnableGUI is a type representing a rendered set of gadgets,+-- widgets, and styles.++-- A rendering function retuns a single RunnableGUI, which+-- represents the top level gui element.  Each of the inner+-- elements is also a RunnableGUI, and they are rendered in the+-- same way.  Anything that can be rendered can be used as a top+-- level element, either in the main application, or in a+-- pop-up.  Of course, this isn't enforced by this module, but+-- the RenderF functions should make sure it's true, because we+-- rely on it.++-- A RunnableGUI contains three fields.  First is the GUI, which+-- is of a type chosen by the renderer (e.g. Gtk uses+-- Gtk.Widget).  Second is an update from state function.  When+-- the state changes, this is called for each widget, causing it+-- to display according to the latest state.  Finally comes a+-- function which, give a function to extract state from IO+-- should call when the state is updated, which allows everything+-- else to be kept up to date.  The final field is a function+-- which, given a way of extracting the current state from IO,+-- and a way of putting it back, can update it via its gadget+-- functionality.++-- One will rightly point out that this is all very ugly and+-- procedural, but luckily, anybody using Barrie doesn't have to+-- worry about it.  It's the sewer of side-effects beneath the+--  cathedral of functional gui-ness.++type RunnableGUI gui state =+    (gui,                                    --  the GUI+     state -> IO (),                         --  update from state+     IO state -> (state -> IO ()) -> IO ())  --  state update function++-- The updates function extracts all the update functions from a+-- runnable gui.  This is convenient for the implementation of+-- renderers.++updates :: [RunnableGUI gui state] -> [state -> IO ()]+updates = map (\ (_, update, _) -> update)++-- A behaviour is just a flat list of gadgets.  Gadgets are defined+-- in a hierarchical way, but are flattened for rendering.++-- Note that the gadget hierarchy is only tangentially related to the+-- widget layout.  The hierarchy is intended to be a functional+-- grouping, although in practice it will often look similar to the+-- widget layout.++renderWidget :: Behaviour w -> Widget -> RenderF r w+             -> IO (RunnableGUI r w)+renderWidget behaviour widget render = go widget+    where --  go :: StyleSheet -> Layout -> RunnableGUI r w+          go w = do let elmt = widgetElementName w+                        style = widgetStyle w+                        gadget = findGadget (uiElementName w) behaviour+                    traceMessage ("rendering element: " ++ elmt);+                    traceMessage ("ui name = " +++                                  intercalate "." (uiElementName w))+                    traceMessage ("gadget = " +++                                  maybe "Nothing" flatName gadget)+                    ws <- mapM go $ widgetChildren w+                    render elmt ws style gadget (widgetPopupChild w)++getRenderer :: String -> [(TypeRep, Dynamic -> a)] -> Dynamic -> a+getRenderer nm known d =+   case filter ((ty==) . fst) known of+      []        -> error $ "can't render as " ++ nm ++ ": " ++ show d+      ((_,f):_) -> f d+    where ty = dynTypeRep d++renderText :: Dynamic -> String+renderText = getRenderer "text" knownTextTypes+    where knownTextTypes =+              [(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+    where knownBoolTypes = [(typeOf False, flip fromDyn False)+                           ]++renderInt :: Dynamic -> Int+renderInt = getRenderer "int" knownIntTypes+    where knownIntTypes =+              [(typeOf (0::Int), flip fromDyn 0)+              ,(typeOf (0::Double), round . flip fromDyn (0::Double))+              ]++renderDouble :: Dynamic -> Double+renderDouble = getRenderer "double" knownDoubleTypes+    where knownDoubleTypes =+              [(typeOf (0::Double), flip fromDyn 0)+              ,(typeOf (0::Int), realToFrac . flip fromDyn (0::Int))+              ]+
− src/Barrie/Render.lhs 
@@ -1,86 +0,0 @@-> module Barrie.Render where--> import Data.List-> import Data.Maybe--> import Barrie.Gadgets-> import Barrie.Style-> import Barrie.Trace-> import Barrie.Widgets--        RenderF is the type of rendering functions.  A rendering-        function should be implmeneted for each backend.  Currently,-        we have Gtk and IO.--> type RenderF a b =  String            --  name of the gui element type->                  -> [RunnableGUI a b] --  children of this gui element->                  -> Style->                  -> Maybe (Gadget b)  --  corresponding implementation->                  -> Maybe Widget      --  possible popup->                  -> IO (RunnableGUI a b)--        RunnableGUI is a type representing a rendered set of gadgets,-        widgets, and styles.--        A rendering function retuns a single RunnableGUI, which-        represents the top level gui element.  Each of the inner-        elements is also a RunnableGUI, and they are rendered in the-        same way.  Anything that can be rendered can be used as a top-        level element, either in the main application, or in a-        pop-up.  Of course, this isn't enforced by this module, but-        the RenderF functions should make sure it's true, because we-        rely on it.--        A RunnableGUI contains three fields.  First is the GUI, which-        is of a type chosen by the renderer (e.g. Gtk uses-        Gtk.Widget).  Second is an update from state function.  When-        the state changes, this is called for each widget, causing it-        to display according to the latest state.  Finally comes a-        function which, give a function to extract state from IO-        should call when the state is updated, which allows everything-        else to be kept up to date.  The final field is a function-        which, given a way of extracting the current state from IO,-        and a way of putting it back, can update it via its gadget-        functionality.--        One will rightly point out that this is all very ugly and-        procedural, but luckily, anybody using Barrie doesn't have to-        worry about it.  It's the sewer of side-effects beneath the-        cathedral of functional gui-ness.--> type RunnableGUI gui state =->     (gui,                                    --  the GUI->      state -> IO (),                         --  update from state->      IO state -> (state -> IO ()) -> IO ())  --  state update function---    The updates function extracts all the update functions from a-    runnable gui.  This is convenient for the implementation of-    renderers.--> updates :: [RunnableGUI gui state] -> [state -> IO ()]-> updates = map (\ (_, update, _) -> update)--    A behaviour is just a flat list of gadgets.  Gadgets are defined-    in a hierarchical way, but are flattened for rendering.--    Note that the gadget hierarchy is only tangentially related to the-    widget layout.  The hierarchy is intended to be a functional-    grouping, although in practice it will often look similar to the-    widget layout.--> renderWidget :: Behaviour w -> Widget -> RenderF r w->              -> IO (RunnableGUI r w)-> renderWidget behaviour widget render = go widget->     where --  go :: StyleSheet -> Layout -> RunnableGUI r w->           go w = do let elmt = widgetElementName w->                         style = widgetStyle w->                         gadget = findGadget (uiElementName w) behaviour->                     traceMessage ("rendering element: " ++ elmt);->                     traceMessage ("ui name = " ++->                                   intercalate "." (uiElementName w))->                     traceMessage ("gadget = " ++->                                   maybe "Nothing" (gadgetName) gadget)->                     ws <- mapM go $ widgetChildren w->                     render elmt ws style gadget (widgetPopupChild w)-
+ src/Barrie/Render/Gtk.hs view
@@ -0,0 +1,449 @@+module Barrie.Render.Gtk (gtkMain, initGtk, renderGtk, runGtk) where++import Data.Dynamic++import qualified Graphics.UI.Gtk as Gtk+import System.Glib.Attributes++import Control.Monad++-- IORefs are Barrie's dirty little secret.  There are three: one is+-- for saving a global state that the GUI works with, the other two+-- save the contents of lists and choosers, so that we don't update+-- them more than necessary.++import Data.IORef++-- We import approximately everything++import Barrie.Config+import Barrie.Render+import Barrie.Style+import Barrie.Gadgets+import Barrie.Gadgets.Connections+import Barrie.Trace+import Barrie.Widgets+++-- |The rendering model is defined by the RenderF type in the+-- Barrie.Render module.  Implementations of the renderer provide+-- a type which describes the GUI.  In this case, it's just a+-- Gtk.Widget.++type GtkGUI = Gtk.Widget++-- All rendering functions in this module use the following type+-- GtkRenderFn.++-- It is a function from:+--   -  a list of child guis (i.e. widgets inside the one being rendered)+--   -  a style+--   -  an optional gadget, which will be connected to the+--      rendered widget if present.+-- It returns a runnable GUI.++type GtkRenderFn a = [RunnableGUI GtkGUI a]+                   -> Style+                   -> 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+-- harmless).++gtkMain :: Gadget a -> Widget -> a -> IO a+gtkMain gadget widget state = do+  initGtk+  gui <- renderWidget (gadgets gadget) widget renderGtk+  runGtk gui state False+++initGtk :: IO ()+initGtk = do Gtk.initGUI+             return ()++renderGtk :: RenderF GtkGUI a+renderGtk nm gs style gadget popupChild = do+  let rendererList = case popupChild of+                        Nothing -> renderers+                        Just w  -> map (\ (x,y) -> (x, y w)) popupRenderers+  case lookup nm rendererList of+    Nothing -> error $ "rendering element '" ++ nm ++ "' not found"+    Just r  -> r gs style gadget++runGtk :: RunnableGUI GtkGUI a -> a -> Bool -> IO a+runGtk (top, start, connect) state modal = do+  stateref <- newIORef state+  let update st = do writeIORef stateref st+                     start st+      getState = readIORef stateref+  connect getState update+  startGtk top start state modal+  getState++startGtk ::  Gtk.Widget -> (a -> IO ()) -> a -> Bool -> IO ()+startGtk top start state modal = do+  Gtk.initGUI+  window <- Gtk.windowNew+  Gtk.windowSetModal window modal+  Gtk.onDestroy window Gtk.mainQuit+  set window [ Gtk.containerChild := top ]+  Gtk.widgetShowAll window+  start state+  Gtk.mainGUI++-----------------------------------+-- Renderers and popup renderers --+-----------------------------------++--  Two kinds of renderers are used.  The normal one puts widgets+--  inside other widgets in the normal way.  The popup renderer+--  instead puts widgets into a modal popup.  The choice of which to+--  used is made based on the popupChild argument to renderGtk, which+--  is taken from the widget corresponding to the gadget.++--  I find this a bit dodgy, since one could come up with all sorts of+--  information that might be useful for a widget to pass to a gadget,+--  but we certainly don't want to add an argument for each.  If I+--  come up with a bunch, I'll change the type from Maybe Widget to a+--  record of properties.++renderers :: [(String, GtkRenderFn a)]+renderers = [("button", renderButton),+             ("label", renderLabel),+             ("textbox", renderTextBox),+             ("checkbutton", renderCheckButton),+             ("droplist", renderChooser),+             ("list", renderSingleColumnList),+             ("hslider", renderScale Gtk.hScaleNewWithRange),+             ("vslider", renderScale Gtk.vScaleNewWithRange),+             ("vbox", renderBox Gtk.vBoxNew),+             ("hbox", renderBox Gtk.hBoxNew)]++-- Currently, we only do popup buttons, but it should be easily+-- generalisable.++popupRenderers :: [(String, Widget -> GtkRenderFn a)]+popupRenderers = [("button", renderPopupButton)]++--  Tables will come back when I work out a nice way to make them+--  dynamic.  Yes, boxes should be dynamic too, but there's something+--  about tables which just seems to demand it.++--  Barrie, of course, is not terribly at ease with dynamic gadgets+--  and widgets.++{-+renderTable :: GtkRenderFn a+renderTable ss children widgets = do+  case tableShape children of+    (1, 1) -> head children+    (1, _) -> renderBox Gtk.hBoxNew ss (head children) widgets+    (_, 1) -> renderBox Gtk.vBoxNew ss (map head children) widgets+    (n, m) -> do table <- Gtk.tableNew n m False+                 return $ (table,+                           startTable table n m ss children widgets,+                           updateContainer (Gtk.castToWidget table)+                                            ss (concat children) widgets)+-}++-- |The renderBox function renders horizontal and vertical layout boxes.++-- |Note the return type: it's a RunnableGUI from module Barrie.Render.++renderBox :: (Gtk.BoxClass b) =>+             (Bool -> Int -> IO b)+          -> GtkRenderFn a+renderBox new gs style gadget = do+  box <- new (getHomogenous style) 1+  startBox box gs gadget+  let result = Gtk.castToWidget box+  let connectBox getS update =+          mapM_ (\ (_, _, connect) -> connect getS update) gs+  return $ (result,+            configureWidget box style gadget $ onUpdate result (updates gs),+            connectBox)++startBox :: (Gtk.BoxClass b) =>+            b+         -> [RunnableGUI GtkGUI a]+         -> Maybe (Gadget a)+         -> IO ()+startBox box gs _ = do+  mapM_ (\ (w, _, _) -> Gtk.boxPackStartDefaults box w) gs++onUpdate :: Gtk.Widget -> [a -> IO ()] -> a -> IO ()+onUpdate _ childUpdates state = do+  mapM_ ($ state) childUpdates++applyStyle :: (a -> IO ()) -> Maybe a -> IO ()+applyStyle _ Nothing = return ()+applyStyle applier (Just style) = applier style++{-+tableShape :: [[a]] -> (Int, Int)+tableShape cells = (length cells, length (head cells))++startTable :: Gtk.Table+           -> StyleSheet -> [RunnableGUI GtkGUI a] -> [TreeWidget a]+           -> a -> IO ()+startTable table ss children widgets state = do+  let attachCell row col widget =+          Gtk.tableAttachDefaults table widget+                                  col (col + 1)+                                  row (row + 1)+      attachRow row cells = mapM_ attach (zip [0 ..] cells)+          where attach (col, (w, _, _)) = attachCell row col w+      attachRows = mapM_ attach (zip [0 ..] children)+          where attach (row, ws) = attachRow row (map (\ (w,_,_) -> w) ws)+  attachRows+-}++renderButton :: GtkRenderFn a+renderButton _ style gadget = do+  btn <- Gtk.buttonNew+  applyStyle (Gtk.buttonSetLabel btn) (getCaption style)+  let onClicked = \ handler -> Gtk.onClicked btn handler >> return ()+      clickUpdate = \ gets -> case gadget of+                                Just g -> connectCommand onClicked gets g+                                Nothing -> const (return ())+  return (Gtk.castToWidget btn,+          configureButton btn style gadget (const (return ())),+          clickUpdate)++renderPopupButton :: Widget -> GtkRenderFn a+renderPopupButton popup _ style gadget = do+  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+                           runGtk gui st True+      clickUpdate = \ gets -> case gadget of+                                Nothing -> \ _ -> return ()+                                Just g  ->+                                  connectChild onClicked inner gets g+  return (Gtk.castToWidget btn,+          configureButton btn style gadget (const (return ())),+          clickUpdate)++configureButton :: Gtk.Button -> Style -> Maybe (Gadget a)+                -> (a -> IO ()) -> a -> IO ()+configureButton btn style (Just gadget) update state = do+  let cfg = gadgetConfig gadget+  when (configHasLabel cfg) $ do+    Gtk.buttonSetLabel btn (configLabel cfg state)+  configureWidget btn style (Just gadget) update state++configureButton _ _ _ update state = update state++configureTreeView :: Gtk.TreeView -> Style -> Maybe (Gadget a)+                -> (a -> IO ()) -> a -> IO ()+configureTreeView view style (Just gadget) update state = do+  Gtk.treeViewSetHeadersVisible view (getTreeHeaderVisible style)+  configureWidget view style (Just gadget) update state++configureTreeView _ _ _ update state = update state++configureWidget :: (Gtk.WidgetClass w) =>+                   w+                -> Style+                -> Maybe (Gadget a)+                -> (a -> IO ())+                -> a -> IO ()+configureWidget widget style (Just gadget) update state = do+   let enable = case (gadgetEnabled gadget state, getHideDisabled style) of+                  (True, True)     -> Gtk.widgetShow+                  (False, True)    -> Gtk.widgetHide+                  (isEnbld, False) -> flip Gtk.widgetSetSensitivity isEnbld+   enable widget+   update state++configureWidget _ _ _ update state = update state++renderScale :: (Gtk.ScaleClass scale) =>+               (Double -> Double -> Double -> IO scale)   -- ^ constructor+            -> GtkRenderFn a+renderScale new _ style gadget = do+  scale <- new (getMinValue style) (getMaxValue style) (getAdjustment style)+  let onChanged = \ h -> (Gtk.onRangeValueChanged scale h >>+                          return ())+      hasChanged = \ d -> (Gtk.rangeGetValue scale >>=+                           \ t -> return $ t /= renderDouble d)+      getDynValue = Gtk.rangeGetValue scale >>= return . toDyn+      setDynValue d = Gtk.rangeSetValue scale (renderDouble d)+      changeUpdate getSt = case gadget of+                             Nothing -> \ _ -> return ()+                             Just g -> connectEditor onChanged getSt+                                            hasChanged getDynValue g+      updateValue = case gadget of+                      Nothing -> \ _ -> return ()+                      Just g  -> connectDisplay setDynValue g+  return (Gtk.castToWidget scale,+          configureWidget scale style gadget updateValue,+          changeUpdate)++renderTextBox :: GtkRenderFn a+renderTextBox _ style gadget = do+  tb <- Gtk.entryNew+  let onChanged = \ h -> (Gtk.onEntryActivate tb h >>+                          Gtk.onFocusOut tb (\ _ -> (h >> return False)) >>+                          return ())+      hasChanged = \ d -> (Gtk.entryGetText tb >>=+                           \ t -> return $ t /= renderText d)+      getDynValue = Gtk.entryGetText tb >>= return . toDyn+      setDynValue d = Gtk.entrySetText tb (renderText d)+      changeUpdate getSt = case gadget of+                             Nothing -> \ _ -> return ()+                             Just g -> connectEditor onChanged getSt+                                            hasChanged getDynValue g+      updateValue = case gadget of+                     Nothing -> \ _ -> return ()+                     Just g  -> connectDisplay setDynValue g+  return (Gtk.castToWidget tb,+          configureWidget tb style gadget updateValue,+          changeUpdate)++renderCheckButton :: GtkRenderFn a+renderCheckButton _ style gadget = do+  cb <- Gtk.checkButtonNew+  let onChanged = \ h -> (Gtk.onToggled cb h >> return ())+      hasChanged = \ d -> (Gtk.toggleButtonGetActive cb >>=+                           \ t -> return $ t /= renderBool d)+      getDynValue = Gtk.toggleButtonGetActive cb >>= return . toDyn+      setDynValue d = Gtk.toggleButtonSetActive cb (renderBool d)+      changeUpdate getSt = case gadget of+                             Nothing -> \ _ -> return ()+                             Just g -> connectEditor onChanged getSt+                                            hasChanged getDynValue g+      updateValue = case gadget of+                     Nothing -> \ _ -> return ()+                     Just g  -> connectDisplay setDynValue g+  return (Gtk.castToWidget cb,+          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 (),+                        mrSetSelection :: Int -> IO (),+                        mrGetValue     :: IO Dynamic,+                        mrHasChanged   :: Dynamic -> IO Bool+                        }++-- |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)])+  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)])+      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"+        curr <- getCursor+        return (x /= curr)+  return MR { mrSetChoices = setChoices,+              mrSetSelection = setCursor,+              mrGetValue = getValue,+              mrHasChanged = hasChanged+            }++renderChooser :: GtkRenderFn a+renderChooser _ style gadget = do+  store <- Gtk.listStoreNew ([] :: [(Dynamic, Dynamic)])+  chooser <- Gtk.comboBoxNewWithModel store+  r <- Gtk.cellRendererTextNew+  Gtk.cellLayoutPackStart chooser r True+  Gtk.cellLayoutSetAttributes chooser r store $+                         \ row -> [ Gtk.cellText := renderText $ fst 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+  let connect = case gadget of+                  Nothing -> \ _ -> return ()+                  Just g -> connectChooser (mrSetChoices mr) (mrSetSelection mr)+                               (mrGetValue mr) g+      update getSt = case gadget of+                       Nothing -> \ _-> return ()+                       Just g -> connectEditor onChanged getSt+                                                (mrHasChanged mr)+                                                (mrGetValue mr) g+  return (Gtk.castToWidget chooser,+          configureWidget chooser style gadget connect,+          update)++renderLabel :: GtkRenderFn a+renderLabel _ style gadget = do+  label <- Gtk.labelNew Nothing+  applyStyle (Gtk.labelSetText label) (getCaption style)+  let setDynText d = Gtk.labelSetText label (renderText d)+      updateText = case gadget of+                     Nothing -> \ _ -> return ()+                     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+  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+  let getModel = return store+      onChanged = \ handler -> Gtk.onCursorChanged list handler >>+                                               return ()+      getSel = do (path, _) <- Gtk.treeViewGetCursor list+                  case path of+                    []  -> return (-1)+                    [x] -> return x+                    _   -> 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+  let connect = case gadget of+                  Nothing -> \ _ -> return ()+                  Just g -> connectChooser (mrSetChoices mr) (mrSetSelection mr)+                                           (mrGetValue mr) g+      update getSt = case gadget of+                       Nothing -> \ _-> return ()+                       Just g -> connectEditor onChanged getSt+                                                (mrHasChanged mr)+                                                (mrGetValue mr) g+  return (Gtk.castToWidget list,+          configureTreeView list style gadget connect,+          update)
− src/Barrie/Render/Gtk.lhs 
@@ -1,412 +0,0 @@-This is Barrie's Gtk2hs rendering engine--    See module Barrie.Render for a discussion of the RunnableGUI type,-    which renderers return.--> module Barrie.Render.Gtk (gtkMain, initGtk, renderGtk, runGtk) where--> import qualified Graphics.UI.Gtk as Gtk-> import System.Glib.Attributes--> import Control.Monad--       IORefs are Barrie's dirty little secret.  There are three: one-       is for saving a global state that the GUI works with, the other-       two save the contents of lists and choosers, so that we don't-       update them more than necessary.--> import Data.IORef---       We import approximately everything--> import Barrie.Config-> import Barrie.Render-> import Barrie.Style-> import Barrie.Gadgets-> --  import Barrie.GadgetValue-> --  import Barrie.GadgetValueType-> import Barrie.Trace-> import Barrie.Widgets-- -       The rendering model is defined by the RenderF type in the-       Barrie.Render module.  Implementations of the renderer provide-       a type which describes the GUI.  In this case, it's just a-       Gtk.Widget.--> type GtkGUI = Gtk.Widget--       All rendering functions in this module use the following type-       GtkRenderFn.- -       It is a function from:-           -  a list of child guis (i.e. widgets inside the one being rendered)-           -  a style-           -  an optional gadget, which will be connected to the-              rendered widget if present.-       It returns a runnable GUI.--> type GtkRenderFn a = [RunnableGUI GtkGUI a]->                    -> Style->                    -> Maybe (Gadget a)->                    -> IO (RunnableGUI GtkGUI a)--- gtkMain is 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- harmless).--> gtkMain :: Gadget a -> Widget -> a -> IO a-> gtkMain gadget widget state = do->   initGtk->   gui <- renderWidget (gadgets gadget) widget renderGtk->   runGtk gui state False---> initGtk :: IO ()-> initGtk = do Gtk.initGUI->              return ()--> renderGtk :: RenderF GtkGUI a-> renderGtk nm gs style gadget popupChild = do->   let rendererList = case popupChild of->                         Nothing -> renderers->                         Just w  -> map (\ (x,y) -> (x, y w)) popupRenderers->   case lookup nm rendererList of->     Nothing -> error $ "rendering element '" ++ nm ++ "' not found"->     Just r  -> do traceMessage ("rendering: " ++ nm)->                   r gs style gadget--> runGtk :: RunnableGUI GtkGUI a -> a -> Bool -> IO a-> runGtk (top, start, connect) state modal = do->   stateref <- newIORef state->   let update st = do writeIORef stateref st->                      start st->       getState = readIORef stateref->   connect getState update->   startGtk top start state modal->   getState--> startGtk ::  Gtk.Widget -> (a -> IO ()) -> a -> Bool -> IO ()-> startGtk top start state modal = do->   Gtk.initGUI->   window <- Gtk.windowNew->   Gtk.windowSetModal window modal->   Gtk.onDestroy window Gtk.mainQuit->   set window [ Gtk.containerChild := top ]->   Gtk.widgetShowAll window->   start state->   Gtk.mainGUI-- ------------------------------ Renderers and popup renderers- ------------------------------- Two kinds of renderers are used.  The normal one puts widgets inside- other widgets in the normal way.  The popup renderer instead puts- widgets into a modal popup.  The choice of which to used is made- based on the popupChild argument to renderGtk, which is taken from- the widget corresponding to the gadget.-- I find this a bit dodgy, since one could come up with all sorts of- information that might be useful for a widget to pass to a gadget,- but we certainly don't want to add an argument for each.  If I come- up with a bunch, I'll change the type from Maybe Widget to a record- of properties.--> renderers :: [(String, GtkRenderFn a)]-> renderers = [("button", renderButton),->              ("label", renderLabel),->              ("textbox", renderTextBox),->              ("droplist", renderChooser),->              ("list", renderSingleColumnList),->              ("vbox", renderBox Gtk.vBoxNew),->              ("hbox", renderBox Gtk.hBoxNew)]--    Currently, we only do popup buttons, but it should be easily-    generalisable.--> popupRenderers :: [(String, Widget -> GtkRenderFn a)]-> popupRenderers = [("button", renderPopupButton)]--    Tables will come back when I work out a nice way to make them-    dynamic.  Yes, boxes should be dynamic too, but there's something-    about tables which just seems to demand it.--    Barrie, of course, is not terribly at ease with dynamic gadgets-    and widgets.--> {--> renderTable :: GtkRenderFn a-> renderTable ss children widgets = do->   case tableShape children of->     (1, 1) -> head children->     (1, _) -> renderBox Gtk.hBoxNew ss (head children) widgets->     (_, 1) -> renderBox Gtk.vBoxNew ss (map head children) widgets->     (n, m) -> do table <- Gtk.tableNew n m False->                  return $ (table,->                            startTable table n m ss children widgets,->                            updateContainer (Gtk.castToWidget table)->                                             ss (concat children) widgets)-> -}--> -- |The renderBox function renders horizontal and vertical layout boxes.--> -- |Note the return type: it's a RunnableGUI from module Barrie.Render.--> renderBox :: (Gtk.BoxClass b) =>->              (Bool -> Int -> IO b)->           -> GtkRenderFn a-> renderBox new gs style gadget = do->   box <- new (getHomogenous style) 1->   startBox box gs gadget->   let result = Gtk.castToWidget box->   let connectBox getS update =->           mapM_ (\ (_, _, connect) -> connect getS update) gs->   return $ (result,->             configureWidget box style gadget $ onUpdate result (updates gs),->             connectBox)--> startBox :: (Gtk.BoxClass b) =>->             b->          -> [RunnableGUI GtkGUI a]->          -> Maybe (Gadget a)->          -> IO ()-> startBox box gs _ = do->   mapM_ (\ (w, _, _) -> Gtk.boxPackStartDefaults box w) gs--> onUpdate :: Gtk.Widget -> [a -> IO ()] -> a -> IO ()-> onUpdate _ childUpdates state =->     mapM_ ($ state) childUpdates--> applyStyle :: (a -> IO ()) -> Maybe a -> IO ()-> applyStyle _ Nothing = return ()-> applyStyle applier (Just style) = applier style--> {--> tableShape :: [[a]] -> (Int, Int)-> tableShape cells = (length cells, length (head cells))--> startTable :: Gtk.Table->            -> StyleSheet -> [RunnableGUI GtkGUI a] -> [TreeWidget a]->            -> a -> IO ()-> startTable table ss children widgets state = do->   let attachCell row col widget =->           Gtk.tableAttachDefaults table widget->                                   col (col + 1)->                                   row (row + 1)->       attachRow row cells = mapM_ attach (zip [0 ..] cells)->           where attach (col, (w, _, _)) = attachCell row col w->       attachRows = mapM_ attach (zip [0 ..] children)->           where attach (row, ws) = attachRow row (map (\ (w,_,_) -> w) ws)->   attachRows-> -}--> renderButton :: GtkRenderFn a-> renderButton _ style gadget = do->   btn <- Gtk.buttonNew->   applyStyle (Gtk.buttonSetLabel btn) (getCaption style)->   let onClicked = \ handler -> Gtk.onClicked btn handler >> return ()->       clickUpdate = \ gets -> connectCommandGadget onClicked gets gadget->   return (Gtk.castToWidget btn,->           configureButton btn style gadget (const (return ())),->           clickUpdate)--> renderPopupButton :: Widget -> GtkRenderFn a-> renderPopupButton popup _ style gadget = do->   btn <- Gtk.buttonNew->   applyStyle (Gtk.buttonSetLabel btn) (getCaption style)->   let onClicked = \ handler -> Gtk.onClicked btn handler >> return ()->       inner = \ g st -> do traceMessage ("popup: gadget = " ++->                                          gadgetName g)->                            gui <- renderWidget (gadgets g) popup renderGtk->                            runGtk gui st True->       clickUpdate = \ gets -> connectInnerGadget onClicked->                                           inner gets gadget->   return (Gtk.castToWidget btn,->           configureButton btn style gadget (const (return ())),->           clickUpdate)--> configureButton :: Gtk.Button -> Style -> Maybe (Gadget a)->                 -> (a -> IO ()) -> a -> IO ()-> configureButton btn style (Just gadget) update state = do->   when (gadgetConfig gadget configHasLabel) $ do->     Gtk.buttonSetLabel btn (gadgetConfig gadget configLabel state)->   configureWidget btn style (Just gadget) update state--> configureButton _ _ _ update state = update state--> configureWidget :: (Gtk.WidgetClass w) =>->                    w->                 -> Style->                 -> Maybe (Gadget a)->                 -> (a -> IO ())->                 -> a -> IO ()-> configureWidget widget style (Just gadget) update state = do->    let enable = case (gadgetEnabled gadget state, getHideDisabled style) of->                   (True, True)     -> Gtk.widgetShow->                   (False, True)    -> Gtk.widgetHide->                   (isEnbld, False) -> flip Gtk.widgetSetSensitivity isEnbld->    enable widget->    update state--> configureWidget _ _ _ update state = update state--> renderTextBox :: GtkRenderFn a-> renderTextBox _ style gadget = do->   tb <- Gtk.entryNew->   let onChanged = \ handler -> (Gtk.onEntryActivate tb handler >>->                                 Gtk.onFocusOut tb (\ _ -> (handler >> return False)) >>->                                 return ())->       changeUpdate = \ getState ->->                      connectEditorGadget onChanged getState->                                   (Gtk.entryGetText tb)->                                   gadget->   return (Gtk.castToWidget tb,->           configureWidget tb style gadget $->                     connectDisplayGadget (Gtk.entrySetText tb) gadget,->           changeUpdate)--> traceGadget :: Maybe (Gadget a) -> String -> IO ()-> traceGadget Nothing msg = traceMessage $ "<no gadget>: " ++ msg-> traceGadget (Just g) msg = traceMessage $ (gadgetName g) ++ msg--> -- |ModelRender: a record for rendering models.--> data ModelRender = MR { mrSetChoices   :: [String] -> IO (),->                         mrSetSelection :: Int -> IO (),->                         mrGetValue     :: IO String->                       }--> -- |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 String)   -- ^ 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->   elemsRef <- newIORef []->   let setChoices xs = do->           current <- readIORef elemsRef->           when (current /= xs) $ do->             model <- getModel->             Gtk.listStoreClear model->             mapM_ (Gtk.listStoreAppend model) xs->             writeIORef elemsRef xs->   let getValue = do cursor <- getCursor->                     model  <- getModel->                     if cursor < 0->                          then return ""->                          else Gtk.listStoreGetValue model cursor->   let setValue n | n < 0     = setCursor n->                  | otherwise = setCursor n->   return MR { mrSetChoices = setChoices,->               mrSetSelection = setValue,->               mrGetValue = getValue->             }--> renderChooser :: GtkRenderFn a-> renderChooser _ style gadget = do->   store <- Gtk.listStoreNew []->   chooser <- Gtk.comboBoxNewWithModel store->   r <- Gtk.cellRendererTextNew->   Gtk.cellLayoutPackStart chooser r True->   Gtk.cellLayoutSetAttributes chooser r store $->                          \ row -> [ Gtk.cellText := 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->   let connect = connectChooserDisplay (mrSetChoices mr) (mrSetSelection mr)->                                       gadget->       update = \getState -> connectEditorGadget onChanged getState->                                                     (mrGetValue mr) gadget->   return (Gtk.castToWidget chooser,->           configureWidget chooser style gadget connect,->           update)--> renderLabel :: GtkRenderFn a-> renderLabel _ style gadget = do->   label <- Gtk.labelNew Nothing->   applyStyle (Gtk.labelSetText label) (getCaption style)->   return (Gtk.castToWidget label,->           connectDisplayGadget (Gtk.labelSetText label) gadget,->           \ _ _ -> return ())--> renderSingleColumnList :: GtkRenderFn a-> renderSingleColumnList children style gadget = do->   store <- Gtk.listStoreNew []->   list <- Gtk.treeViewNewWithModel store->   col <- Gtk.treeViewColumnNew->   r <- Gtk.cellRendererTextNew->   Gtk.cellLayoutPackStart col r True->   Gtk.cellLayoutSetAttributes col r store $ \ row -> [ Gtk.cellText := row ]->   Gtk.treeViewAppendColumn list col->   let getModel = return store->       onChanged = \ handler -> Gtk.onCursorChanged list handler >>->                                                return ()->       getSel = do (path, _) <- Gtk.treeViewGetCursor list->                   case path of->                     []  -> return (-1)->                     [x] -> return x->                     _   -> 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->   let connect = connectChooserDisplay (mrSetChoices mr) (mrSetSelection mr)->                                       gadget->       update = \getState -> connectEditorGadget onChanged getState->                                                     (mrGetValue mr) gadget->   return (Gtk.castToWidget list,->           configureWidget list style gadget connect,->           update)--->   {- list <- Gtk.treeViewNew->   col <- Gtk.treeViewColumnNew->   Gtk.treeViewAppendColumn list col->   tr <- Gtk.cellRendererTextNew->   Gtk.treeViewColumnPackStart col tr True->   Gtk.treeViewColumnAddAttribute col tr "text" 0->   let onChanged = \ handler -> Gtk.onCursorChanged list handler >>->                                return ()->   let getValue rd = do Just store <- Gtk.treeViewGetModel list->                        (path, col) <- Gtk.treeViewGetCursor list->                        miter <- Gtk.treeModelGetIter store path->                        case miter of->                           Nothing   -> return gvNoValue->                           (Just iter) -> do->                              (Gtk.GVstring (Just s)) <-->                                       Gtk.treeModelGetValue store iter 0->                              return (rd s)->   return (Gtk.castToWidget list,->           setListChanger (\ m -> Gtk.treeViewSetModel list m) gadget,->           \ getState -> connectTextEditorGadget onChanged getState->                                                 getValue gadget)-> -}--> {- setListChanger :: (Gtk.ListStore -> IO ())->                -> Maybe (Gadget a)->                -> a -> IO ()-> setListChanger update gadget st = connectDisplayGadget update' gadget st->     where update' gv = toListStore gv >>= update->           toListStore gv = case gvType gv of->                              (GVList t) ->->                                  toSingleColumnList t (gvListValues gv)->                              _ -> error ("can't display value in a list: " ++->                                          toString gv)->           toSingleColumnList t list = do->             store <- Gtk.listStoreNew [toGtkType t]->             mapM_ (listModelAddRow store) (map (toGtkValue t) list)->             return store->   -}--
+ src/Barrie/Style.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Barrie.Style (Style, Styled(..), addStyle, emptyStyle,+                     caption, getCaption,+                     hideDisabled, getHideDisabled,+                     homogenous, getHomogenous,+                     textValue, textItems,+                     minValue, maxValue,+                     getMinValue, getMaxValue,+                     adjustment, getAdjustment,+                     treeHeaderVisible, getTreeHeaderVisible) where++import Data.Monoid++newtype Style = Style [(String, StyleValue)]+           deriving (Read, Show, Monoid)++type StyleValue = String++mkStyle :: String -> StyleValue -> Style+mkStyle name value = Style [(name, value)]++class Styled a where+   setStyle :: Style -> a -> a+   getStyle :: a -> Style++instance Styled Style where+   setStyle = const+   getStyle = id++addStyle :: (Styled a) => Style -> a -> a+addStyle style item = setStyle (style `mappend` getStyle item) item++emptyStyle :: Style+emptyStyle = Style []++styleValue :: (Styled a) => String -> a -> Maybe StyleValue+styleValue name ss = lookup name styleList+   where (Style styleList) = getStyle ss++caption :: (Styled a) => String -> a -> a+caption text = addStyle $ mkStyle "caption" text++getCaption :: (Styled a) => a -> Maybe StyleValue+getCaption = styleValue "caption"++textValue :: (Styled a) => String -> a -> a+textValue text = addStyle $ mkStyle "textValue" text++textItems :: (Styled a) => [String] -> a -> a+textItems items = addStyle $ mkStyle "textItems" (unlines items)++hideDisabled :: (Styled a) => Bool -> a -> a+hideDisabled hide = addStyle $ mkStyle "hideDisabled" (show hide)++getHideDisabled :: (Styled a) => a -> Bool+getHideDisabled style = case styleValue "hideDisabled" style of+                          Nothing -> False+                          Just text -> read text+++homogenous :: (Styled a) => Bool -> a -> a+homogenous set = addStyle $ mkStyle "homogenous" (show set)++getHomogenous :: (Styled a) => a -> Bool+getHomogenous style = case styleValue "homogenous" style of+                          Nothing -> False+                          Just text -> read text+++minValue :: (Styled a, Num b, Show b, Read b) => b -> a -> a+minValue value = addStyle $ mkStyle "minValue" (show value)++getMinValue :: (Styled a, Num b, Show b, Read b) => a -> b+getMinValue style = case styleValue "minValue" style of+                          Nothing -> 0+                          Just text -> read text+++maxValue :: (Styled a, Num b, Show b, Read b) => b -> a -> a+maxValue value = addStyle $ mkStyle "maxValue" (show value)++getMaxValue :: (Styled a, Num b, Show b, Read b) => a -> b+getMaxValue style = case styleValue "maxValue" style of+                          Nothing -> 0+                          Just text -> read text+++adjustment :: (Styled a, Num b, Show b, Read b) => b -> a -> a+adjustment value = addStyle $ mkStyle "adjustment" (show value)++getAdjustment :: (Styled a, Num b, Show b, Read b) => a -> b+getAdjustment style = case styleValue "adjustment" style of+                          Nothing -> 1+                          Just text -> read text+++treeHeaderVisible :: (Styled a) => Bool -> a -> a+treeHeaderVisible hide = addStyle $ mkStyle "treeHeaderVisible" (show hide)++getTreeHeaderVisible :: (Styled a) => a -> Bool+getTreeHeaderVisible style = case styleValue "treeHeaderVisible" style of+                               Nothing -> False+                               Just text -> read text
− src/Barrie/Style.lhs 
@@ -1,66 +0,0 @@-> {-# LANGUAGE GeneralizedNewtypeDeriving #-}--> module Barrie.Style (Style, Styled(..), addStyle, emptyStyle,->                      caption, getCaption,->                      hideDisabled, getHideDisabled,->                      homogenous, getHomogenous,->                      textValue, textItems) where--> import Data.Monoid--> newtype Style = Style [(String, StyleValue)]->            deriving (Read, Show, Monoid)--> type StyleValue = String--> mkStyle :: String -> StyleValue -> Style-> mkStyle name value = Style [(name, value)]--> class Styled a where->    setStyle :: Style -> a -> a->    getStyle :: a -> Style--> instance Styled Style where->    setStyle = const->    getStyle = id--> addStyle :: (Styled a) => Style -> a -> a-> addStyle style item = setStyle (style `mappend` getStyle item) item--> emptyStyle :: Style-> emptyStyle = Style []--> styleValue :: (Styled a) => String -> a -> Maybe StyleValue-> styleValue name ss = lookup name styleList->    where (Style styleList) = getStyle ss--> caption :: (Styled a) => String -> a -> a-> caption text = addStyle $ mkStyle "caption" text--> getCaption :: (Styled a) => a -> Maybe StyleValue-> getCaption = styleValue "caption"--> textValue :: (Styled a) => String -> a -> a-> textValue text = addStyle $ mkStyle "textValue" text--> textItems :: (Styled a) => [String] -> a -> a-> textItems items = addStyle $ mkStyle "textItems" (unlines items)--> hideDisabled :: (Styled a) => Bool -> a -> a-> hideDisabled hide = addStyle $ mkStyle "hideDisabled" (show hide)--> getHideDisabled :: (Styled a) => a -> Bool-> getHideDisabled style = case styleValue "hideDisabled" style of->                           Nothing -> False->                           Just text -> read text---> homogenous :: (Styled a) => Bool -> a -> a-> homogenous set = addStyle $ mkStyle "homogenous" (show set)--> getHomogenous :: (Styled a) => a -> Bool-> getHomogenous style = case styleValue "homogenous" style of->                           Nothing -> False->                           Just text -> read text--
+ src/Barrie/Trace.hs view
@@ -0,0 +1,21 @@+--  Module for enabling trace++module Barrie.Trace (enableTrace, traceMessage) where++import Data.IORef+import System.IO.Unsafe++traceFile :: IORef (Maybe String)+traceFile = unsafePerformIO $ newIORef Nothing++enableTrace :: String -> IO ()+enableTrace fileName = do+  writeIORef traceFile (Just fileName)++traceMessage :: String -> IO ()+traceMessage msg = do+  fileName <- readIORef traceFile+  case fileName of+     Nothing -> return ()+     Just name -> appendFile name (msg ++ "\n")+
− src/Barrie/Trace.lhs 
@@ -1,21 +0,0 @@-Module for enabling trace--> module Barrie.Trace (enableTrace, traceMessage) where--> import Data.IORef-> import System.IO.Unsafe--> traceFile :: IORef (Maybe String)-> traceFile = unsafePerformIO $ newIORef Nothing--> enableTrace :: String -> IO ()-> enableTrace fileName = do->   writeIORef traceFile (Just fileName)--> traceMessage :: String -> IO ()-> traceMessage msg = do->   fileName <- readIORef traceFile->   case fileName of->      Nothing -> return ()->      Just name -> appendFile name (msg ++ "\n")-
+ src/Barrie/Widgets.hs view
@@ -0,0 +1,123 @@+module Barrie.Widgets+    (Widget, widgetElementName, widgetToLines, widgetChildren, widgetStyle,+     widgetPopupChild,+     mkWidget, mkPopup,+     ui, ui', uiElementName,+     LayoutDirection(..),+     vbox, hbox, menu, menuItem, button, labelButton, checkButton,+     textLabel, slider, hslider, vslider,+     staticDropList, dropList, listView, radioButtonList,+     textBox, textBoxWithValue)+    where++import Data.List++import Barrie.Style++data Widget = Widget { elementName  :: String,+                       styles       :: Style,+                       uiName       :: [String],+                       wpopup       :: Maybe Widget,+                       wdirection   :: Maybe LayoutDirection,+                       children     :: [Widget]+                     }+              deriving (Read, Show)++data LayoutDirection = Vertical | Horizontal+                       deriving (Read, Show)++instance Styled Widget where+   getStyle = styles+   setStyle style w = w { styles = style }++widgetElementName :: Widget -> String+widgetElementName w = prefix ++ elementName w+    where prefix = case wdirection w of+                     Nothing -> ""+                     Just Vertical -> "v"+                     Just Horizontal -> "h"++widgetToLines :: Widget -> [String]+widgetToLines w = widgetLine : concatMap widgetToLines (children w)+    where widgetLine = elementName w ++ uiLine+          uiLine = case uiName w of+                     []  -> ""+                     nms -> " (" ++ intercalate "." nms ++ ")"++widgetChildren :: Widget -> [Widget]+widgetChildren = children++widgetStyle :: Widget -> Style+widgetStyle = styles++widgetPopupChild :: Widget -> Maybe Widget+widgetPopupChild = wpopup++mkWidget :: String -> [Widget] -> Widget+mkWidget elmtName ws = Widget elmtName emptyStyle [] Nothing Nothing ws++mkPopup :: String -> Widget -> Widget -> Widget+mkPopup uiname popup w = ui uiname w { wpopup = Just popup }++layoutDirection :: LayoutDirection -> Widget -> Widget+layoutDirection d w = w { wdirection = Just d }++ui :: String -> Widget -> Widget+ui name = ui' [name]++ui' :: [String] -> Widget -> Widget+ui' name widget = widget { uiName = name }++uiElementName :: Widget -> [String]+uiElementName = uiName++vbox, hbox :: [Widget] -> Widget+vbox = layoutDirection Vertical . mkWidget "box"+hbox = layoutDirection Horizontal . mkWidget "box"++slider :: (Real a) => LayoutDirection -> a -> a -> a -> Widget+slider d lo hi adj = (minValue ((realToFrac lo) :: Double) .+                      maxValue ((realToFrac hi) :: Double) .+                      adjustment ((realToFrac adj) :: Double) .+                      layoutDirection d) (mkWidget "slider" [])++hslider, vslider :: (Real a) => a -> a -> a -> Widget+hslider = slider Horizontal+vslider = slider Vertical++menu :: [Widget] -> Widget+menu = mkWidget "menu"++menuItem :: [Widget] -> Widget+menuItem = mkWidget "menuitem"++button :: [Widget] -> Widget+button = mkWidget "button"++labelButton :: String -> Widget+labelButton text = caption text (button [])++checkButton :: Widget+checkButton = mkWidget "checkbutton" []++textLabel :: String -> Widget+textLabel text = caption text (mkWidget "label" [])++staticDropList :: String -> [String] -> Widget+staticDropList val vals = textValue val $ textItems vals $+                                mkWidget "droplist" []++dropList :: Widget+dropList = mkWidget "droplist" []++listView :: Widget+listView = mkWidget "list" []++radioButtonList :: LayoutDirection -> Widget+radioButtonList d = layoutDirection d $ mkWidget "radioButtonList" []++textBox :: Widget+textBox  = mkWidget "textbox" []++textBoxWithValue :: String -> Widget+textBoxWithValue text  = textValue text textBox
− src/Barrie/Widgets.lhs 
@@ -1,102 +0,0 @@-> module Barrie.Widgets->     (Widget, widgetElementName, widgetToLines, widgetChildren, widgetStyle,->      widgetPopupChild,->      mkWidget, mkPopup,->      ui, ui', uiElementName,->      vbox, hbox, menu, menuItem, button, labelButton, textLabel,->      staticDropList, dropList, list, textBox, textBoxWithValue)->     where--> import Data.List--> import Barrie.Style--> data Widget = Widget { elementName  :: String,->                        styles       :: Style,->                        uiName       :: [String],->                        wpopup       :: Maybe Widget,->                        children     :: [Widget]->                      }->               deriving (Read, Show)--> instance Styled Widget where->    getStyle = styles->    setStyle style w = w { styles = style }--> widgetElementName :: Widget -> String-> widgetElementName = elementName--> widgetToLines :: Widget -> [String]-> widgetToLines w = widgetLine : concatMap widgetToLines (children w)->     where widgetLine = elementName w ++ uiLine->           uiLine = case uiName w of->                      []  -> ""->                      nms -> " (" ++ intercalate "." nms ++ ")"--> widgetChildren :: Widget -> [Widget]-> widgetChildren = children--> widgetStyle :: Widget -> Style-> widgetStyle = styles--> widgetPopupChild :: Widget -> Maybe Widget-> widgetPopupChild = wpopup--> mkWidget :: String -> [Widget] -> Widget-> mkWidget elmtName ws = Widget elmtName emptyStyle [] Nothing ws--> mkPopup :: String -> Widget -> Widget -> Widget-> mkPopup uiname popup w = ui uiname w { wpopup = Just popup }--> ui :: String -> Widget -> Widget-> ui name = ui' [name]--> ui' :: [String] -> Widget -> Widget-> ui' name widget = widget { uiName = name }--> uiElementName :: Widget -> [String]-> uiElementName = uiName--> vbox, hbox :: [Widget] -> Widget-> vbox = mkWidget "vbox"-> hbox = mkWidget "hbox"--> table :: [[Widget]] -> Widget-> table = mkWidget "table" . map tableRow--> tableRow :: [Widget] -> Widget-> tableRow = mkWidget "tr" . map tableCell--> tableCell :: Widget -> Widget-> tableCell = mkWidget "td" . (:[])--> menu :: [Widget] -> Widget-> menu = mkWidget "menu"--> menuItem :: [Widget] -> Widget-> menuItem = mkWidget "menuitem"--> button :: [Widget] -> Widget-> button = mkWidget "button"--> labelButton :: String -> Widget-> labelButton text = caption text (button [])--> textLabel :: String -> Widget-> textLabel text = caption text (mkWidget "label" [])--> staticDropList :: String -> [String] -> Widget-> staticDropList val vals = textValue val $ textItems vals $->                                 mkWidget "droplist" []--> dropList :: Widget-> dropList = mkWidget "droplist" []--> list :: Widget-> list = mkWidget "list" []--> textBox :: Widget-> textBox  = mkWidget "textbox" []--> textBoxWithValue :: String -> Widget-> textBoxWithValue text  = textValue text textBox