What follows is my first attempt of using Arrows to create a GUI Library based on GTK+. It uses many ideas from Fruit (http://haskell.org/fruit/). However it is based on discrete events rather than a continuous signal. The interface is only updated during an Event. It also ideas from Fudgets (http://www.md.chalmers.se/Cs/Research/Functional/Fudgets/), some of which were also used by Fruit. To the best of my knowledge this has note been attempted before as Fruit is not based on an existing GUI. As such I ran into a number of unique problems. Some of which are discussed in the implementation notes below. I plan on elaborating on the many issues I had to deal with latter. You can find the code and documentation at: http://kevin.atkinson.dhs.org/fg/. I am also intersting parts below (The whole file is two large). Feedback appreciated. -- FG.hs -- Copyright (C) 2005 by Kevin Atkinson under the GNU LGPL license -- version 2.0 or 2.1. You should have received a copy of the LGPL -- license along with this library if you did not you can find -- it at http://www.gnu.org/ {-| This module is a first attempt of using Arrows to create a GUI Library based on GTK+. A good understanding of how Arrows work is required in order to understand the interface. For more information on Arrows see <http://www.haskell.org/arrows/>. It uses many ideas from Fruit (<http://haskell.org/fruit/>). However it is based on discrete events rather than a continuous signal. The interface is only updated during an Event. It also ideas from Fudgets (<http://www.md.chalmers.se/Cs/Research/Functional/Fudgets/>), some of which were also used by Fruit. Here is a complete working example to give you an idea of how to use FG:
import FG
-- A Widget with three buttons "Inc", "Dec" and "Reset". "Dec" is -- disabled when the count is 0. Does not actually display the count. -- The output value is the current value of the counter. counter :: Widget WidgetP Int counter = proc p -> hbox [] (proc _ -> do rec inc <- tag (+1) <<< button [text "Inc"] -< def dec <- tag (+(-1)) <<< button [text "Dec"] -< [enabled (c > 0)] reset <- tag (const 0) <<< button [text "Reset"] -< def cs@(_,c) <- hold 0 -< onEvent (\f -> Just $ f c) Nothing (inc >< dec >< reset) returnA -< cs) -< (p, ())
-- The main FG. Connects the value of the counter to a Label. mainFG :: Container () () mainFG = vbox [spacing 2] $ proc _ -> do (_,c) <- counter -< def label [] -< [text $ show c] returnA -< ()
main :: IO () main = runFG mainFG
-} --------------------------------------------------------------------------- -- -- Basic Types -- data FG a b = FG !(FGState -> IO (FG' a b, FGState)) data Event = NoEvent | Event --------------------------------------------------------------------------- -- -- Internal data types -- data FG' a b = FG' !(Control -> a -> IO (Control, b)) data Control = Init | Pending !EventId | Handled !EventId | Done deriving Eq type EventId = Int data AbstrWidget = forall w. WidgetClass w => AbstrWidget w data PendingCallback = PendingCallback !EventId !(Callback -> IO ()) type Callback = IO () data FGState = FGState ![AbstrWidget] !EventId -- Last used callback id ![PendingCallback] --------------------------------------------------------------------------- -- -- Arrow Implementation -- instance Arrow FG where arr = arrFG (>>>) = combFG first = firstFG instance ArrowLoop FG where loop = loopFG arrFG :: (a -> b) -> FG a b arrFG f = FG $ \s -> do let f' c x = return (c, f x) return (FG' f', s) combFG :: FG a b -> FG b c -> FG a c combFG (FG f1) (FG f2) = FG $ \s -> do (FG' f1, s) <- f1 s (FG' f2, s) <- f2 s let f c v = do (c, v) <- f1 c v (c, v) <- f2 c v return (c, v) return (FG' f, s) firstFG :: FG a b -> FG (a,c) (b,c) firstFG (FG f) = FG $ \s -> do (FG' f, s) <- f s let f' c (x, y) = do (c, x) <- f c x return (c, (x, y)) return (FG' f', s) loopFG :: FG (a, c) (b, c) -> FG a b loopFG (FG f) = FG $ \z -> do (FG' f, z) <- f z st <- newIORef undefined let f' Init v = do (Init, (v', s)) <- f Init (v, undefined) writeIORef st s return (Init, v') f' c v = do s <- readIORef st (c, (_, s)) <- f c (v, s) (c, (v', s)) <- f c (v, s) writeIORef st s return (c, v') return (FG' f', z) --------------------------------------------------------------------------- -- -- ArrowDef -- class ArrowDef a where def :: a -- ^Evaluates to a sensible default value. When used as an Arrow, -- ie on the RHS of a @-<@, evaluates to 'init' which takes a -- paramater for the default value, if this parameter is ommited -- the default value is 'def'. instance ArrowDef () where def = () instance ArrowDef [a] where def = [] instance ArrowDef (Maybe a) where def = Nothing instance ArrowDef Event where def = NoEvent instance (ArrowDef a, ArrowDef b) => ArrowDef (a, b) where def = (def, def) --------------------------------------------------------------------------- -- -- AbstractFunction -- -- | An AbstractFunction is either a true function or an Arrow class AbstractFunction f where mkAFun :: (a -> b) -> f a b mkAFunDef :: (a -> b) -> b -> f a b ... --------------------------------------------------------------------------- -- -- Arrow Utilities -- -- -- |In a loop context (ie when rec is used) some arrows are not well -- defined as they may receive 'undefined' as a value during the first -- iteration. Guard those arrows by giving them a default value -- during the initial value, by using one of 'init', 'guard', or 'def', -- during the first iteration. -- -- Note: 'init' is also defined by the Prelude and List, and 'guard' -- is defined in Monad. -- init, guard :: a -> FG a a init d = FG $ \s -> do let f' Init _ = return (Init, d) f' c v = return (c, v) return (FG' f', s) guard = init -- def :: a -> FG a a instance ArrowDef (a -> FG a a) where def = init -- ArrowDef a => def :: FG a a instance ArrowDef a => ArrowDef (FG a a) where def = init def -- this is not a recursion the 'def' called is a -- different function -- -- |'><' merges two events, taking the value from the signal with an Event, -- if none of the signals have an event than the value is taken from -- the first signal. The case where more than one signal have an event -- should't happen but if it does the value of the first signal is taken -- (><) :: (Event, a) -> (Event, a) -> (Event, a) v >< (NoEvent, _) = v (NoEvent, _) >< v = v v >< _ = v -- -- |'tag' tages an event with a value, throwing away the old value. -- -- can either be used as a function or an arrow -- tag :: (AbstractFunction f) => b -> f (Event, a) (Event, b) tag v = mkAFun (\(e, _) -> (e, v)) -- -- |'hold' creates a value that will hold onto a value until instructed -- to change it. 'hold' is safe to use in a loop context -- hold :: Show s => s -> FG (Maybe s) (Event, s) hold s0 = FG $ \z -> do st <- newIORef s0 let f' c x = do s <- readIORef st case (c, x) of (Init, _) -> return (c, (NoEvent, s)) (_, Nothing) -> return (c, (NoEvent, s)) (_, (Just s')) -> do writeIORef st s' return (c, (Event, s')) return (FG' f', z) -- -- |'arrIO' is like 'arr' except that the function may perform IO -- -- This may be called multiple times during a single event, so be -- careful. It is best only to perform actions with side effects -- during the actual occurrence of the event of interest. -- arrIO :: (a -> IO b) -> FG a b arrIO f = FG $ \z -> do let f' c x = do r <- f x return (c, r) return (FG' f', z) -- -- |'onEvent' will call a function on the value of the event when there -- is any sort of event otherwise it will return a default value. It is -- also safe to in a loop context when used as an arrow. -- onEvent :: (AbstractFunction f) => (a -> b) -> b -> f (Event, a) b onEvent f def = mkAFunDef f' def where f' (NoEvent, _) = def f' (_, v) = f v --------------------------------------------------------------------------- -- -- runFG -- -- | Runs a FG Arrow runFG :: Container () () -> IO () runFG fg = runFG' fg () -- | Runs an FG Arrow with the given input and throws away the return value runFG' :: Container a b -> a -> IO () runFG' (FG f) v = do initGUI window <- windowNew onDestroy window mainQuit containerSetBorderWidth window 10 (FG' f, FGState [AbstrWidget w] _ cbs) <- f $ FGState [] 1 [] let h id = do f (Pending id) ([], v) return () mapM_ (\(PendingCallback id instCb) -> instCb $ h id) cbs widgetShow w f Init ([], v) -- initialize loops h 0 -- set initial state containerAdd window w widgetShow window mainGUI --------------------------------------------------------------------------- -- -- Widget data type -- -- $widget -- A 'Widget' is an Arrow corresponding to GUI element. A widget -- constructor is generally of the form @[p] -> Widget p v@ where @p@ -- is a property type. A property is created using a, possible -- overloaded, property function, common propery function include -- 'text', 'markup', 'enabled' and, 'visible'. -- -- A widget is of the type @'FG' [p] ('Event', v)@. The arrow input is -- a list of properties to change. The arrow output is an 'Event' and -- the current value associated with the Widget, if any. -- -- The event value is either 'NoEvent' if no event is emitted or 'Event'. -- Future versions will have a more specific mechanism to distinguish -- between different types of events. -- type Widget p v = FG [p] (Event, v) --------------------------------------------------------------------------- -- -- Properties -- class Text a where -- | The widget label text :: String -> a class Enabled a where -- | If the Widget is enabled, ie can receive user events enabled :: Bool -> a ... --------------------------------------------------------------------------- -- -- Label Widget -- type Label = Widget LabelP () -- ^ -- * doesn't emit any events -- -- * doesn't have any readable properties -- newtype LabelP = LabelP (forall w. LabelClass w => w -> IO ()) labelP (LabelP a) = a instance Enabled LabelP where enabled p = LabelP (enableW p) instance Visible LabelP where visible p = LabelP (visibleW p) instance Text LabelP where text p = LabelP (\w -> labelSetText w p) instance Markup LabelP where markup p = LabelP (\w -> labelSetMarkup w p) label :: [LabelP] -> Label label = widget' (labelNew Nothing) labelP NoEventP noProp --------------------------------------------------------------------------- -- -- Button Widget -- type Button = Widget ButtonP () -- ^ -- * emits an Event when pressed -- -- * doesn't have any readable properties -- newtype ButtonP = ButtonP (forall w. ButtonClass w => w -> IO ()) buttonP (ButtonP a) = a instance Enabled ButtonP where enabled p = ButtonP (enableW p) instance Visible ButtonP where visible p = ButtonP (enableW p) instance Text ButtonP where text p = ButtonP (textWL p) instance Markup ButtonP where markup p = ButtonP (markupWL p) button :: [ButtonP] -> Button button = widget' (widgetWithLabelNew buttonNew) buttonP (EP Event onClicked) noProp --------------------------------------------------------------------------- -- -- Container Widgets -- type Container a b = FG ([WidgetP], a) b -- ^ -- A container simply arranges the widgets of the underlying arrow in -- a fixed fashion. The first input of an arrow is for dynamically -- changing the properties of a container. The second input is passed -- to underlying arrow. The output is the same as the underlying -- arrow. -- hbox, vbox :: [BoxP] -> FG a b -> Container a b hbox = box' hBoxNew vbox = box' vBoxNew ... --------------------------------------------------------------------------- -- -- Generic Widget Implementation -- data EventParm w z = NoEventP | EP Event (w -> Callback -> IO z) noProp _ = return () widget' :: (WidgetClass w) => IO w -> (a -> w -> IO b) -> EventParm w z -> (w -> IO p) -> ([a] -> Widget a p) widget' create apply eventP prop ps = FG $ \(FGState ws cid cbs) -> do w <- create widgetShow w mapM_ (\a -> apply a w) ps case (eventP) of NoEventP -> do let f c ps = do unless (c == Init) $ mapM_ (\a -> apply a w) ps p <- prop w return (c, (NoEvent, p)) return (FG' f, FGState (AbstrWidget w : ws) cid cbs) (EP e cbF) -> do let f c ps = do unless (c == Init) $ mapM_ (\a -> apply a w) ps p <- prop w case c of Pending id | id == cid -> return (Handled cid, (e, p)) Handled id | id == cid -> return (Done, (NoEvent, p)) _ -> return (c, (NoEvent, p)) let cb f = do cbF w f; return () return (FG' f, FGState (AbstrWidget w : ws) (cid + 1) (PendingCallback cid cb : cbs)) ... --------------------------------------------------------------------------- -- -- Extra Documentation -- {- $ImplementationNotes Arrows essentially build up a huge tree like data structure represting the control flow between arrows. In the current implementation the /entire/ top-level structure has to be traversed when ever an event is fired -- even if absolutely no actions need to be taken. Worse when ever a loop is used the entire loop has to we traversed twice. Consequently, this means that any inner loops will end up being tranversed four times. More generally the deepest most loop will be traversed 2^d times, where d in the depth of loop. Thus FG will obviously not scale well for large applications. By mainating some state information on the value of final value of a loop during a previous event it should be possible to avoid having to traverse a loop twice. However, avoiding the problem of having to traverse the entire tree for every event is much more difficult and require dataflow analysis. Precise analysis will probably require the use of Generalised Algebraic Data Types (GADT) and possible changes to how code is generated when using the arrow notation. -} {- $Requirements FG is based on gtk2hs and uses several GHC extensions. It was tested with GHC 6.2.2 and gtk2hs 0.9.7. -} -- http://kevin.atkinson.dhs.org