[Haskell] Arrows GUI Library Based on GTK+
Kevin Atkinson
kevina at cs.utah.edu
Fri Mar 18 21:18:29 EST 2005
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
More information about the Haskell
mailing list