{-# OPTIONS -fglasgow-exts -farrows #-}

-- 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/

{-|
Module      :  FG
Copyright   :  (c) Kevin Atkinson 2005
License     :  LGPL

Maintainer  :  kevina@cs.utah.edu
Stability   :  experimental
Portability :  non-portable (many GHC extensions)

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

-}

module FG (module Control.Arrow, 

           -- * Basic Types

           FG, Event(NoEvent, Event),

           -- * Arrow Utilities

           init, guard, (><), vmap, value, tag, arrST, arrST_, arrIO, hold, onEvent,
           ArrowDef, def,
           AbstractFunction,
           runFG, runFG',

           -- * Widgets

           -- $widget

           Widget,
           Label, label, LabelP,
           Button, button, ButtonP,
           ToggleButton, toggleButton, ToggleButtonP,
           CheckButton, checkButton, CheckButtonP,
           Entry, entry, EntryP,
           ComboBox, comboBoxText, appendText,
           HSeparator, hSeparator, VSeparator, vSeparator,

           -- * Container Widgets

           Container, 
           ContainerP,
           homogeneous, spacing, 
           hbox, vbox, BoxP,
           packRepel, packGrow, packNatural,
           table, TableP, 
           attachExpand, attachShrink, attachFill,

           -- * Properties

           Text, text, Markup, markup, Enabled, enabled, 
           Visible, visible, Active, active,
           WidgetP

           -- * Implementation Notes

           -- $ImplementationNotes

           -- * Requirements

           -- $Requirements
           
           ) where

import Prelude hiding (init)
import qualified Graphics.UI.Gtk as Gtk
import Graphics.UI.Gtk hiding (Event, Markup, Widget, Entry, 
                               Label, Button, ComboBox, 
                               ToggleButton, CheckButton, Arrow,
                               HSeparator, VSeparator, Container,
                               button, visible)
import Data.IORef
import Control.Arrow
import List hiding (init)
import Monad hiding (guard)

---------------------------------------------------------------------------
--
-- Basic Types
--

newtype FG a b = FG (IO (FG' a b, FGReturn a b))

data Event = NoEvent | Event

---------------------------------------------------------------------------
--
-- Implementation Info
-- 

--
-- The FG data structure builds up a giant function which does the
-- real work.  This function is called by runFG.  The function created
-- by FG does the following:
--   * Create the Gtk+ widgets
--   * Build up a top-level function which will traverse the entire
--     arrow structure.
--   * Build up the functions which are called when a Widget fires an
--     event.
-- The idea behind building up a seperate function for each event is
-- to theoretically avoid having to traverse irrelevent parts of the
-- arrow structure.  Currently this is not implemented very well and
-- as a result most of the data structure will have to be traversed
-- any way.  However it does avoid having to traverse every loop twice
-- -- only the loops which an event was fired in a traversed multiple
-- times.  
--
-- See the docs at the end of the file for additional info on
-- performance.

---------------------------------------------------------------------------
--
-- Internal data types
--

newtype FG' a b = FG' (Mode -> a -> IO b)

data Mode = Init | Normal deriving Eq

type FGReturn a b = ([AbstrWidget], [CB a b])

data AbstrWidget = forall w. WidgetClass w => AbstrWidget !w

data CB a b = CB (CBFun a b)
                 InstCB

type InstCB = IO () -> IO ()

data CBFun a b = CB_I (a -> IO b) (a -> IO b)
                 -- ^ This callback may need input and may produces a result
               | CB_O (IO b) (a -> IO (), a -> IO b)
                 -- ^ This callback doesn't need input but may produce a result
  -- The second part of CBFun in the action needed to be performed to
  -- complete the loop.  "a -> IO ()" will execute the command from
  -- the beggining of the loop up to the current Widget.  "a -> IO b"
  -- will execute the entire loop but the current Widget is expected
  -- to return NoEvent to keep actions based on the orignal event from
  -- running twice.  Both types are needed in CB_O in order to convert
  -- from a CB_O to a CB_I as is required by "first".

---------------------------------------------------------------------------
--
-- 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 $ do
    let f' _ x = return $ f x
    return (FG' f', def)

combFG :: FG a b -> FG b c -> FG a c
combFG (FG f1) (FG f2) = FG $ do
    (FG' f1, (ws1, cbs1)) <- f1 
    (FG' f2, (ws2, cbs2)) <- f2 
    let f c = f1 c >>. f2 c
    let fixCB1 (CB (CB_I f r) i) 
            = CB (CB_I (f >>. f2 Normal) (r >>. f2 Normal)) i
        fixCB1 (CB (CB_O f (r,r2)) i) 
            = CB (CB_O (f >>= f2 Normal) (r, r2 >>. f2 Normal)) i
    let fixCB2 (CB (CB_I f r) i) 
            = CB (CB_I (f1 Normal >>. f) (f1 Normal >>. r)) i
        fixCB2 (CB (CB_O f (r,r2)) i) 
            = CB (CB_O f (f1 Normal >>. r, f1 Normal >>. r2)) i
    return (FG' f, (ws1 ++ ws2, map fixCB1 cbs1 ++ map fixCB2 cbs2))

firstFG :: FG a b -> FG (a,c) (b,c)
firstFG (FG f) = FG $ do
    (FG' f, (ws, cbs)) <- f 
    let f' c = appF (f c)
    let fixCB (CB (CB_I f r) i) = CB (CB_I (appF f)  (appF r)) i
        fixCB (CB (CB_O f (_,r2)) i) = CB (CB_I (appF f_) (appF r2)) i
            where f_ _ = f
    return (FG' f', (ws, map fixCB cbs))
  where
    appF f (x, y) = do x <- f x
                       return (x, y)

loopFG :: FG (a, c) (b, c) -> FG a b
loopFG (FG f) = FG $ do
    (FG' f, (ws, cbs)) <- f 
    st <- newIORef undefined
    let f' Init v = do (v', s) <- f Init (v, undefined)
                       writeIORef st s
                       return v'
        f' c v = do s <- readIORef st
                    (v', s) <- f c (v, s)
                    writeIORef st s
                    return v'
    let fixCB (CB (CB_I f rest) i) = 
            let f'' v = do s <- readIORef st
                           (_, s) <- f (v, s)
                           (v', s) <- rest (v, s)
                           writeIORef st s
                           return v'
            in CB (CB_I f'' (f' Normal)) i
        -- the CB_O case doesn't make sence and should not happen here
    return (FG' f', (ws, map fixCB cbs))

---------------------------------------------------------------------------
--
-- 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

instance AbstractFunction (->) where
    mkAFun f = f
    mkAFunDef f _ = f

instance AbstractFunction FG where
    mkAFun f = FG $ do
        let f' _ v = return $ f v
        return (FG' f', def)
    mkAFunDef f d = FG $ do
        let f' Init _ = return d
            f' _    v = return $ f v
        return (FG' f', def)

---------------------------------------------------------------------------
--
-- 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 $ do
    let f' Init _ = return d
        f' _    v = return v
    return (FG' f', def)
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)) 

--
-- |'vmap' maps the value of a (Event, value) pair with a new value 
-- based on the old
--
-- It can either be used as a function or an arrow, when used as a
-- function it is also a Functor.
--
vmap :: (AbstractFunction f) => (a -> b) -> f (Event, a) (Event, b)
vmap f = mkAFun (\(e, v) -> (e, f v))

instance Functor ((,) Event) where fmap = fmap

--
-- |'arrST' is like 'arr' except with state, that is the function takes
-- two paramaters with the second one represents some sort of internal
-- state 
--
arrST :: (a -> s -> (b, s)) -> s -> FG a b
arrST f s0 = FG $ do
    st <- newIORef s0
    let f' _ x = do s <- readIORef st
                    let (r, s') = f x s
                    writeIORef st s'
                    return r
    return (FG' f', def)

arrST_ :: (a -> s -> s) -> s -> FG a s
arrST_ f s0 = FG $ do
    st <- newIORef s0
    let f' _ x = do s <- readIORef st
                    let s' = f x s
                    writeIORef st s'
                    return s'
    return (FG' f', def)

--
-- |'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 $ do
    st <- newIORef s0
    let f' c x = do s <- readIORef st
                    case (c, x) of
                      (Init, _)      -> return (NoEvent, s)
                      (_, Nothing)   -> return (NoEvent, s)
                      (_, (Just s')) -> do writeIORef st s'
                                           return (Event, s')
    return (FG' f', def)

--
-- |'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 $ do
    let f' _ x = do r <- f x
                    return r
    return (FG' f', def)

--
-- |'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

--
-- |'value' returns a value part of an (Event, value) pair
--
value :: (Event, a) -> a
value (_, v) = 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, ([AbstrWidget w], cbs)) <- f
    let instCB (CB (CB_I f _) inst) = inst $ do f ([], v); return ()
        instCB (CB (CB_O f _) inst) = inst $ do f; return ()
    mapM_ instCB cbs
    widgetShow w
    f Init ([], v)   -- initialize loops
    f Normal ([], v) -- 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 Markup a where
    -- | Like 'text' but is encoded in the Pango Text Attribute Markup language
    markup :: String -> a

class Enabled a where
    -- | If the Widget is enabled, ie can receive user events
    enabled :: Bool -> a

class Visible a where
    -- | If the Widget is visible
    visible :: Bool -> a

class Active a v where
    -- | The active value of the Widget
    active :: v -> 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

---------------------------------------------------------------------------
--
-- ToggleButton Widget
--

type ToggleButton = Widget ToggleButtonP Bool
-- ^
-- * emits an Event when pressed
--
-- * it's readable property is its current value as a Bool
--

newtype ToggleButtonP = ToggleButtonP (forall w. ToggleButtonClass w => w -> IO ())
toggleButtonP (ToggleButtonP a) = a

instance Enabled ToggleButtonP where enabled p = ToggleButtonP (enableW p)
instance Visible ToggleButtonP where visible p = ToggleButtonP (enableW p)
instance Text    ToggleButtonP where text p    = ToggleButtonP (textWL p)
instance Markup  ToggleButtonP where markup p  = ToggleButtonP (markupWL p)
instance Active  ToggleButtonP Bool where active p  = ToggleButtonP (toggleButtonSetActive p)

toggleButton :: [ToggleButtonP] -> ToggleButton
toggleButton = widget' (widgetWithLabelNew toggleButtonNew) toggleButtonP 
                       (EP Event afterToggled) (toggleButtonGetActive)

---------------------------------------------------------------------------
--
-- CheckButton Widget
--

type CheckButton = Widget CheckButtonP Bool
-- ^
-- * emits an Event when pressed
-- 
-- * it's readable property is its current value as a Bool
--

newtype CheckButtonP = CheckButtonP (forall w. CheckButtonClass w => w -> IO ())
checkButtonP (CheckButtonP a) = a

instance Enabled CheckButtonP where enabled p = CheckButtonP (enableW p)
instance Visible CheckButtonP where visible p = CheckButtonP (enableW p)
instance Text    CheckButtonP where text p    = CheckButtonP (textWL p)
instance Markup  CheckButtonP where markup p  = CheckButtonP (markupWL p)
instance Active  CheckButtonP Bool where active p  = CheckButtonP (toggleButtonSetActive p)

checkButton :: [CheckButtonP] -> CheckButton
checkButton = widget' (widgetWithLabelNew checkButtonNew) checkButtonP 
                      (EP Event afterToggled) (toggleButtonGetActive)

---------------------------------------------------------------------------
--
-- Entry Widget
--

type Entry = Widget EntryP String
-- ^
-- * doesn't ement any events
--
-- * it's readable property is its current value as a String
--

newtype EntryP = EntryP (forall w. EntryClass w => w -> IO ())
entryP (EntryP a) = a

instance Enabled EntryP where enabled p = EntryP (enableW p)
instance Visible EntryP where visible p = EntryP (enableW p)
instance Text    EntryP where text p = EntryP (\w -> entrySetText w p)

entry :: [EntryP] -> Entry
entry = widget' entryNew entryP NoEventP entryGetText 

---------------------------------------------------------------------------
--
-- ComboBox Widget
-- 

type ComboBox = Widget ComboBoxP (Maybe Int)
-- ^
-- * does not emit any events
-- 
-- * it's readable property is its current value as an Int
--

newtype ComboBoxP = ComboBoxP (forall w. ComboBoxClass w => w -> IO ())
comboBoxP (ComboBoxP a) = a

instance Enabled ComboBoxP where enabled p = ComboBoxP (enableW p)
instance Visible ComboBoxP where visible p = ComboBoxP (enableW p)
instance Active  ComboBoxP Int where active p  = ComboBoxP (\w -> comboBoxSetActive w p)

appendText :: String -> ComboBoxP
appendText str = ComboBoxP (\w -> comboBoxAppendText w str)

comboBoxText :: [ComboBoxP] -> ComboBox
comboBoxText = widget' comboBoxNewText comboBoxP NoEventP comboBoxGetActive

---------------------------------------------------------------------------
--
-- V/HSeparator Widgets
--

type HSeparator = Widget () ()
-- ^
-- * desn't emit any events
--
-- * desn't have any readable properties
--

hSeparator :: HSeparator
hSeparator = separator' hSeparatorNew

type VSeparator = Widget () ()
-- ^
-- * doesn't emit any events
--
-- * doesn't have any readable properties
--

vSeparator :: VSeparator
vSeparator = separator' vSeparatorNew

separator':: (SeparatorClass w) => IO w -> Widget () ()
separator' sepNew = FG $ do
    s <- sepNew
    let f c _ = return (NoEvent, ())
    return (FG' f, ([AbstrWidget s], []))

---------------------------------------------------------------------------
--
-- 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.
--

data ContainerP a = ContainerP !(ContainerP' a -> ContainerP' a) 
                  | ContainerA (forall w. WidgetClass w => w -> IO ())

data ContainerP' a = ContainerP' !Bool -- homogeneous
                                 !Int -- spacing
                                 !a

instance Enabled (ContainerP a) where enabled p = ContainerA (enableW p)
instance Visible (ContainerP a) where visible p = ContainerA (enableW p)

homogeneous :: Bool -> ContainerP a
homogeneous h = ContainerP (\(ContainerP' _ s p) -> ContainerP' h s p)

spacing :: Int -> ContainerP a
spacing s = ContainerP (\(ContainerP' h _ p) -> ContainerP' h s p) 

container' :: (WidgetClass w) =>
             (ContainerP' a -> [AbstrWidget] -> IO w)
                 -> ContainerP' a -> [ContainerP a] -> FG a1 b 
                 -> FG ([WidgetP], a1) b

container' widgetNew defaults ps (FG init) = FG $ do
    let (props, actions) = foldr split ([],[]) ps 
    let props' = foldl (flip ($)) defaults props
    (FG' f, (ws, cbs)) <- init
    b <- widgetNew props' ws
    mapM_ (\(ContainerA a) -> a b) actions
    widgetShow b
    let f' c (ps, o) = do mapM_ (\(WidgetP a) -> a b) ps
                          r <- f c o
                          return r
    let fixCB (CB (CB_I f r) i) = CB (CB_I (useS f) (useS r)) i
        fixCB (CB (CB_O f (r,r2)) i) = CB (CB_O f (useS r, useS r2)) i
    return (FG' f', ([AbstrWidget b], map fixCB cbs))
  where
    split p (pl, al) = case (p) of
                       ContainerP x -> (x : pl, al)
                       ContainerA x -> (pl, ContainerA x : al)
    useS f (_, v) = f v


---------------------------------------------------------------------------
--
-- H/VBox 
--

hbox, vbox :: [BoxP] -> FG a b -> Container a b
hbox = box' hBoxNew
vbox = box' vBoxNew

type BoxParm = Packing

type BoxP = ContainerP BoxParm

packRepel, packGrow, packNatural :: BoxP
packRepel     = ContainerP (\(ContainerP' h s _) -> ContainerP' h s PackRepel) 
packGrow      = ContainerP (\(ContainerP' h s _) -> ContainerP' h s PackGrow) 
packNatural   = ContainerP (\(ContainerP' h s _) -> ContainerP' h s PackNatural) 

boxDefaults = ContainerP' False 0 PackRepel

box' :: (BoxClass bx) => 
       (Bool -> Int -> IO bx) -> [BoxP] -> FG a b -> Container a b
box' boxNew = container' widgetNew boxDefaults
  where
    widgetNew (ContainerP' homogeneous spacing pack) ws = do
        b <- boxNew homogeneous spacing
        mapM_ (\(AbstrWidget w) -> boxPackStart b w pack 0) ws
        return b

---------------------------------------------------------------------------
--
-- Table
--

-- |Creates a table of widgets.  The underlying arrow is expected to
-- have exactly \"rows * colums\" widgets.  It will arrange than
-- across than down. \[UNIMPLEMENTED\]
table :: Int -- ^ rows
      -> Int -- ^ columns
      -> [TableP] -> FG a b -> Container a b
table rows cols = container' widgetNew tableDefaults
  where
    widgetNew (ContainerP' homogeneous spacing attachOpts) ws = do
        b <- tableNew rows cols homogeneous
        tableGetRowSpacing b spacing
        tableGetColSpacing b spacing
        mapM_ (\(AbstrWidget w, (x, y)) -> tableAttach b w x x y y attachOpts attachOpts 0 0)
              $ zip ws [(x,y) | x <- [0..], y <- [0..], x < rows, y < cols]
        return b

type TableParm = [AttachOptions]

type TableP = ContainerP TableParm

attachExpand, attachShrink, attachFill :: TableP
attachExpand = ContainerP (\(ContainerP' h s a) -> ContainerP' h s (Expand : a)) 
attachShrink = ContainerP (\(ContainerP' h s a) -> ContainerP' h s (Shrink : a)) 
attachFill   = ContainerP (\(ContainerP' h s a) -> ContainerP' h s (Fill : a)) 

tableDefaults = ContainerP' False 0 [Expand, Fill]

---------------------------------------------------------------------------
--
-- Generic Widget Implementation
--

data EventParm w z = NoEventP | EP Event (w -> IO () -> 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 $ do
    w <- create
    widgetShow w
    mapM_ (\a -> apply a w) ps
    let readProp c ps = do
        unless (c == Init) $ mapM_ (\a -> apply a w) ps
        p <- prop w
        return (NoEvent, p)
    case (eventP) of
      NoEventP -> do
        return (FG' readProp, ([AbstrWidget w], []))
      (EP e cbF) -> do
        let emit = do p <- prop w; return (e, p)
        let rest ps = do mapM_ (\a -> apply a w) ps
        let rest2 ps = do mapM_ (\a -> apply a w) ps
                          p <- prop w
                          return (NoEvent, p)
        let instCB f = do cbF w f; return ()
        return (FG' readProp, ([AbstrWidget w], [CB (CB_O emit (rest,rest2)) instCB]))

widgetWithLabelNew :: (ContainerClass c) => IO c -> IO c
widgetWithLabelNew create = do
  w <- create
  l <- labelNew Nothing
  containerAdd w l
  widgetShow l
  return w

---------------------------------------------------------------------------
--
-- Generic property implementations
--

enableW :: (WidgetClass w) => Bool -> w -> IO ()
enableW p w = widgetSetSensitivity w p

visibleW :: (WidgetClass w) => Bool -> w -> IO ()
visibleW True  w = widgetShow w
visibleW False w = widgetHide w

textWL :: (ContainerClass c) => String -> c -> IO ()
textWL p c = do [w] <- containerGetChildren c
                labelSetText (castToLabel w) p

markupWL :: (ContainerClass c) => String -> c -> IO ()
markupWL p c = do [w] <- containerGetChildren c
                  labelSetMarkup (castToLabel w) p

newtype WidgetP = WidgetP (forall w. WidgetClass w => w -> IO ())
instance Enabled WidgetP where enabled p = WidgetP (enableW p)
instance Visible WidgetP where visible p = WidgetP (visibleW p)

---------------------------------------------------------------------------
--
-- Helper Functions
--


infixl 1 >>.
(>>.) :: (Monad m) => (a -> m b) -> (b -> m c) -> (a -> m c)
f >>. g = \x -> do r <- f x
                   g r

---------------------------------------------------------------------------
--
-- Extra Documentation
--

{- $ImplementationNotes

Arrows essentially build up a huge tree like data structure
representing the control flow between arrows.  In the current
implementation most of top-level structure has to be traversed when
ever an event is fired -- even if absolutely no actions need to be
taken.  When a loop is used parts of this structure may be traversed
multiple times.  In particular the inner most loop where an event was
fired from will be traversed \"@d + 1@\" times where d is the depth of
the loop.  If an event was not fired inside a loop (or any of the sub
loops) than the loop will only be traversed once.

Avoiding this problem of having to traverse most of tree for every
event requires information that I'm not sure the compiler can give me.
For example I need to know the difference between @arr (\\x -> x)@ and
@arr (\\_ -> 10)@.  The first passes the input to the output the second
throws the value away.  All I am able to know is that @arr@ was used.
What exactly the function does is a black box.

-}

{- $Requirements

FG is based on gtk2hs and uses several GHC extensions.  It was tested
with GHC 6.2.2 and gtk2hs 0.9.7.

-}