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.cabal b/grapefruit-ui.cabal --- a/grapefruit-ui.cabal +++ b/grapefruit-ui.cabal @@ -1,15 +1,15 @@ Name: grapefruit-ui -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/0.0.0.0/grapefruit-ui-0.0.0.0.tar.gz +Homepage: http://grapefruit-project.org/ +Package-URL: http://hackage.haskell.org/packages/archive/grapefruit-ui/0.1.0.0/grapefruit-ui-0.1.0.0.tar.gz Synopsis: 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 @@ -22,18 +22,29 @@ moment, the only backend is one based on GTK+. This is provided by the grapefruit-ui-gtk package. 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: arrows >= 0.2 && < 0.5, - base >= 3.0 && < 4.1, - grapefruit-frp >= 0.0 && < 0.1, - grapefruit-records >= 0.0 && < 0.1 + Build-Depends: arrows >= 0.2 && < 0.5, + 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 Extensions: Arrows - CPP EmptyDataDecls FlexibleContexts + GADTs GeneralizedNewtypeDeriving Rank2Types TypeFamilies @@ -43,7 +54,8 @@ Graphics.UI.Grapefruit.Interfacing Graphics.UI.Grapefruit.Item Graphics.UI.Grapefruit.Backend - Graphics.UI.Grapefruit.Backend.Std + Graphics.UI.Grapefruit.Backend.Basic + Graphics.UI.Grapefruit.Backend.Container Other-Modules: Internal.Interfacing Internal.UICircuit Internal.UIItem diff --git a/src/Graphics/UI/Grapefruit/Backend/Basic.hs b/src/Graphics/UI/Grapefruit/Backend/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Grapefruit/Backend/Basic.hs @@ -0,0 +1,152 @@ +{-| + This module declares a subclass of 'UIBackend' with methods that every reasonable UI backend + should implement. +-} +module Graphics.UI.Grapefruit.Backend.Basic ( + + -- * Interface + BasicUIBackend (..), + + -- * Utilities + Orientation (Horizontal, Vertical), + Caption (ColdCaption, HotCaption), + + -- * Field names + Closure (Closure), + Content (Content), + Push (Push), + Text (Text), + Title (Title) + +) where + + -- Data + import Data.Record as Record + import Data.Record.Optionality as OptionalityRecord + + -- FRP.Grapefruit + import FRP.Grapefruit.Signal as Signal + import FRP.Grapefruit.Signal.Discrete as DSignal + import FRP.Grapefruit.Signal.Segmented as SSignal + + -- Graphics.UI.Grapefruit + import Graphics.UI.Grapefruit.Item as UIItem + import Graphics.UI.Grapefruit.Circuit as UICircuit + import Graphics.UI.Grapefruit.Backend as UIBackend + + -- * Interface + -- |A subclass of 'UIBackend' which declares basic bricks and boxes. + class (UIBackend uiBackend) => BasicUIBackend uiBackend where + + -- |A widget showing one line of text. + label :: Brick Widget uiBackend (X :& Req Text ::: SSignal `Of` String) X + + -- |A push button. + pushButton :: Brick Widget uiBackend (X :& Req Text ::: SSignal `Of` String) + (X :& Push ::: DSignal `Of` ()) + + -- |An editor for a single line of text. + lineEditor :: Brick Widget uiBackend X + (X :& Content ::: SSignal `Of` String) + + -- |A widget which aggregates and arbitrary number of other widgets. + box :: Orientation -> Box UICircuit Widget Widget uiBackend X X + + -- |An ordinary window. + window :: Box UIItem Widget Window uiBackend (X :& Req Title ::: SSignal `Of` String) + (X :& Closure ::: DSignal `Of` ()) + + -- * Utilities + -- |An orientation of widgets in a box. + data Orientation = Horizontal | Vertical + + {-| + A caption of a widget with an optional hotkey marker. + + Currently, this type is not used. + -} + data Caption = ColdCaption String + -- ^a caption without a hotkey + | HotCaption String Char String + -- ^a caption consisting of a prefix string, a hotkey and a suffix string + + -- * Field names + {-| + A field name. + + Typical properties: + + [kind] + output + + [type] + @'DSignal' `'Of'` ()@ + + [meaning] + a “window was closed” event + -} + data Closure = Closure + + {-| + A field name. + + Typical properties: + + [kind] + output + + [type] + @'SSignal' `'Of'` /val/@ for some type @/val/@ + + [meaning] + the content of an editor widget + -} + data Content = Content + + {-| + A field name. + + Typical properties: + + [kind] + output + + [type] + @'DSignal' `'Of'` ()@ + + [meaning] + a stream of button push events + -} + data Push = Push + + {-| + A field name. + + Typical properties: + + [kind] + input (required) + + [type] + @'SSignal' `'Of'` String@ + + [meaning] + the caption of a widget + -} + data Text = Text + + {-| + A field name. + + Typical properties: + + [kind] + input (required) + + [type] + @'SSignal' `'Of'` String@ + + [meaning] + the title of a window + -} + data Title = Title diff --git a/src/Graphics/UI/Grapefruit/Backend/Container.hs b/src/Graphics/UI/Grapefruit/Backend/Container.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Grapefruit/Backend/Container.hs @@ -0,0 +1,80 @@ +module Graphics.UI.Grapefruit.Backend.Container ( + + -- * Interface + ContainerUIBackend (..), + + -- * Utilities + Column (Column), + TextCellDisplay (TextCellDisplay), + ProgressCellDisplay (ProgressCellDisplay), + Availability (Never, AsNecessary, Always), + + -- * Field names + Elements (Elements), + Columns (Columns), + HasScrollbars (HasScrollbars), + Selection (Selection) + +) where + + -- Data + import Data.Sequence as Seq + import Data.Set as Set + import Data.Fraction as Fraction + import Data.Colour.RGBSpace as RGBSpace + import Data.Record as Record + import Data.Record.Optionality as OptionalityRecord + + -- FRP.Grapefruit + import FRP.Grapefruit.Signal as Signal + import FRP.Grapefruit.Signal.Segmented as SSignal + import FRP.Grapefruit.Signal.Incremental as ISignal + + -- Graphics.UI.Grapefruit + import Graphics.UI.Grapefruit.Item as UIItem + import Graphics.UI.Grapefruit.Backend.Basic as BasicUIBackend + + -- * Interface + class (BasicUIBackend uiBackend) => ContainerUIBackend uiBackend where + + listView :: Brick Widget + uiBackend + (X :& Req Elements ::: ISignal `Of` Seq el + :& Req Columns ::: ISignal `Of` Seq (Column uiBackend el) + :& Opt HasScrollbars ::: SSignal `Of` (Orientation -> Availability)) + (X :& Selection ::: SSignal `Of` Seq el) + + setView :: (Ord el) => + Brick Widget + uiBackend + (X :& Req Elements ::: ISignal `Of` Set el + :& Req Columns ::: ISignal `Of` Seq (Column uiBackend el) + :& Opt HasScrollbars ::: SSignal `Of` (Orientation -> Availability)) + (X :& Selection ::: SSignal `Of` Set el) + + data Cell uiBackend :: * -> * + + textCell :: Cell uiBackend TextCellDisplay + + progressCell :: Cell uiBackend ProgressCellDisplay + + -- * Utilities + data Column uiBackend el where + + Column :: String -> (el -> display) -> Cell uiBackend display -> Column uiBackend el + + data TextCellDisplay = TextCellDisplay String (RGB Fraction) + + data ProgressCellDisplay = ProgressCellDisplay Fraction (Maybe String) + + -- FIXME: This should probably go into some more general module. + data Availability = Never | AsNecessary | Always + + -- * Field names + data Elements = Elements + + data Columns = Columns + + data HasScrollbars = HasScrollbars + + data Selection = Selection diff --git a/src/Graphics/UI/Grapefruit/Backend/Std.hs b/src/Graphics/UI/Grapefruit/Backend/Std.hs deleted file mode 100644 --- a/src/Graphics/UI/Grapefruit/Backend/Std.hs +++ /dev/null @@ -1,129 +0,0 @@ -{-| - This module declares a subclass of 'UIBackend' with methods that every reasonable UI backend - should implement. --} -module Graphics.UI.Grapefruit.Backend.Std ( - - -- * Interface - StdUIBackend (..), - - -- * Utilities - Orientation (Horizontal, Vertical), - Caption (ColdCaption, HotCaption), - - -- * Field names - Closure (Closure), - Push (Push), - Text (Text), - Title (Title) - -) where - - -- FRP.Grapefruit - import FRP.Grapefruit.Signal as Signal - import FRP.Grapefruit.Signal.Discrete as DSignal - import FRP.Grapefruit.Signal.Segmented as SSignal - import FRP.Grapefruit.Record as Record - import FRP.Grapefruit.Record.Optionality as OptionalityRecord - - -- Graphics.UI.Grapefruit - import Graphics.UI.Grapefruit.Backend as UIBackend - import Graphics.UI.Grapefruit.Item as UIItem - import Graphics.UI.Grapefruit.Circuit as UICircuit - - -- * Interface - -- |A subclass of 'UIBackend' which declares standard bricks and boxes. - class (UIBackend uiBackend) => StdUIBackend uiBackend where - - -- |A widget showing one line of text. - label :: Brick Widget uiBackend (X :& Req Text ::: SSignal `Of` String) X - - -- |A push button. - pushButton :: Brick Widget uiBackend (X :& Req Text ::: SSignal `Of` String) - (X :& Push ::: DSignal `Of` ()) - - -- |A widget which aggregates and arbitrary number of other widgets. - box :: Orientation -> Box UICircuit Widget Widget uiBackend X X - - -- |An ordinary window. - window :: Box UIItem Widget Window uiBackend (X :& Req Title ::: SSignal `Of` String) - (X :& Closure ::: DSignal `Of` ()) - - -- * Utilities - -- |An orientation of widgets in a box. - data Orientation = Horizontal | Vertical - - {-| - A caption of a widget with an optional hotkey marker. - - Currently, this type is not used. - -} - data Caption = ColdCaption String - -- ^a caption without a hotkey - | HotCaption String Char String - -- ^a caption consisting of a prefix string, a hotkey and a suffix string - - -- * Field names - {-| - A field name. - - Typical properties: - - [kind] - output - - [type] - @'DSignal' `'Of'` ()@ - - [meaning] - a “window was closed” event - -} - data Closure = Closure - - {-| - A field name. - - Typical properties: - - [kind] - output - - [type] - @'DSignal' `'Of'` ()@ - - [meaning] - a stream of button push events - -} - data Push = Push - - {-| - A field name. - - Typical properties: - - [kind] - input (required) - - [type] - @'SSignal' `'Of'` String@ - - [meaning] - the caption of a widget - -} - data Text = Text - - {-| - A field name. - - Typical properties: - - [kind] - input (required) - - [type] - @'SSignal' `'Of'` String@ - - [meaning] - the title of a window - -} - data Title = Title diff --git a/src/Internal/Interfacing.hs b/src/Internal/Interfacing.hs --- a/src/Internal/Interfacing.hs +++ b/src/Internal/Interfacing.hs @@ -15,10 +15,13 @@ import Control.Arrow.Operations as ArrowOperations import Control.Arrow.Transformer.Reader as ReaderArrow + -- Data + import Data.Record as Record + import Data.Record.Signal as SignalRecord + import Data.Record.Signal.Context as ContextSignalRecord + -- FRP.Grapefruit - import FRP.Grapefruit.Circuit as Circuit - import FRP.Grapefruit.Record as Record - import FRP.Grapefruit.Record.Context as ContextRecord + import FRP.Grapefruit.Circuit as Circuit -- Internal import {-# SOURCE #-} Internal.UIItem as UIItem @@ -28,7 +31,7 @@ import Graphics.UI.Grapefruit.Comp as UIComp -- Fixities - infixl 1 `With` + infixr 1 `With` -- * Interfacing {-| @@ -48,13 +51,14 @@ fields without a corresponding signal field. Connectors, for which no signal field exists, are not performed. -} - basic :: (Subrecord extIShape iShape, Subrecord extOShape oShape) + basic :: (Record SignalKind extIShape, Record SignalKind extOShape, + Subrecord extIShape iShape, Subrecord extOShape oShape) => ContextConsumerRecord nativeItem iShape -> ContextProducerRecord nativeItem oShape -> Interfacing nativeItem era (SignalRecord era extIShape) (SignalRecord era extOShape) basic consumerRecord producerRecord = Interfacing $ - ContextRecord.consume (narrow consumerRecord) >>> - ContextRecord.produce (narrow producerRecord) + ContextSignalRecord.consume (narrow consumerRecord) >>> + ContextSignalRecord.produce (narrow producerRecord) inner :: (UIComp uiComp) => (nativeItem -> Placement innerItem uiBackend) diff --git a/src/Internal/UICircuit.hs b/src/Internal/UICircuit.hs --- a/src/Internal/UICircuit.hs +++ b/src/Internal/UICircuit.hs @@ -10,12 +10,11 @@ import Prelude hiding ((.)) -- Control -#if __GLASGOW_HASKELL__ >= 610 import Control.Category as Category hiding (id) import qualified Control.Category as Category -#endif import Control.Arrow as Arrow import Control.Arrow.Transformer.Reader as ReaderArrow + import Control.Concurrent.MVar as MVar -- FRP.Grapefruit import FRP.Grapefruit.Circuit as Circuit @@ -41,22 +40,16 @@ o) -- manual deriving because of GHC bug #1133 -#if __GLASGOW_HASKELL__ >= 610 instance Category (UICircuit item uiBackend era) where id = UICircuit Category.id UICircuit arrow1 . UICircuit arrow2 = UICircuit (arrow1 . arrow2) -#endif instance Arrow (UICircuit item uiBackend era) where arr fun = UICircuit (arr fun) -#if __GLASGOW_HASKELL__ < 610 - UICircuit arrow1 >>> UICircuit arrow2 = UICircuit (arrow1 >>> arrow2) -#endif - first (UICircuit arrow) = UICircuit (first arrow) second (UICircuit arrow) = UICircuit (second arrow) @@ -93,20 +86,41 @@ quantification of the circuit’s era parameter ensures that the circuit does not use signals which are produced outside the circuit and therefore avoids era mismatches. -} - run :: (UIBackend uiBackend) => - uiBackend -> (forall era. UICircuit Window uiBackend era () (DSignal era ())) -> IO () - run uiBackend uiCircuit = run where + run :: (UIBackend uiBackend) + => uiBackend + -- ^the user interface backend to use + -> (forall era. UICircuit Window uiBackend era i (DSignal era o)) + -- ^the circuit to run + -> i + -- ^the input of the ciruit + -> IO o + {-^ + an action running the circuit and returning the value of the output signal’s + first occurence + -} + run uiBackend uiCircuit i = run where - run = do - UIBackend.initialize uiBackend - (_,finalizeCircuit) <- Circuit.create circuit () - UIBackend.handleEvents uiBackend - finalizeCircuit - UIBackend.finalize uiBackend - -- Where are the top level windows removed? + run = do + oMVar <- newEmptyMVar + UIBackend.initialize uiBackend + let - circuit = proc _ -> do - quittingReq <- runReader $ - case uiCircuit of UICircuit arrow -> arrow - -< ((),topLevel uiBackend) - consume $ DSignal.consumer (const (requestQuitting uiBackend)) -< quittingReq + circuitCreation = Circuit.create + (proc _ -> do + quittingReq <- runReader $ + case uiCircuit of + UICircuit arrow -> arrow + -< (i,topLevel uiBackend) + consume $ DSignal.consumer qReqHdlr -< quittingReq) + () + + qReqHdlr o = do + requestQuitting uiBackend + putMVar oMVar o + + (_,finalizeCircuit) <- circuitCreation + UIBackend.handleEvents uiBackend + finalizeCircuit + UIBackend.finalize uiBackend + takeMVar oMVar + -- Where are the top level windows removed? diff --git a/src/Internal/UIItem.hs b/src/Internal/UIItem.hs --- a/src/Internal/UIItem.hs +++ b/src/Internal/UIItem.hs @@ -31,13 +31,17 @@ import Control.Arrow.Operations as ArrowOperations import Control.Arrow.Transformer.Reader as ReaderArrow + -- Data + import Data.Record as Record + import Data.Record.Optionality as OptionalityRecord + import Data.Record.Signal as SignalRecord + import Data.Record.Signal.Context as ContextSignalRecord + -- FRP.Grapefruit - import FRP.Grapefruit.Circuit as Circuit - import FRP.Grapefruit.Signal as Signal - 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 + import FRP.Grapefruit.Setup as Setup + import FRP.Grapefruit.Circuit as Circuit + import FRP.Grapefruit.Signal as Signal + import FRP.Grapefruit.Signal.Segmented as SSignal -- Graphics.UI.Grapefruit import Graphics.UI.Grapefruit.Backend as UIBackend @@ -50,6 +54,9 @@ -- Graphics.UI.Grapefruit import Graphics.UI.Grapefruit.Comp as UIComp + -- Fixities + infixr 6 `with` + -- * User interface items in general {-| The type of user interface items. @@ -92,7 +99,7 @@ arrow = proc (i,placement) -> do nativeItem <- act -< newItem placement o <- runReader interfacingImpl -< (i,nativeItem) - _ <- act -< showItem nativeItem + _ <- putSetup -< Setup.fromIO $ showItem nativeItem returnA -< o -- * Bricks @@ -111,7 +118,9 @@ -} newtype Brick item uiBackend iOptRecord oRecord = Brick (forall era extIRecord extORecord. - (Subrecord extIRecord + (Record SignalKind extIRecord, + Record SignalKind extORecord, + Subrecord extIRecord (All iOptRecord `Cat` All (CommonInputOptRecord item)), Subrecord (Required iOptRecord `Cat` Required (CommonInputOptRecord item)) extIRecord, @@ -121,7 +130,10 @@ (SignalRecord era extORecord)) -- |Constructs a brick. - brick :: (Item item, OptRecord iOptRecord, Record oRecord) + brick :: (Item item, + OptRecord iOptRecord, + Record SignalKind (All iOptRecord), + Record SignalKind oRecord) => ContextConsumerRecord nativeItem (All (CommonInputOptRecord item)) {-^ consumers of those inputs which are common to all bricks of the respective item @@ -176,7 +188,9 @@ and output field names have to be known at the call site. For the output field names, this is usually done via pattern matching. -} - just :: (Subrecord extIRecord + just :: (Record SignalKind extIRecord, + Record SignalKind extORecord, + Subrecord extIRecord (All iOptRecord `Cat` All (CommonInputOptRecord item)), Subrecord (Required iOptRecord `Cat` Required (CommonInputOptRecord item)) extIRecord, @@ -202,7 +216,9 @@ -} newtype Box innerUIComp innerItem item uiBackend iOptRecord oRecord = Box (forall era extIRecord extORecord innerI innerO. - (Subrecord extIRecord + (Record SignalKind extIRecord, + Record SignalKind extORecord, + Subrecord extIRecord (All iOptRecord `Cat` All (CommonInputOptRecord item)), Subrecord (Required iOptRecord `Cat` Required (CommonInputOptRecord item)) extIRecord, @@ -213,7 +229,11 @@ (SignalRecord era extORecord `With` innerO)) -- |Constructs a box. - box :: (UIComp innerUIComp, Item item, OptRecord iOptRecord, Record oRecord) + box :: (UIComp innerUIComp, + Item item, + OptRecord iOptRecord, + Record SignalKind (All iOptRecord), + Record SignalKind oRecord) => ContextConsumerRecord nativeItem (All (CommonInputOptRecord item)) {-^ consumers of those inputs which are common to all bricks of the respective item @@ -257,7 +277,9 @@ Applications of @with@ are usually written infix. -} - with :: (Subrecord extIRecord + with :: (Record SignalKind extIRecord, + Record SignalKind extORecord, + Subrecord extIRecord (All iOptRecord `Cat` All (CommonInputOptRecord item)), Subrecord (Required iOptRecord `Cat` Required (CommonInputOptRecord item)) extIRecord, @@ -276,7 +298,9 @@ Instances of this class serve as phantom parameters of 'UIItem', 'UICircuit' and others. -} - class (OptRecord (CommonInputOptRecord item), Record (CommonOutputRecord item)) => + class (OptRecord (CommonInputOptRecord item), + Record SignalKind (All (CommonInputOptRecord item)), + Record SignalKind (CommonOutputRecord item)) => Item item where -- |Inputs which are shared by all items of the respective kind.