diff --git a/barrie.cabal b/barrie.cabal --- a/barrie.cabal +++ b/barrie.cabal @@ -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 diff --git a/src/Barrie.hs b/src/Barrie.hs new file mode 100644 --- /dev/null +++ b/src/Barrie.hs @@ -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 diff --git a/src/Barrie.lhs b/src/Barrie.lhs deleted file mode 100644 --- a/src/Barrie.lhs +++ /dev/null @@ -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 diff --git a/src/Barrie/AbstractGadgets.lhs b/src/Barrie/AbstractGadgets.lhs deleted file mode 100644 --- a/src/Barrie/AbstractGadgets.lhs +++ /dev/null @@ -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 diff --git a/src/Barrie/Config.hs b/src/Barrie/Config.hs new file mode 100644 --- /dev/null +++ b/src/Barrie/Config.hs @@ -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" + diff --git a/src/Barrie/Config.lhs b/src/Barrie/Config.lhs deleted file mode 100644 --- a/src/Barrie/Config.lhs +++ /dev/null @@ -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" - diff --git a/src/Barrie/DrawPrimitive.hs b/src/Barrie/DrawPrimitive.hs new file mode 100644 --- /dev/null +++ b/src/Barrie/DrawPrimitive.hs @@ -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) diff --git a/src/Barrie/DrawPrimitive.lhs b/src/Barrie/DrawPrimitive.lhs deleted file mode 100644 --- a/src/Barrie/DrawPrimitive.lhs +++ /dev/null @@ -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) diff --git a/src/Barrie/Gadgets.hs b/src/Barrie/Gadgets.hs new file mode 100644 --- /dev/null +++ b/src/Barrie/Gadgets.hs @@ -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 } diff --git a/src/Barrie/Gadgets.lhs b/src/Barrie/Gadgets.lhs deleted file mode 100644 --- a/src/Barrie/Gadgets.lhs +++ /dev/null @@ -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] - diff --git a/src/Barrie/Gadgets/Connections.hs b/src/Barrie/Gadgets/Connections.hs new file mode 100644 --- /dev/null +++ b/src/Barrie/Gadgets/Connections.hs @@ -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') diff --git a/src/Barrie/Render.hs b/src/Barrie/Render.hs new file mode 100644 --- /dev/null +++ b/src/Barrie/Render.hs @@ -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)) + ] + diff --git a/src/Barrie/Render.lhs b/src/Barrie/Render.lhs deleted file mode 100644 --- a/src/Barrie/Render.lhs +++ /dev/null @@ -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) - diff --git a/src/Barrie/Render/Gtk.hs b/src/Barrie/Render/Gtk.hs new file mode 100644 --- /dev/null +++ b/src/Barrie/Render/Gtk.hs @@ -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 $ ": " ++ 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) diff --git a/src/Barrie/Render/Gtk.lhs b/src/Barrie/Render/Gtk.lhs deleted file mode 100644 --- a/src/Barrie/Render/Gtk.lhs +++ /dev/null @@ -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 $ ": " ++ 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 -> -} - - diff --git a/src/Barrie/Style.hs b/src/Barrie/Style.hs new file mode 100644 --- /dev/null +++ b/src/Barrie/Style.hs @@ -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 diff --git a/src/Barrie/Style.lhs b/src/Barrie/Style.lhs deleted file mode 100644 --- a/src/Barrie/Style.lhs +++ /dev/null @@ -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 - - diff --git a/src/Barrie/Trace.hs b/src/Barrie/Trace.hs new file mode 100644 --- /dev/null +++ b/src/Barrie/Trace.hs @@ -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") + diff --git a/src/Barrie/Trace.lhs b/src/Barrie/Trace.lhs deleted file mode 100644 --- a/src/Barrie/Trace.lhs +++ /dev/null @@ -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") - diff --git a/src/Barrie/Widgets.hs b/src/Barrie/Widgets.hs new file mode 100644 --- /dev/null +++ b/src/Barrie/Widgets.hs @@ -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 diff --git a/src/Barrie/Widgets.lhs b/src/Barrie/Widgets.lhs deleted file mode 100644 --- a/src/Barrie/Widgets.lhs +++ /dev/null @@ -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