diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright © 2007–2009 Brandenburgische Technische Universität Cottbus +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted +provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of conditions + and the following disclaimer. + + * Redistributions in binary form must reproduce the above copyright notice, this list of + conditions and the following disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holders nor the names of the contributors may be used to + endorse or promote products derived from this software without specific prior written + permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS “AS IS” AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR +CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF +THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#!/usr/bin/env runghc + +> import Distribution.Simple +> main = defaultMain diff --git a/grapefruit-ui.cabal b/grapefruit-ui.cabal new file mode 100644 --- /dev/null +++ b/grapefruit-ui.cabal @@ -0,0 +1,50 @@ +Name: grapefruit-ui +Version: 0.0.0.0 +Cabal-Version: >= 1.2.3 +Build-Type: Simple +License: BSD3 +License-File: LICENSE +Copyright: © 2007–2009 Brandenburgische Technische Universität Cottbus +Author: Wolfgang Jeltsch +Maintainer: jeltsch@informatik.tu-cottbus.de +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 +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 + in a declarative style. To learn more about FRP, have a look at + . + . + This package contains general user interface support. To make use of it, it has to be + complemented by a UI backend. It is possible to have different UI backends + implementing the same general interface on top of different UI toolkits. At the + 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 + +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 + Extensions: Arrows + CPP + EmptyDataDecls + FlexibleContexts + GeneralizedNewtypeDeriving + Rank2Types + TypeFamilies + TypeOperators + Exposed-Modules: Graphics.UI.Grapefruit.Circuit + Graphics.UI.Grapefruit.Comp + Graphics.UI.Grapefruit.Interfacing + Graphics.UI.Grapefruit.Item + Graphics.UI.Grapefruit.Backend + Graphics.UI.Grapefruit.Backend.Std + Other-Modules: Internal.Interfacing + Internal.UICircuit + Internal.UIItem + HS-Source-Dirs: src diff --git a/src/Graphics/UI/Grapefruit/Backend.hs b/src/Graphics/UI/Grapefruit/Backend.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Grapefruit/Backend.hs @@ -0,0 +1,47 @@ +-- |This module defines the basic interface to all user interface backends. +module Graphics.UI.Grapefruit.Backend ( + + UIBackend (..) + +) where + + -- Graphics.UI.Grapefruit + import {-# SOURCE #-} Internal.UIItem as UIItem + + {-| + The class of all user interface backends. + + A backend is represented by a type. This technique allows the class system to be used to + manage different implementations of the same interface. @UIBackend@ declares an interface to + basic functionality and is implemented by all user interface backends. Subclasses of + @UIBackend@ extend the basic interface. A backend can be an instance of only some of these + subclasses when some functionality is not yet implemented or cannot be provided by the + backend. Backend types are typically used as phantom parameters. However, in some cases, an + explicit value of a backend type is needed as a function argument. Therefore, a backend is + usually a single-value type whose only value is named like the type. + + All associated types and methods of @UIBackend@ are used internally by Grapefruit and should + not be used directly by the user. + -} + class UIBackend uiBackend where + + -- |@WidgetPlacement /uiBackend/@ provides the result of @'Placement' 'Widget' /uiBackend/@. + type WidgetPlacement uiBackend :: * + + -- |@WindowPlacement /uiBackend/@ provides the result of @'Placement' 'Window' /uiBackend/@. + type WindowPlacement uiBackend :: * + + -- |Initializes the backend. + initialize :: uiBackend -> IO () + + -- |Executes the event handling loop. + handleEvents :: uiBackend -> IO () + + -- |Asks the event handling loop to quit. + requestQuitting :: uiBackend -> IO () + + -- |Finalizes the backend. + finalize :: uiBackend -> IO () + + -- |Yields the placement of top-level windows. + topLevel :: uiBackend -> Placement Window uiBackend diff --git a/src/Graphics/UI/Grapefruit/Backend/Std.hs b/src/Graphics/UI/Grapefruit/Backend/Std.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Grapefruit/Backend/Std.hs @@ -0,0 +1,129 @@ +{-| + 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/Graphics/UI/Grapefruit/Circuit.hs b/src/Graphics/UI/Grapefruit/Circuit.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Grapefruit/Circuit.hs @@ -0,0 +1,21 @@ +{-FIXME: + Once Haddock supports cross-package links to modules, make FRP.Grapefruit.Circuit below a + hyperlink. +-} +{-| + This module provides support for user interface circuits. + + UI circuits are systems of UI items (for example, widgets). They are similar to ordinary + circuits as provided by FRP.Grapefruit.Circuit but have the additional feature of providing + parts of user interfaces. +-} +module Graphics.UI.Grapefruit.Circuit ( + + UICircuit, + fromCircuit, + run + +) where + + -- Internal.Circuit + import Internal.UICircuit as UICircuit diff --git a/src/Graphics/UI/Grapefruit/Comp.hs b/src/Graphics/UI/Grapefruit/Comp.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Grapefruit/Comp.hs @@ -0,0 +1,92 @@ +{-| + This module provides general support for user interface components. + + A user interface component is either a user interface item or a user interface circuit. UI items + are introduced by "Graphics.UI.Grapefruit.Item" and UI circuits by + "Graphics.UI.Grapefruit.Circuit". +-} +module Graphics.UI.Grapefruit.Comp ( + + UIComp ((|>>), (>>|), loop, toUICircuit, fromUIItem), + (<<|), + (|<<) + +) where + + -- Control + import Control.Arrow as Arrow -- for documentation only + + -- FRP.Grapefruit + import FRP.Grapefruit.Circuit as Circuit + + -- Internal + import {-# SOURCE #-} Internal.UICircuit as UICircuit + import {-# SOURCE #-} Internal.UIItem as UIItem + + {-| + The class of all user interface components. + + A user interface component is a part of a user interface which communicates with the + remainder of the user interface through signals. + -} + class UIComp uiComp where + + infixr 1 |>> + {-| + Adds a circuit before a user interface component. + + This does not add any items to the user interface but may add data manipulation and + control functionality. + -} + (|>>) :: Circuit era i tmp + -> uiComp item uiBackend era tmp o + -> uiComp item uiBackend era i o + + infixr 1 >>| + {-| + Adds a circuit after a user interface component. + + This does not add any items to the user interface but may add data manipulation and + control functionality. + -} + (>>|) :: uiComp item uiBackend era i tmp + -> Circuit era tmp o + -> uiComp item uiBackend era i o + + {-| + Adds a feedback loop to a user interface component. + + This method is completely analogous to the 'Arrow.loop' method of 'ArrowLoop'. It is + provided because not every instance of @UIComp@ is an arrow. + -} + loop :: uiComp item uiBackend era (i,feedback) (o,feedback) -> uiComp item uiBackend era i o + + -- |Converts a user interface component into a user interface circuit. + toUICircuit :: uiComp item uiBackend era i o -> UICircuit item uiBackend era i o + + -- |Converts a user interface item into a user interface component. + fromUIItem :: UIItem item uiBackend era i o -> uiComp item uiBackend era i o + + {-| + Puts a circuit before a user interface component. + + This does not add any items to the user interface but may add data manipulation and control + functionality. @(<<|)@ is equivalent to @flip ('|>>')@. + -} + (<<|) :: (UIComp uiComp) + => uiComp item uiBackend era tmp o + -> Circuit era i tmp + -> uiComp item uiBackend era i o + (<<|) = flip (|>>) + + {-| + Puts a circuit after a user interface component. + + This does not add any items to the user interface but may add data manipulation and control + functionality. @(|<<)@ is equivalent to @flip ('>>|')@. + -} + (|<<) :: (UIComp uiComp) + => Circuit era tmp o + -> uiComp item uiBackend era i tmp + -> uiComp item uiBackend era i o + (|<<) = flip (>>|) diff --git a/src/Graphics/UI/Grapefruit/Interfacing.hs b/src/Graphics/UI/Grapefruit/Interfacing.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Grapefruit/Interfacing.hs @@ -0,0 +1,15 @@ +-- |This module is about creating interfaces of UI items. +module Graphics.UI.Grapefruit.Interfacing ( + + -- * Interfacing + Interfacing, + basic, + with, + + -- * Inner components + With (With) + +) where + + -- Internal + import Internal.Interfacing as Interfacing diff --git a/src/Graphics/UI/Grapefruit/Item.hs b/src/Graphics/UI/Grapefruit/Item.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Grapefruit/Item.hs @@ -0,0 +1,38 @@ +{-| + This module provides support for user interface items. + + UI items are the building blocks of user interfaces. Typical items are widgets and windows. A UI + item may contain another item or a UI circuit which is a system of UI items. An example of the + former case is a window which contains a single widget. An example of the latter case is a box + widget which contains an arbitrary number of other widgets. +-} +module Graphics.UI.Grapefruit.Item ( + + -- * User interface items in general + UIItem, + item, + + -- * Bricks + Brick, + brick, + just, + + -- * Boxes + Box, + box, + with, + With (With), + + -- * Kinds of items + Item (type CommonInputOptRecord, type CommonOutputRecord), + Placement, + Widget, + Window, + + -- * Field names + IsEnabled (IsEnabled) + +) where + + -- Internal + import Internal.UIItem as UIItem diff --git a/src/Internal/Interfacing.hs b/src/Internal/Interfacing.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Interfacing.hs @@ -0,0 +1,98 @@ +module Internal.Interfacing ( + + -- * Interfacing + Interfacing (Interfacing), + basic, + with, + + -- * Inner components + With (With) + +) where + + -- Control + import Control.Arrow as Arrow + import Control.Arrow.Operations as ArrowOperations + import Control.Arrow.Transformer.Reader as ReaderArrow + + -- FRP.Grapefruit + import FRP.Grapefruit.Circuit as Circuit + import FRP.Grapefruit.Record as Record + import FRP.Grapefruit.Record.Context as ContextRecord + + -- Internal + import {-# SOURCE #-} Internal.UIItem as UIItem + import Internal.UICircuit as UICircuit + + -- Graphics.UI.Grapefruit + import Graphics.UI.Grapefruit.Comp as UIComp + + -- Fixities + infixl 1 `With` + + -- * Interfacing + {-| + Describes communication of an item with its environment. + + An interfacing is a mapping from native items to circuits. These circuits handle input + consumption and output production. + -} + newtype Interfacing nativeItem era i o = Interfacing (ReaderArrow nativeItem (Circuit era) i o) + + {-| + Creates an interfacing based on signal connectors (consumers and producers). + + The input and output are signal records. The only restriction to these records is that their + fields must have corresponding fields in the connector records. The order of fields in the + signal records may differ from the order of connector fields and there may be connector + fields without a corresponding signal field. Connectors, for which no signal field exists, + are not performed. + -} + basic :: (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) + + inner :: (UIComp uiComp) + => (nativeItem -> Placement innerItem uiBackend) + -> uiComp innerItem uiBackend era innerI innerO + -> Interfacing nativeItem era innerI innerO + inner placement innerComp = Interfacing $ + arr id &&& (readState >>> arr placement) >>> + liftReader (runReader innerArrow) where + + UICircuit innerArrow = toUICircuit innerComp + + {-| + Extends an interfacing so that the resulting interfacing also adds an inner component to the + UI item in question and extends the input and output to contain the input and output of the + inner component. + -} + with :: (UIComp uiComp) + => (nativeItem -> Placement innerItem uiBackend) + -- ^conversion from a native item into the placement for its inner items + -> uiComp innerItem uiBackend era innerI innerO + -- ^an inner user interface component + -> Interfacing nativeItem era baseI baseO + -- ^an interfacing to which the inner component interfacing shall be added + -> Interfacing nativeItem era (baseI `With` innerI) (baseO `With` innerO) + with placement innerComp (Interfacing baseInterfacingImpl) = interfacing' where + + interfacing' = Interfacing $ + arr fromWith >>> + baseInterfacingImpl *** innerInterfacingImpl >>> + arr toWith + + Interfacing innerInterfacingImpl = inner placement innerComp + + + fromWith (base `With` inner) = (base,inner) + + toWith (base,inner) = base `With` inner + + -- * Inner components + -- |An input or output, extended with the input or output of an inner component. + data base `With` inner = base `With` inner diff --git a/src/Internal/UICircuit.hs b/src/Internal/UICircuit.hs new file mode 100644 --- /dev/null +++ b/src/Internal/UICircuit.hs @@ -0,0 +1,112 @@ +module Internal.UICircuit ( + + UICircuit (UICircuit), + fromCircuit, + run + +) where + + -- Prelude + 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 + + -- FRP.Grapefruit + import FRP.Grapefruit.Circuit as Circuit + import FRP.Grapefruit.Signal as Signal + import FRP.Grapefruit.Signal.Discrete as DSignal + + -- Internal + import {-# SOURCE #-} Internal.UIItem as UIItem + + -- Graphics.UI.Grapefruit + import Graphics.UI.Grapefruit.Backend as UIBackend + import Graphics.UI.Grapefruit.Comp as UIComp + + {-| + The type of user interface circuits. + + The @item@ parameter is a phantom parameter which says which kind of items the circuit + contains. It should be an instance of 'Item'. + -} + newtype UICircuit item uiBackend era i o = UICircuit (ReaderArrow (Placement item uiBackend) + (Circuit era) + i + 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) + + UICircuit arrow1 *** UICircuit arrow2 = UICircuit (arrow1 *** arrow2) + + UICircuit arrow1 &&& UICircuit arrow2 = UICircuit (arrow1 &&& arrow2) + + instance ArrowLoop (UICircuit item uiBackend era) where + + loop (UICircuit arrow) = UICircuit (Arrow.loop arrow) + + -- “really manual” instance (not just because of manual deriving) + instance UIComp UICircuit where + + circuit |>> uiCircuit = fromCircuit circuit >>> uiCircuit + + uiCircuit >>| circuit = uiCircuit >>> fromCircuit circuit + + loop = Arrow.loop + + toUICircuit = id + + fromUIItem (UIItem uiCircuit) = uiCircuit + + -- |Converts an ordinary circuit into a user interface circuit that contains no items. + fromCircuit :: Circuit era i o -> UICircuit item uiBackend era i o + fromCircuit = liftReader >>> UICircuit + + {-| + Runs a user interface circuit. + + @run@ quits when the output signal of the circuit has a first occurence. The universal + 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 = do + UIBackend.initialize uiBackend + (_,finalizeCircuit) <- Circuit.create circuit () + UIBackend.handleEvents uiBackend + finalizeCircuit + UIBackend.finalize uiBackend + -- Where are the top level windows removed? + + circuit = proc _ -> do + quittingReq <- runReader $ + case uiCircuit of UICircuit arrow -> arrow + -< ((),topLevel uiBackend) + consume $ DSignal.consumer (const (requestQuitting uiBackend)) -< quittingReq diff --git a/src/Internal/UICircuit.hs-boot b/src/Internal/UICircuit.hs-boot new file mode 100644 --- /dev/null +++ b/src/Internal/UICircuit.hs-boot @@ -0,0 +1,7 @@ +module Internal.UICircuit ( + + UICircuit + +) where + + data UICircuit item uiBackend era i o diff --git a/src/Internal/UIItem.hs b/src/Internal/UIItem.hs new file mode 100644 --- /dev/null +++ b/src/Internal/UIItem.hs @@ -0,0 +1,349 @@ +module Internal.UIItem ( + + -- * User interface items in general + UIItem (UIItem), + item, + + -- * Bricks + Brick, + brick, + just, + + -- * Boxes + Box, + box, + with, + With (With), + + -- * Kinds of items + Item (type CommonInputOptRecord, type CommonOutputRecord), + Placement, + Widget, + Window, + + -- * Field names + IsEnabled (IsEnabled) + +) where + + -- Controls + import Control.Arrow as Arrow + import Control.Arrow.Operations as ArrowOperations + import Control.Arrow.Transformer.Reader as ReaderArrow + + -- 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 + + -- Graphics.UI.Grapefruit + import Graphics.UI.Grapefruit.Backend as UIBackend + + -- Internal + import Internal.UICircuit as UICircuit + import Internal.Interfacing as Interfacing hiding (with) + import qualified Internal.Interfacing as Interfacing + + -- Graphics.UI.Grapefruit + import Graphics.UI.Grapefruit.Comp as UIComp + + -- * User interface items in general + {-| + The type of user interface items. + + The @item@ parameter is a phantom parameter which denotes the kind of the item. It should + be an instance of 'Item'. + -} + newtype UIItem item uiBackend era i o = UIItem (UICircuit item uiBackend era i o) + + -- manual deriving because of GHC bug #1133 + instance UIComp UIItem where + + circuit |>> UIItem uiCircuit = UIItem (circuit |>> uiCircuit) + + UIItem uiCircuit >>| circuit = UIItem (uiCircuit >>| circuit) + + loop (UIItem uiCircuit) = UIItem (Arrow.loop uiCircuit) + + toUICircuit (UIItem uiCircuit) = uiCircuit + + fromUIItem = id + + {-| + Constructs an item using functionality of an underlying imperative library. + + The @nativeItem@ type variable represents an item type of the underlying library. + -} + item :: (nativeItem -> IO ()) + -- ^an action which makes a native item visible + -> (Placement item uiBackend -> IO nativeItem) + -- ^an action which creates a native item depending on a placement for the item + -> Interfacing nativeItem era i o + -- ^the interface specification for the item + -> UIItem item uiBackend era i o + item showItem + newItem + (Interfacing interfacingImpl) = UIItem $ + UICircuit $ arr id &&& readState >>> liftReader arrow where + + arrow = proc (i,placement) -> do + nativeItem <- act -< newItem placement + o <- runReader interfacingImpl -< (i,nativeItem) + _ <- act -< showItem nativeItem + returnA -< o + + -- * Bricks + {-| + A brick is an era-independent item with a comfortable record-based interface. + + The parameter @iOptRecord@ is an optionality record and therefore specifies a set of + required and a set of optional fields. When the brick is used, the input fields can be given + in any order and optional fields can be left out. Similarily, @oRecord@ specifies a set of + fields (without optionalities) of whom not all have to be utilized by the user of the brick. + + A brick has additional input and output fields which are not explicitely mentioned in its + type. For an item kind @/item/@, they are given by @'CommonInputOptRecord' /item/@ and + @'CommonOutputRecord' /item/@. Therefore, it is possible to have inputs and outputs common + for all bricks of a certain item kind. + -} + newtype Brick item uiBackend iOptRecord oRecord + = Brick (forall era extIRecord extORecord. + (Subrecord extIRecord + (All iOptRecord `Cat` All (CommonInputOptRecord item)), + Subrecord (Required iOptRecord `Cat` Required (CommonInputOptRecord item)) + extIRecord, + Subrecord extORecord + (oRecord `Cat` CommonOutputRecord item)) => + UIItem item uiBackend era (SignalRecord era extIRecord) + (SignalRecord era extORecord)) + + -- |Constructs a brick. + brick :: (Item item, OptRecord iOptRecord, Record oRecord) + => ContextConsumerRecord nativeItem (All (CommonInputOptRecord item)) + {-^ + consumers of those inputs which are common to all bricks of the respective item + kind + -} + -> ContextProducerRecord nativeItem (CommonOutputRecord item) + {-^ + producers of those outputs which are common to all bricks of the respective item + kind + -} + -> (nativeItem -> IO ()) + -- ^an action which makes a native item visible + -> (Placement item uiBackend -> IO nativeItem) + -- ^an action which creates a native item depending on a placement for the item + -> ContextConsumerRecord nativeItem (All iOptRecord) + -- ^consumers of those inputs which are specific to this brick + -> ContextProducerRecord nativeItem oRecord + -- ^producers of those outputs which are specific to this brick + -> Brick item uiBackend iOptRecord oRecord + brick commonConsumerRecord commonProducerRecord showItem newItem consumerRecord producerRecord + = Brick $ item showItem + newItem + (Interfacing.basic (cat consumerRecord commonConsumerRecord) + (cat producerRecord commonProducerRecord)) + + {-| + Converts a brick into an ordinary user interface component. + + The brick is first converted into a UI item which is then converted into the resulting + component by applying 'fromUIItem'. + + The type of @just@ states the following properties of the resulting component: + + * The input record covers only fields which are input fields according to the type of + the brick or are common input fields of all items of the respective kind. + + * The input record covers all input fields which are marked as required. + + * The output record covers only fields which are output fields according to the type of + the brick or are common output fields of all items of the respective kind. + + * The order of fields is arbitrary. + + * The component is not tied to a specific era. + + * All input and output signals use the same era as the component. + + Dropping certain input or output fields results in the corresponding connectors not being + executed. + + To make the type variables @extIRecord@ and @extORecord@ non-ambiguous, the lists of input + 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 + (All iOptRecord `Cat` All (CommonInputOptRecord item)), + Subrecord (Required iOptRecord `Cat` Required (CommonInputOptRecord item)) + extIRecord, + Subrecord extORecord + (oRecord `Cat` CommonOutputRecord item), + UIComp uiComp) + => Brick item uiBackend iOptRecord oRecord + -> uiComp item uiBackend era (SignalRecord era extIRecord) (SignalRecord era extORecord) + just (Brick item) = fromUIItem item + + -- * Boxes + {-| + A box is a container which can be transformed into an item by putting a user interface + component into it. + + The component which is put into a box is called the inner component of that box. The + parameters @innerItem@ and @item@ tell the type of the inner component and the item kind, it + is based on. + + The interface of an item made from a box is similar to that of an item made from a brick. + The only difference is that the interface of the box item covers also the input and the + output of the inner component. + -} + newtype Box innerUIComp innerItem item uiBackend iOptRecord oRecord + = Box (forall era extIRecord extORecord innerI innerO. + (Subrecord extIRecord + (All iOptRecord `Cat` All (CommonInputOptRecord item)), + Subrecord (Required iOptRecord `Cat` Required (CommonInputOptRecord item)) + extIRecord, + Subrecord extORecord + (oRecord `Cat` CommonOutputRecord item)) => + innerUIComp innerItem uiBackend era innerI innerO -> + UIItem item uiBackend era (SignalRecord era extIRecord `With` innerI) + (SignalRecord era extORecord `With` innerO)) + + -- |Constructs a box. + box :: (UIComp innerUIComp, Item item, OptRecord iOptRecord, Record oRecord) + => ContextConsumerRecord nativeItem (All (CommonInputOptRecord item)) + {-^ + consumers of those inputs which are common to all bricks of the respective item + kind + -} + -> ContextProducerRecord nativeItem (CommonOutputRecord item) + {-^ + producers of those outputs which are common to all bricks of the respective item + kind + -} + -> (nativeItem -> IO ()) + -- ^an action which makes a native item visible + -> (Placement item uiBackend -> IO nativeItem) + -- ^an action which creates a native item depending on a placement for the item + -> (nativeItem -> Placement innerItem uiBackend) + -- ^conversion from a native item into the placement for its inner items + -> ContextConsumerRecord nativeItem (All iOptRecord) + -- ^consumers of those inputs which are specific to this box + -> ContextProducerRecord nativeItem oRecord + -- ^producers of those outputs which are specific to this box + -> Box innerUIComp innerItem item uiBackend iOptRecord oRecord + box commonConsumerRecord commonProducerRecord + showItem + newItem + placement + consumerRecord producerRecord + = Box $ \innerComp -> item showItem + newItem + (Interfacing.with placement innerComp $ + Interfacing.basic (cat consumerRecord commonConsumerRecord) + (cat producerRecord commonProducerRecord)) + + {-| + Puts an inner component into a box and converts the result into an ordinary user interface + component. + + This function is very similar to 'just'. In contrast to 'just', it takes the inner component + as an additional argument and extends the input and output of the resulting component with + the input and output of the inner component. Note that the era of the inner component equals + the era of the resulting component. + + Applications of @with@ are usually written infix. + -} + with :: (Subrecord extIRecord + (All iOptRecord `Cat` All (CommonInputOptRecord item)), + Subrecord (Required iOptRecord `Cat` Required (CommonInputOptRecord item)) + extIRecord, + Subrecord extORecord + (oRecord `Cat` CommonOutputRecord item), + UIComp uiComp) + => Box innerUIComp innerItem item uiBackend iOptRecord oRecord + -> innerUIComp innerItem uiBackend era innerI innerO + -> uiComp item uiBackend era (SignalRecord era extIRecord `With` innerI) + (SignalRecord era extORecord `With` innerO) + with (Box item) = fromUIItem . item + + -- * Kinds of items + {-| + The class of all kinds of items. + + Instances of this class serve as phantom parameters of 'UIItem', 'UICircuit' and others. + -} + class (OptRecord (CommonInputOptRecord item), Record (CommonOutputRecord item)) => + Item item where + + -- |Inputs which are shared by all items of the respective kind. + type CommonInputOptRecord item :: * -> * + + -- |Outputs which are shared by all items of the respective kind. + type CommonOutputRecord item :: * -> * + + {-| + The family of item placement types. + + A placement says where to place a user interface item, for example, to place a widget in a + certain box or a window at the top level. @Graphics.UI.Grapefruit.Item@ declares two + instances of @Placement@. @Placement 'Widget' /uiBackend/@ is equivalent to + @'WidgetPlacement' /uiBackend/@ and @Placement 'Window' /uiBackend/@ is equivalent to + @'WindowPlacement' /uiBackend/@. + -} + type family Placement item uiBackend :: * + + {-| + The widget item kind. + + A widget is an item which resides inside a window. Examples of widgets are push buttons, + labels and boxes (which contain other widgets themselves). + -} + data Widget + + instance Item Widget where + + type CommonInputOptRecord Widget = X :& Opt IsEnabled ::: SSignal `Of` Bool + + type CommonOutputRecord Widget = X + + type instance Placement Widget uiBackend = WidgetPlacement uiBackend + + {-| + The window item kind. + + A window is an item which resides directly on the desktop and typically has a frame with a + title and some control buttons. Examples of windows are application windows and dialogs. + -} + data Window + + instance Item Window where + + type CommonOutputRecord Window = X + + type CommonInputOptRecord Window = X + + type instance Placement Window uiBackend = WindowPlacement uiBackend + + -- * Field names + {-| + A field name. + + Typical properties: + + [kind] + input (optional) + + [type] + @'SSignal' `'Of'` Bool@ + + [meaning] + whether a widget is enabled or not + + Disabled widgets cannot receive user events and are typically displayed in a different + style + -} + data IsEnabled = IsEnabled diff --git a/src/Internal/UIItem.hs-boot b/src/Internal/UIItem.hs-boot new file mode 100644 --- /dev/null +++ b/src/Internal/UIItem.hs-boot @@ -0,0 +1,18 @@ +module Internal.UIItem ( + + UIItem (UIItem), + Placement, + Widget, + Window + +) where + + import {-# SOURCE #-} Internal.UICircuit as UICircuit + + newtype UIItem item uiBackend era i o = UIItem (UICircuit item uiBackend era i o) + + type family Placement item uiBackend :: * + + data Widget + + data Window