diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,5 @@ Copyright © 2007–2009 Brandenburgische Technische Universität Cottbus +Copyright © 2011 Wolfgang Jeltsch All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted diff --git a/grapefruit-ui-gtk.cabal b/grapefruit-ui-gtk.cabal --- a/grapefruit-ui-gtk.cabal +++ b/grapefruit-ui-gtk.cabal @@ -1,15 +1,15 @@ Name: grapefruit-ui-gtk -Version: 0.0.0.0 -Cabal-Version: >= 1.2.3 +Version: 0.1.0.0 +Cabal-Version: >= 1.6 Build-Type: Simple License: BSD3 License-File: LICENSE -Copyright: © 2007–2009 Brandenburgische Technische Universität Cottbus +Copyright: © 2007–2009 Brandenburgische Technische Universität Cottbus; © 2011 Wolfgang Jeltsch Author: Wolfgang Jeltsch -Maintainer: jeltsch@informatik.tu-cottbus.de +Maintainer: wolfgang@cs.ioc.ee Stability: provisional -Homepage: http://haskell.org/haskellwiki/Grapefruit -Package-URL: http://hackage.haskell.org/packages/archive/grapefruit-ui-gtk/0.0.0.0/grapefruit-ui-gtk-0.0.0.0.tar.gz +Homepage: http://grapefruit-project.org/ +Package-URL: http://hackage.haskell.org/packages/archive/grapefruit-ui-gtk/0.1.0.0/grapefruit-ui-gtk-0.1.0.0.tar.gz Synopsis: GTK+-based backend for declarative user interface programming Description: Grapefruit is a library for Functional Reactive Programming (FRP) with a focus on user interfaces. FRP makes it possible to implement reactive and interactive systems @@ -18,19 +18,34 @@ . This package contains the GTK+-based user interface backend. Category: FRP, Reactivity, GUI, User Interfaces -Tested-With: GHC == 6.8.3 - GHC == 6.10.1 +Tested-With: GHC == 7.0.4 +Source-Repository head + type: darcs + location: http://darcs.grapefruit-project.org/main + +Source-Repository this + type: darcs + location: http://darcs.grapefruit-project.org/main + tag: grapefruit-0.1.0.0 + Library - Build-Depends: base >= 3.0 && < 4.1, - grapefruit-frp >= 0.0 && < 0.1, - grapefruit-records >= 0.0 && < 0.1, - grapefruit-ui >= 0.0 && < 0.1, - gtk >= 0.9.13 && < 0.11 - Extensions: TypeFamilies + Build-Depends: base >= 3.0 && < 4.4, + colour >= 1.0 && < 2.4, + containers >= 0.1 && < 0.5, + fraction >= 0.0.1 && < 0.2, + grapefruit-frp >= 0.1 && < 0.2, + grapefruit-records >= 0.1 && < 0.2, + grapefruit-ui >= 0.1 && < 0.2, + glib >= 0.9.13 && < 0.13, + gtk >= 0.9.13 && < 0.13 + Extensions: Arrows + ExistentialQuantification + FlexibleContexts + Rank2Types + TypeFamilies + TypeOperators Exposed-Modules: Graphics.UI.Grapefruit.GTK - Graphics.UI.Grapefruit.GTK.Connector - Graphics.UI.Grapefruit.GTK.Item - Other-Modules: Graphics.UI.Grapefruit.GTK.Backend - Graphics.UI.Grapefruit.GTK.Backend.Std + -- Graphics.UI.Grapefruit.GTK.Connector + -- Graphics.UI.Grapefruit.GTK.Item HS-Source-Dirs: src diff --git a/src/Graphics/UI/Grapefruit/GTK.hs b/src/Graphics/UI/Grapefruit/GTK.hs --- a/src/Graphics/UI/Grapefruit/GTK.hs +++ b/src/Graphics/UI/Grapefruit/GTK.hs @@ -5,10 +5,57 @@ ) where - -- Graphics.UI.Grapefruit.GTK - import Graphics.UI.Grapefruit.GTK.Backend as GTKUIBackend - import Graphics.UI.Grapefruit.GTK.Backend.Std as GTKStdUIBackend + {-FIXME: + Originally, this module only contained the declaration of GTK. Unfortunately, GHC 7 did not + (re-)export the instances from the backend modules, possibly because it has a bug regarding + the interplay of orphan modules and mutually dependent modules. As a result, we copied the + contents of all other modules into this module. :-( + -} + -- Prelude + import Prelude hiding (sequence_, mapM_) + + -- Control + import Control.Monad as Monad hiding (sequence_, mapM_) + import Control.Arrow as Arrow + + -- Data + import Data.Foldable as Foldable + import Data.Sequence as Seq hiding (reverse, zipWith) + import Data.Set as Set + import Data.Fraction as Fraction + import Data.Colour.RGBSpace as RGBSpace + import Data.IORef as IORef + import Data.Record as Record + import Data.Record.Optionality as OptRecord + import Data.Record.Signal as SignalRecord + import Data.Record.Signal.Context as ContextSignalRecord + + -- FRP.Grapefruit + import FRP.Grapefruit.Setup as Setup + import FRP.Grapefruit.Circuit as Circuit + import FRP.Grapefruit.Signal as Signal + import FRP.Grapefruit.Signal.Discrete as DSignal + import FRP.Grapefruit.Signal.Segmented as SSignal + import FRP.Grapefruit.Signal.Incremental as ISignal hiding (const) + import FRP.Grapefruit.Signal.Incremental.Sequence as SeqISignal hiding (reverse) + import FRP.Grapefruit.Signal.Incremental.Set as SetISignal hiding (Diff) + + -- Graphics.UI.Grapefruit + import Graphics.UI.Grapefruit.Comp as UIComp + import Graphics.UI.Grapefruit.Item as UIItem + import Graphics.UI.Grapefruit.Backend as UIBackend + import Graphics.UI.Grapefruit.Backend.Basic as BasicUIBackend + import Graphics.UI.Grapefruit.Backend.Container as ContainerUIBackend + + -- System.Glib + import qualified System.Glib.GObject as Glib + import qualified System.Glib.Signals as Glib + import qualified System.Glib.Attributes as Glib + + -- Graphics.UI.Gtk + import qualified Graphics.UI.Gtk as Gtk + {-| Denotes the GTK+-based UI backend. @@ -16,3 +63,480 @@ backends. -} data GTK = GTK + + instance UIBackend GTK where + + type WidgetPlacement GTK = Gtk.Widget -> IO () + + type WindowPlacement GTK = Gtk.Window -> IO () + + initialize GTK = Gtk.unsafeInitGUIForThreadedRTS >> return () + + handleEvents GTK = Gtk.mainGUI + + requestQuitting GTK = Gtk.mainQuit + + finalize GTK = return () + + topLevel GTK = const (return ()) + + instance BasicUIBackend GTK where + + label = widgetBrick (Gtk.labelNew Nothing) + Gtk.toWidget + (X :& Text := attrConsumer Gtk.labelLabel) + X + + pushButton = widgetBrick Gtk.buttonNew + Gtk.toWidget + (X :& Text := attrConsumer Gtk.buttonLabel) + (X :& Push := eventProducer Gtk.onPressed) + + lineEditor = widgetBrick Gtk.entryNew + Gtk.toWidget + X + (X :& Content := attrEventProducer Gtk.entryText + Gtk.onEditableChanged) + + box orientation = widgetBox (case orientation of + Horizontal -> newGtkBox Gtk.hBoxNew + Vertical -> newGtkBox Gtk.vBoxNew) + Gtk.toWidget + Gtk.containerAdd + X + X + + window = windowBox Gtk.windowNew + Gtk.toWindow + Gtk.containerAdd + (X :& Title := attrConsumer Gtk.windowTitle) + (X :& Closure := eventProducer Gtk.onDestroy) + + newGtkBox :: (Gtk.BoxClass gtkBox) => (Bool -> Int -> IO gtkBox) -> IO Gtk.Box + newGtkBox rawNewGtkBox = fmap Gtk.toBox (rawNewGtkBox False 0) + + instance ContainerUIBackend GTK where + + listView = listViewBrick id id + + setView = listViewBrick SetISignal.toSeqs (Set.fromList . Foldable.toList) + + data Cell GTK display = forall gtkCellRenderer. (Gtk.CellRendererClass gtkCellRenderer) => + Cell (IO gtkCellRenderer) [CellValAttr gtkCellRenderer display] + + textCell = Cell Gtk.cellRendererTextNew [textAttr,backgroundColorAttr] where + + textAttr = CellValAttr toText Gtk.cellText + + toText (TextCellDisplay text _) = text + + backgroundColorAttr = CellValAttr toBackgroundColor + Gtk.cellTextBackgroundColor + + toBackgroundColor (TextCellDisplay _ bgColor) = toGtkColor bgColor + + progressCell = Cell Gtk.cellRendererProgressNew [valueAttr,textAttr] where + + valueAttr = CellValAttr toValue Gtk.cellProgressValue + + toValue (ProgressCellDisplay progress _) = round (Fraction.toPercentage progress) + + textAttr = CellValAttr toText Gtk.cellProgressText + + toText (ProgressCellDisplay _ maybeText) = maybeText + + data CellValAttr gtkCellRenderer display = forall gtkReadVal gtkWriteVal. + CellValAttr (display -> gtkWriteVal) + (Gtk.ReadWriteAttr gtkCellRenderer + gtkReadVal + gtkWriteVal) + + listViewBrick :: (forall era. ISignal era container -> ISignal era (Seq el)) + -> (Seq el -> container) + -> Brick Widget + GTK + (X :& Req Elements ::: ISignal `Of` container + :& Req Columns ::: ISignal `Of` Seq (Column GTK el) + :& Opt HasScrollbars ::: SSignal `Of` (Orientation -> Availability)) + (X :& Selection ::: SSignal `Of` container) + listViewBrick fromContainerSignal toContainer = brick where + + brick = widgetBrick (do + gtkScrolledWindow <- Gtk.scrolledWindowNew Nothing Nothing + gtkTreeView <- Gtk.treeViewNew + Gtk.containerAdd gtkScrolledWindow gtkTreeView + gtkTreeSelection <- Gtk.treeViewGetSelection gtkTreeView + Gtk.treeSelectionSetMode gtkTreeSelection Gtk.SelectionMultiple + gtkListStore <- Gtk.listStoreNew [] + seqRef <- newIORef Seq.empty + Gtk.treeViewSetModel gtkTreeView gtkListStore + return (gtkScrolledWindow,gtkTreeView,gtkListStore,seqRef)) + (\(gtkScrolledWindow,_,_,_) -> Gtk.toWidget gtkScrolledWindow) + (X :& Elements := consumerComap fromContainerSignal . + seqSignalConsumer + (withModelAndRef insertListViewElement) + (withModelAndRef deleteListViewElement) + (withModelAndRef shiftListViewElement) + :& Columns := seqSignalConsumer + (withViewAndModel insertListViewColumn) + (withView deleteListViewColumn) + (withView shiftListViewColumn) + :& HasScrollbars := withScrolledWindow hasScrollbarsConsumer) + (X :& Selection := producerMap (fmap toContainer) . + withViewAndModel selectionProducer) where + + withScrolledWindow fun (gtkScrolledWindow,_,_,_) = fun gtkScrolledWindow + + withViewAndModel :: (Gtk.TreeView -> Gtk.ListStore el -> result) + -> (Gtk.ScrolledWindow,Gtk.TreeView,Gtk.ListStore el,IORef (Seq el)) + -> result + withViewAndModel fun (_,gtkTreeView,gtkListStore,_) = fun gtkTreeView gtkListStore + + withView :: (Gtk.TreeView -> result) + -> (Gtk.ScrolledWindow,Gtk.TreeView,Gtk.ListStore el,IORef (Seq el)) + -> result + withView fun = withViewAndModel (const . fun) + + withModelAndRef :: (Gtk.ListStore el -> IORef (Seq el) -> result) + -> (Gtk.ScrolledWindow,Gtk.TreeView,Gtk.ListStore el,IORef (Seq el)) + -> result + withModelAndRef fun (_,_,gtkListStore,seqRef) = fun gtkListStore seqRef + + consumerComap :: (forall era. signal era val -> signal' era val') + -> (Consumer signal' val' -> Consumer signal val) + consumerComap signalFun consumer' = Consumer $ arr signalFun >>> Signal.consume consumer' + + producerMap :: (forall era. signal era val -> signal' era val') + -> (Producer signal val -> Producer signal' val') + producerMap signalFun producer = Producer $ Signal.produce producer >>> arr signalFun + + insertListViewElement :: Gtk.ListStore el -> IORef (Seq el) -> Int -> el -> IO () + insertListViewElement gtkListStore seqRef idx el = Gtk.listStoreInsert gtkListStore idx el >> + modifyIORef seqRef (flip patch diff) where + + diff = SeqISignal.elementInsertion idx el + + deleteListViewElement :: Gtk.ListStore el -> IORef (Seq el) -> Int -> IO () + deleteListViewElement gtkListStore seqRef idx = Gtk.listStoreRemove gtkListStore idx >> + modifyIORef seqRef (flip patch diff) where + + diff = SeqISignal.elementDeletion idx + + shiftListViewElement :: Gtk.ListStore el -> IORef (Seq el) -> Int -> Int -> IO () + shiftListViewElement gtkListStore seqRef from to = shift where + + shift = do + seq <- readIORef seqRef + Gtk.listStoreRemove gtkListStore from + Gtk.listStoreInsert gtkListStore to (Seq.index seq from) + modifyIORef seqRef (flip patch diff) + + diff = elementShift from to + + insertListViewColumn :: Gtk.TreeView -> Gtk.ListStore el -> Int -> Column GTK el -> IO () + insertListViewColumn gtkTreeView + gtkListStore + idx + (Column title toDisplay (Cell newCellRenderer cellValAttrs)) = insert where + + insert = do + gtkTreeViewColumn <- Gtk.treeViewColumnNew + Gtk.treeViewColumnSetTitle gtkTreeViewColumn title + gtkCellRenderer <- newCellRenderer + Gtk.cellLayoutPackStart gtkTreeViewColumn + gtkCellRenderer + True + Gtk.cellLayoutSetAttributes gtkTreeViewColumn + gtkCellRenderer + gtkListStore + (mapM cellValAss cellValAttrs) + Gtk.treeViewInsertColumn gtkTreeView gtkTreeViewColumn idx + return () + + cellValAss cellValAttr el = case cellValAttr of + CellValAttr toWriteVal + gtkWriteAttr -> gtkWriteAttr Gtk.:= + toWriteVal (toDisplay el) + + deleteListViewColumn :: Gtk.TreeView -> Int -> IO () + deleteListViewColumn gtkTreeView idx = delete where + + delete = do + Just gtkTreeViewColumn <- Gtk.treeViewGetColumn gtkTreeView idx + Gtk.treeViewRemoveColumn gtkTreeView gtkTreeViewColumn + return () + + shiftListViewColumn :: Gtk.TreeView -> Int -> Int -> IO () + shiftListViewColumn gtkTreeView from to = shift where + + shift = do + Just gtkFromColumn <- Gtk.treeViewGetColumn gtkTreeView from + if to == 0 then Gtk.treeViewMoveColumnFirst gtkTreeView + gtkFromColumn + else if from <= to + then shiftAfter gtkFromColumn to + else shiftAfter gtkFromColumn (pred to) + + shiftAfter gtkColumn idx = do + Just gtkBeforeColumn <- Gtk.treeViewGetColumn gtkTreeView idx + Gtk.treeViewMoveColumnAfter gtkTreeView + gtkColumn + gtkBeforeColumn + + seqSignalConsumer :: (gtkObject -> Int -> el -> IO ()) + -> (gtkObject -> Int -> IO ()) + -> (gtkObject -> Int -> Int -> IO ()) + -> gtkObject + -> Consumer ISignal (Seq el) + seqSignalConsumer insertOne deleteOne shiftOne gtkObject = consumer where + + consumer = ISignal.consumer (insert 0) patchObject + + patchObject (Diff atomicDiffs) = mapM_ atomicPatchObject atomicDiffs + + atomicPatchObject (Insertion idx seq) = insert idx seq + atomicPatchObject (Deletion idx cnt) = delete idx cnt + atomicPatchObject (Shift from cnt to) = let + + oneShifts = zipWith (shiftOne gtkObject) + [from..pred (from + cnt)] + [to..pred (to + cnt)] + + in sequence_ (if from <= to then reverse oneShifts + else oneShifts) + atomicPatchObject (Update idx seq) = delete idx (Seq.length seq) >> insert idx seq + + insert idx seq = zipWithM_ (insertOne gtkObject) + [idx..] + (Foldable.toList seq) + + delete idx cnt = replicateM_ cnt (deleteOne gtkObject idx) + + hasScrollbarsConsumer :: Gtk.ScrolledWindow -> Consumer SSignal (Orientation -> Availability) + hasScrollbarsConsumer gtkScrolledWindow = SSignal.consumer hdlr where + + hdlr avails = Gtk.scrolledWindowSetPolicy gtkScrolledWindow + (policy avails Horizontal) + (policy avails Vertical) + + policy avails orient = case avails orient of + Never -> Gtk.PolicyNever + AsNecessary -> Gtk.PolicyAutomatic + Always -> Gtk.PolicyAlways + + selectionProducer :: Gtk.TreeView -> Gtk.ListStore el -> Producer SSignal (Seq el) + selectionProducer gtkTreeView gtkListStore = Producer $ proc _ -> do + gtkTreeSelection <- act -< Gtk.treeViewGetSelection gtkTreeView + let + + actualProducer = readEventProducer (readSelection gtkListStore) + Gtk.onSelectionChanged + gtkTreeSelection + + Signal.produce $ actualProducer -<< () + + readSelection :: Gtk.ListStore el -> Gtk.TreeSelection -> IO (Seq el) + readSelection gtkListStore gtkTreeSelection = read where + + read = do + gtkSelPaths <- Gtk.treeSelectionGetSelectedRows gtkTreeSelection + els <- mapM (Gtk.listStoreGetValue gtkListStore) + (Prelude.map treePathToIndex gtkSelPaths) + return (Seq.fromList els) + + treePathToIndex :: Gtk.TreePath -> Int + treePathToIndex [idx] = idx + treePathToIndex _ = error "grapefruit-ui-gtk: tree path has not length 1" + + -- FIXME: This should maybe go to another place. + toGtkColor :: RGB Fraction -> Gtk.Color + toGtkColor (RGB redFrac greenFrac blueFrac) = Gtk.Color (toWord16 redFrac) + (toWord16 greenFrac) + (toWord16 blueFrac) where + + toWord16 = round . toNumber (0,0xFFFF) + + -- |Constructs a GTK+-based widget brick. + widgetBrick :: (OptRecord iOptRecord, + Record SignalKind (All iOptRecord), + Record SignalKind oRecord) + => IO nativeWidget + -- ^an action which creates a native widget + -> (nativeWidget -> Gtk.Widget) + -- ^converts a native widget into a Gtk2Hs widget + -> ContextConsumerRecord nativeWidget (All iOptRecord) + -- ^consumers of those inputs which are specific to this brick + -> ContextProducerRecord nativeWidget oRecord + -- ^producers of those outputs which are specific to this brick + -> Brick Widget GTK iOptRecord oRecord + widgetBrick = brickOrBox brick commonWidgetConsumerRecord commonWidgetProducerRecord + + -- |Constructs a GTK+-based window brick. + windowBrick :: (OptRecord iOptRecord, + Record SignalKind (All iOptRecord), + Record SignalKind oRecord) + => IO nativeWindow + -- ^an action which creates a native window + -> (nativeWindow -> Gtk.Window) + -- ^converts a native window into a Gtk2Hs window + -> ContextConsumerRecord nativeWindow (All iOptRecord) + -- ^consumers of those inputs which are specific to this brick + -> ContextProducerRecord nativeWindow oRecord + -- ^producers of those outputs which are specific to this brick + -> Brick Window GTK iOptRecord oRecord + windowBrick = brickOrBox brick commonWindowConsumerRecord commonWindowProducerRecord + + -- |Constructs a GTK+-based widget box. + widgetBox :: (UIComp innerUIComp, + OptRecord iOptRecord, + Record SignalKind (All iOptRecord), + Record SignalKind oRecord) + => IO nativeWidget + -- ^an action which creates a native widget + -> (nativeWidget -> Gtk.Widget) + -- ^converts a native widget into a Gtk2Hs widget + -> (nativeWidget -> Placement innerItem GTK) + -- ^conversion from a native widget into the placement for its inner items + -> ContextConsumerRecord nativeWidget (All iOptRecord) + -- ^consumers of those inputs which are specific to this box + -> ContextProducerRecord nativeWidget oRecord + -- ^producers of those outputs which are specific to this box + -> Box innerUIComp innerItem Widget GTK iOptRecord oRecord + widgetBox = brickOrBox UIItem.box commonWidgetConsumerRecord commonWidgetProducerRecord + + -- |Constructs a GTK+-based window box. + windowBox :: (UIComp innerUIComp, + OptRecord iOptRecord, + Record SignalKind (All iOptRecord), + Record SignalKind oRecord) + => IO nativeWindow + -- ^an action which creates a native window + -> (nativeWindow -> Gtk.Window) + -- ^converts a native window into a Gtk2Hs window + -> (nativeWindow -> Placement innerItem GTK) + -- ^conversion from a native window into the placement for its inner items + -> ContextConsumerRecord nativeWindow (All iOptRecord) + -- ^consumers of those inputs which are specific to this box + -> ContextProducerRecord nativeWindow oRecord + -- ^producers of those outputs which are specific to this box + -> Box innerUIComp innerItem Window GTK iOptRecord oRecord + windowBox = brickOrBox UIItem.box commonWindowConsumerRecord commonWindowProducerRecord + + brickOrBox :: (Gtk.WidgetClass gtkItem, Record SignalKind iRecord, Record SignalKind oRecord) + => (ContextConsumerRecord nativeItem iRecord -> + ContextProducerRecord nativeItem oRecord -> + (nativeItem -> IO ()) -> + ((gtkItem -> IO ()) -> IO nativeItem) -> + result) + -> ContextConsumerRecord gtkItem iRecord + -> ContextProducerRecord gtkItem oRecord + -> IO nativeItem + -> (nativeItem -> gtkItem) + -> result + brickOrBox genericBrickOrBox + contextConsumers + contextProducers + newNativeItem + toGtkItem = genericBrickOrBox (Record.map (brickOrBoxTransformer toGtkItem) + contextConsumers) + (Record.map (brickOrBoxTransformer toGtkItem) + contextProducers) + (Gtk.widgetShowAll . toGtkItem) + {-FIXME: + Using widgetShowAll instead of widgetShow + is just a temporary hack for supporting + tree views inside scrolled windows. + -} + newItem where + + newItem placement = do + nativeItem <- newNativeItem + placement (toGtkItem nativeItem) + return nativeItem + + brickOrBoxTransformer :: (nativeItem -> gtkItem) + -> Forall SignalKind + (TransformerPiece (ContextConnectorStyle gtkItem connector) + (ContextConnectorStyle nativeItem connector)) + brickOrBoxTransformer toGtkItem = SignalForall (TransformerPiece (. toGtkItem)) + + commonWidgetConsumerRecord :: ContextConsumerRecord Gtk.Widget + (All (CommonInputOptRecord Widget)) + commonWidgetConsumerRecord = X :& IsEnabled := SSignal.consumer . Gtk.widgetSetSensitivity + + commonWidgetProducerRecord :: ContextProducerRecord Gtk.Widget (CommonOutputRecord Window) + commonWidgetProducerRecord = X + + commonWindowConsumerRecord :: ContextConsumerRecord Gtk.Window + (All (CommonInputOptRecord Window)) + commonWindowConsumerRecord = X + + commonWindowProducerRecord :: ContextProducerRecord Gtk.Window (CommonOutputRecord Window) + commonWindowProducerRecord = X + + {-| + Constructs a consumer of segmented signals which makes a Gtk2Hs attribute of a Gtk2Hs widget + being updated on every update point of the consumed signal. + -} + attrConsumer :: (Glib.GObjectClass gObject) + => Glib.ReadWriteAttr gObject readVal writeVal + -> gObject + -> Consumer SSignal writeVal + attrConsumer gAttr gObject = SSignal.consumer $ \val -> Glib.set gObject [gAttr Glib.:= val] + + -- |Constructs a producer of discrete signals that represent sequences of Gtk2Hs events. + eventProducer :: (Glib.GObjectClass gObject) + => (gObject -> IO () -> IO (Glib.ConnectId gObject)) + {-^ + an @on/EventType/@ function of Gtk2Hs, representing a certain kind of + event + -} + -> gObject + -- ^a Gtk2Hs widget which provides the events + -> Producer DSignal () + eventProducer onEvent gObject = DSignal.producer (register onEvent gObject . ($ ())) + + {-| + Constructs a producer of segmented signals whose values can be read with a certain I/O + action and which are updated updated on certain Gtk2Hs events. + -} + readEventProducer :: (Glib.GObjectClass gObject) + => (gObject -> IO val) + -- ^an action which provides the current value of the produced signal + -> (gObject -> IO () -> IO (Glib.ConnectId gObject)) + {-^ + an @on/EventType/@ function of Gtk2Hs whose corresponding events mark + the update points of the produced signal except the update point at the + beginning of the era + -} + -> gObject + -- ^a Gtk2Hs widget + -> Producer SSignal val + readEventProducer readVal onEvent gObject = SSignal.producer (readVal gObject) + (register onEvent gObject) + + {-| + Constructs a producer of segmented signals that reflect a Gtk2Hs attribute and are updated + on certain Gtk2Hs events. + -} + attrEventProducer :: (Glib.GObjectClass gObject) + => Glib.ReadWriteAttr gObject readVal writeVal + -- ^a Gtk2Hs attribute providing the values of the produced signal + -> (gObject -> IO () -> IO (Glib.ConnectId gObject)) + {-^ + an @on/EventType/@ function of Gtk2Hs whose corresponding events mark + the update points of the produced signal except the update point at the + beginning of the era + -} + -> gObject + -- ^a Gtk2Hs widget + -> Producer SSignal readVal + attrEventProducer gAttr = readEventProducer (flip Glib.get gAttr) + + register :: (Glib.GObjectClass gObject) + => (gObject -> IO () -> IO (Glib.ConnectId gObject)) + -> gObject + -> (IO () -> Setup) + register onEvent gObject handler = setup $ do + connectID <- onEvent gObject handler + return (Glib.signalDisconnect connectID) diff --git a/src/Graphics/UI/Grapefruit/GTK/Backend.hs b/src/Graphics/UI/Grapefruit/GTK/Backend.hs deleted file mode 100644 --- a/src/Graphics/UI/Grapefruit/GTK/Backend.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Graphics.UI.Grapefruit.GTK.Backend () where - - -- Graphics.UI.Grapefruit - import Graphics.UI.Grapefruit.Backend as Backend - - -- Graphics.UI.Gtk - import qualified Graphics.UI.Gtk as Gtk - - -- Graphics.UI.Grapefruit.GTK - import {-# SOURCE #-} Graphics.UI.Grapefruit.GTK as GTK - - instance UIBackend GTK where - - type WidgetPlacement GTK = Gtk.Widget -> IO () - - type WindowPlacement GTK = Gtk.Window -> IO () - - initialize GTK = Gtk.initGUI >> return () - - handleEvents GTK = Gtk.mainGUI - - requestQuitting GTK = Gtk.mainQuit - - finalize GTK = return () - - topLevel GTK = const (return ()) diff --git a/src/Graphics/UI/Grapefruit/GTK/Backend/Std.hs b/src/Graphics/UI/Grapefruit/GTK/Backend/Std.hs deleted file mode 100644 --- a/src/Graphics/UI/Grapefruit/GTK/Backend/Std.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Graphics.UI.Grapefruit.GTK.Backend.Std () where - - -- FRP.Grapefruit - import FRP.Grapefruit.Record as Record - import FRP.Grapefruit.Record.Context as ContextRecord - - -- Graphics.UI.Grapefruit - import Graphics.UI.Grapefruit.Backend.Std as StdUIBackend - - -- Graphics.UI.Gtk - import qualified Graphics.UI.Gtk as Gtk - - -- Graphics.UI.Grapefruit.GTK - import {-# SOURCE #-} Graphics.UI.Grapefruit.GTK as GTK - import Graphics.UI.Grapefruit.GTK.Connector as GTKConnector - import Graphics.UI.Grapefruit.GTK.Item as GTKUIItem - import Graphics.UI.Grapefruit.GTK.Backend as GTKUIBackend - - instance StdUIBackend GTK where - - label = widgetBrick (Gtk.labelNew Nothing) - (X :& Text ::~~ attrConsumer Gtk.labelLabel) - X - - pushButton = widgetBrick Gtk.buttonNew - (X :& Text ::~~ attrConsumer Gtk.buttonLabel) - (X :& Push ::~~ eventProducer Gtk.onPressed) - - box orientation = widgetBox (case orientation of - Horizontal -> newGtkBox Gtk.hBoxNew - Vertical -> newGtkBox Gtk.vBoxNew) - Gtk.containerAdd - X - X where - - newGtkBox rawNewGtkBox = fmap Gtk.toBox (rawNewGtkBox False 0) - - window = windowBox Gtk.windowNew - Gtk.containerAdd - (X :& Title ::~~ attrConsumer Gtk.windowTitle) - (X :& Closure ::~~ eventProducer Gtk.onDestroy) diff --git a/src/Graphics/UI/Grapefruit/GTK/Connector.hs b/src/Graphics/UI/Grapefruit/GTK/Connector.hs deleted file mode 100644 --- a/src/Graphics/UI/Grapefruit/GTK/Connector.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-| - This module provides convenience functions for constructing connectors specific to the - GTK+-based backend. --} -module Graphics.UI.Grapefruit.GTK.Connector ( - - attrConsumer, - eventProducer - -) where - - -- FRP.Grapefruit - import FRP.Grapefruit.Setup as Setup - import FRP.Grapefruit.Signal as Signal - import FRP.Grapefruit.Signal.Discrete as DSignal - import FRP.Grapefruit.Signal.Segmented as SSignal - - -- Graphics.UI.Gtk - import qualified Graphics.UI.Gtk as Gtk - - {-| - Constructs a consumer for segmented signals which makes a Gtk2Hs attribute of a Gtk2Hs - widget being updated on every update point of the consumed signal. - -} - attrConsumer :: (Gtk.WidgetClass gtkWidget) => - Gtk.Attr gtkWidget val -> gtkWidget -> Consumer SSignal val - attrConsumer attr gtkWidget = SSignal.consumer $ \val -> Gtk.set gtkWidget [attr Gtk.:= val] - - -- |Constructs a producer of discrete signals that represent sequences of Gtk2Hs events. - eventProducer :: (Gtk.WidgetClass gtkWidget) - => (gtkWidget -> IO () -> IO (Gtk.ConnectId gtkWidget)) - {-^ - an @on/EventType/@ function of Gtk2Hs, representing a certain kind of - event - -} - -> gtkWidget - -- ^a Gtk2Hs widget which provides the events - -> Producer DSignal () - eventProducer onEvent gtkWidget = DSignal.producer $ - \handler -> setup $ - do - connectID <- onEvent gtkWidget (handler ()) - return (Gtk.signalDisconnect connectID) diff --git a/src/Graphics/UI/Grapefruit/GTK/Item.hs b/src/Graphics/UI/Grapefruit/GTK/Item.hs deleted file mode 100644 --- a/src/Graphics/UI/Grapefruit/GTK/Item.hs +++ /dev/null @@ -1,123 +0,0 @@ --- |This module provides convenience functions for creating GTK+-based bricks and boxes. -module Graphics.UI.Grapefruit.GTK.Item ( - - widgetBrick, - windowBrick, - widgetBox, - windowBox - -) where - - -- FRP.Grapefruit - import FRP.Grapefruit.Signal.Segmented as SSignal - import FRP.Grapefruit.Record as Record - import FRP.Grapefruit.Record.Optionality as OptionalityRecord - import FRP.Grapefruit.Record.Context as ContextRecord - - -- Graphics.UI.Grapefruit - import Graphics.UI.Grapefruit.Comp as UIComp - import Graphics.UI.Grapefruit.Item as UIItem - import qualified Graphics.UI.Grapefruit.Item as UIItem - import Graphics.UI.Grapefruit.Backend as UIBackend - - -- Graphics.UI.Gtk - import qualified Graphics.UI.Gtk as Gtk - - -- Graphics.UI.Grapefruit.GTK - import {-# SOURCE #-} Graphics.UI.Grapefruit.GTK as GTK - import Graphics.UI.Grapefruit.GTK.Backend as GTKUIBackend - - -- |Constructs a GTK+-based widget brick. - widgetBrick :: (Gtk.WidgetClass gtkWidget, OptRecord iOptRecord, Record oRecord) - => IO gtkWidget - -- ^an action which creates a Gtk2Hs widget - -> ContextConsumerRecord gtkWidget (All iOptRecord) - -- ^consumers of those inputs which are specific to this brick - -> ContextProducerRecord gtkWidget oRecord - -- ^producers of those outputs which are specific to this brick - -> Brick Widget GTK iOptRecord oRecord - widgetBrick = brick commonWidgetConsumerRecord commonWidgetProducerRecord Gtk.widgetShow . - newWidget - - -- |Constructs a GTK+-based window brick. - windowBrick :: (Gtk.WindowClass gtkWindow, OptRecord iOptRecord, Record oRecord) - => IO gtkWindow - -- ^an action which creates a Gtk2Hs window - -> ContextConsumerRecord gtkWindow (All iOptRecord) - -- ^consumers of those inputs which are specific to this brick - -> ContextProducerRecord gtkWindow oRecord - -- ^producers of those outputs which are specific to this brick - -> Brick Window GTK iOptRecord oRecord - windowBrick = brick commonWindowConsumerRecord commonWindowProducerRecord Gtk.widgetShow . - newWindow - - -- |Constructs a GTK+-based widget box. - widgetBox :: (Gtk.WidgetClass gtkWidget, - UIComp innerUIComp, - OptRecord iOptRecord, - Record oRecord) - => IO gtkWidget - -- ^an action which creates a Gtk2Hs widget - -> (gtkWidget -> Placement innerItem GTK) - -- ^conversion from a Gtk2Hs widget into the placement for its inner items - -> ContextConsumerRecord gtkWidget (All iOptRecord) - -- ^consumers of those inputs which are specific to this box - -> ContextProducerRecord gtkWidget oRecord - -- ^producers of those outputs which are specific to this box - -> Box innerUIComp innerItem Widget GTK iOptRecord oRecord - widgetBox = box commonWidgetConsumerRecord commonWidgetProducerRecord Gtk.widgetShow . newWidget - - -- |Constructs a GTK+-based window box. - windowBox :: (Gtk.WindowClass gtkWindow, - UIComp innerUIComp, - OptRecord iOptRecord, - Record oRecord) - => IO gtkWindow - -- ^an action which creates a Gtk2Hs window - -> (gtkWindow -> Placement innerItem GTK) - -- ^conversion from a Gtk2Hs window into the placement for its inner items - -> ContextConsumerRecord gtkWindow (All iOptRecord) - -- ^consumers of those inputs which are specific to this box - -> ContextProducerRecord gtkWindow oRecord - -- ^producers of those outputs which are specific to this box - -> Box innerUIComp innerItem Window GTK iOptRecord oRecord - windowBox = box commonWindowConsumerRecord commonWindowProducerRecord Gtk.widgetShow . newWindow - - newWidget :: (Gtk.WidgetClass gtkWidget) - => IO gtkWidget - -> Placement Widget GTK - -> IO gtkWidget - newWidget = newItem Gtk.toWidget - - newWindow :: (Gtk.WindowClass gtkWindow) - => IO gtkWindow - -> Placement Window GTK - -> IO gtkWindow - newWindow = newItem Gtk.toWindow - - newItem :: (specificItem -> genericItem) - -> IO specificItem - -> (genericItem -> IO ()) - -> IO specificItem - newItem genericItem newSpecificItem placement = do - specificItem <- newSpecificItem - placement (genericItem specificItem) - return specificItem - - commonWidgetConsumerRecord :: (Gtk.WidgetClass gtkWidget) - => ContextConsumerRecord gtkWidget - (All (CommonInputOptRecord Widget)) - commonWidgetConsumerRecord = X :& IsEnabled ::~~ SSignal.consumer . Gtk.widgetSetSensitivity - - commonWidgetProducerRecord :: (Gtk.WidgetClass gtkWidget) - => ContextProducerRecord gtkWidget (CommonOutputRecord Window) - commonWidgetProducerRecord = X - - commonWindowConsumerRecord :: (Gtk.WindowClass gtkWindow) - => ContextConsumerRecord gtkWindow - (All (CommonInputOptRecord Window)) - commonWindowConsumerRecord = X - - commonWindowProducerRecord :: (Gtk.WindowClass gtkWindow) - => ContextProducerRecord gtkWindow (CommonOutputRecord Window) - commonWindowProducerRecord = X