grapefruit-ui 0.0.0.0 → 0.1.0.0
raw patch · 8 files changed
+345/−187 lines, 8 filesdep +colourdep +containersdep +fractiondep ~basedep ~grapefruit-frpdep ~grapefruit-records
Dependencies added: colour, containers, fraction
Dependency ranges changed: base, grapefruit-frp, grapefruit-records
Files
- LICENSE +1/−0
- grapefruit-ui.cabal +26/−14
- src/Graphics/UI/Grapefruit/Backend/Basic.hs +152/−0
- src/Graphics/UI/Grapefruit/Backend/Container.hs +80/−0
- src/Graphics/UI/Grapefruit/Backend/Std.hs +0/−129
- src/Internal/Interfacing.hs +11/−7
- src/Internal/UICircuit.hs +37/−23
- src/Internal/UIItem.hs +38/−14
LICENSE view
@@ -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
grapefruit-ui.cabal view
@@ -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
+ src/Graphics/UI/Grapefruit/Backend/Basic.hs view
@@ -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
+ src/Graphics/UI/Grapefruit/Backend/Container.hs view
@@ -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
− src/Graphics/UI/Grapefruit/Backend/Std.hs
@@ -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
src/Internal/Interfacing.hs view
@@ -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)
src/Internal/UICircuit.hs view
@@ -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?
src/Internal/UIItem.hs view
@@ -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.