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