packages feed

grapefruit-frp (empty) → 0.0.0.0

raw patch · 19 files changed

+1875/−0 lines, 19 filesdep +TypeComposedep +arrowsdep +basesetup-changed

Dependencies added: TypeCompose, arrows, base, containers

Files

+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runghc++> import Distribution.Simple+> main = defaultMain
+ grapefruit-frp.cabal view
@@ -0,0 +1,57 @@+Name:          grapefruit-frp+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-frp/0.0.0.0/grapefruit-frp-0.0.0.0.tar.gz+Synopsis:      Functional Reactive Programming core+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+               <http://haskell.org/haskellwiki/Functional_Reactive_Programming>.+               .+               This package contains general support for Functional Reactive Programming.+Category:      FRP, Reactivity+Tested-With:   GHC == 6.8.3+               GHC == 6.10.1++Library+    Build-Depends:   arrows      >= 0.2 && < 0.5,+                     base        >= 3.0 && < 4.1,+                     containers  >= 0.1 && < 0.3,+                     TypeCompose >= 0.3 && < 0.7+    Extensions:      Arrows+                     CPP+                     EmptyDataDecls+                     GADTs+                     GeneralizedNewtypeDeriving+                     -- ImpredicativeTypes+                     KindSignatures+                     Rank2Types+                     ScopedTypeVariables+                     TypeOperators+    GHC-Options:     -fglasgow-exts -O0+                     -- Switching off optimizations is needed because otherwise GHC 6.10.1 loops.+                     -- Replacing (fmap polyUnOSF funSignal) and (fmap polyUnSSF funSignal) in the+                     -- Signal.switch implementation by (undefined) makes GHC work even with -O.+    Exposed-Modules: FRP.Grapefruit.Circuit+                     FRP.Grapefruit.Setup+                     FRP.Grapefruit.Signal+                     FRP.Grapefruit.Signal.Continuous+                     FRP.Grapefruit.Signal.Discrete+                     FRP.Grapefruit.Signal.Segmented+    Other-Modules:   Internal.Capsule+                     Internal.Circuit+                     Internal.CSeg+                     Internal.Signal+                     Internal.Signal.Discrete+                     Internal.Signal.Segmented+                     Internal.ListenerSet+                     Internal.Vista+    HS-Source-Dirs:  src
+ src/FRP/Grapefruit/Circuit.hs view
@@ -0,0 +1,91 @@+-- |This module provides circuits which are descriptions of reactive systems.+module FRP.Grapefruit.Circuit (++    Circuit,+    act,+    putSetup,+    create++) where++    -- Prelude+    import           Prelude (($), (>>), IO, flip, return)+    import qualified Prelude++    -- Control+    import Control.Arrow                    as Arrow+    import Control.Arrow.Operations         as ArrowOperations+    import Control.Arrow.Transformer        as ArrowTransformer+    import Control.Arrow.Transformer.Reader as ReaderArrow+    import Control.Arrow.Transformer.Writer as WriterArrow+    import Control.Concurrent.MVar          as MVar++    -- Data+    import Data.Unique as Unique++    -- FRP.Grapefruit+    import FRP.Grapefruit.Setup as Setup++    -- Internal+    import Internal.Circuit as Circuit++    {-|+        This circuit takes an I/O action when it is constructed, performs this action immediately+        and outputs its result.+    -}+    act :: Circuit era (IO output) output+    act = Circuit $ (lift >>> lift >>> lift) (Kleisli Prelude.id)++    {-|+        A circuit which triggers initialization and finalization according to a given setup.+    -}+    putSetup :: Circuit era Setup ()+    putSetup = Circuit $ (lift >>> lift) write++    {-|+        Creates a circuit.++        The second argument of @create@ is fed into the circuit as its input and the circuit is+        constructed then. After that, the initialization actions of all setups inserted by+        'putSetup' are run. The finalization actions of the setups are chained and returned by+        @create@ together with the output of the circuit.++        Note that initialization is done completely after circuit creation. This allows outputs of+        circuits to be generated before they are used for forming circuit inputs. This is important+        to avoid circular dependencies when 'loop' is used.+    -}+    create :: (forall era. Circuit era i o) -> i -> IO (o,IO ())+    create circuit input = do+                               startTimeID <- newUnique+                               ecFinalizerVar <- newMVar (return ())+                               (output,setup) <- runCircuitArrow (polyCircuitArrow circuit)+                                                                 startTimeID+                                                                 ecFinalizerVar+                                                                 input+                               finalize <- Setup.run setup+                               return (output,finalize)+    {-+        When creating subcircuits because of dynamicity create neither a new EC finalizer variable,+        nor a new time ID (take the one from the event triggering the subcircuit creation instead).+    -}++    polyCircuitArrow :: (forall era. Circuit era input output) -> CircuitArrow input output+    polyCircuitArrow plainCircuit = circuitArrow plainCircuit++    circuitArrow :: Circuit era input output -> CircuitArrow input output+    circuitArrow (Circuit circuitArrow) = circuitArrow++    runCircuitArrow :: CircuitArrow input output+                    -> Unique+                    -> MVar (IO ())+                    -> input+                    -> IO (output,Setup)+    runCircuitArrow circuitArrow startTimeID ecFinalizerVar input = run where++        run                 = runKleisli ioArrow input++        ioArrow             = runWriter setupWriterArrow++        setupWriterArrow    = arr (flip (,) ecFinalizerVar) >>> runReader ecFinVarReaderArrow++        ecFinVarReaderArrow = arr (flip (,) startTimeID) >>> runReader circuitArrow
+ src/FRP/Grapefruit/Setup.hs view
@@ -0,0 +1,34 @@+-- |A setup describes how to initialize and finalize a reactive system.+module FRP.Grapefruit.Setup (++    Setup,+    setup,+    run++) where++    -- Control+    import Control.Arrow   as Arrow+    import Control.Compose as Compose++    -- Data+    import Data.Monoid as Monoid++    {-|+        A setup describes the initialization and finalization of a reactive system. It is equivalent+        to an action of type @IO (IO ())@ which initializes the system and returns a finalization+        action.++        The 'mempty' method of the 'Monoid' instance denotes a setup which does no initialization+        and no finalization.  The 'mappend' method sequences initialization and finalization+        actions.+    -}+    newtype Setup = Setup ((IO :. IO) :$ ()) deriving (Monoid)++    -- |Converts an I/O action into a setup.+    setup :: IO (IO ()) -> Setup+    setup = Setup . App . O++    -- |Converts a setup into an I/O action.+    run :: Setup -> IO (IO ())+    run (Setup io) = unO (unApp io)
+ src/FRP/Grapefruit/Signal.hs view
@@ -0,0 +1,55 @@+{-|+    Signals are the key concept of Functional Reactive Programming. They describe behavior over+    time. This module provides general support for signals. Individual kinds of signals are provided+    by the submodules "FRP.Grapefruit.Signal.Disrete", "FRP.Grapefruit.Signal.Segmented" and+    "FRP.Grapefruit.Signal.Continuous".++    A signal type has kind @* -> * -> *@. Its first parameter denotes the time interval in which the+    signal is alive. This is called the /era/ of the signal. An era is left-closed (contains a+    starting time) but right-open or right-unbounded (does not contain an ending time).++    The era type parameter is not intended to be instantiated with concrete types. Instead, it is+    used to force equality of eras or independence of eras at compile time. Its use is very similar+    to that of the first type parameter of 'ST' and the first parameter of 'STRef'.+-}+module FRP.Grapefruit.Signal (++    -- * Signals+    Signal,++    -- * Switching+    switch,++    -- * Signal functions+    SignalFun (OSF, SSF),+    unOSF,+    unSSF,+    sfApp,+    (:->),++    -- * Signal shapes+    Of,++    -- * Sampling+    Sampler,+    Samplee,+    (<#>),+    (#>),+    (<#),++    -- * Connectors+    Consumer (Consumer),+    consume,+    Producer (Producer),+    produce++) where++    -- Control+    import Control.Monad.ST as ST          -- for documentation only++    -- Data+    import Data.STRef as STRef -- for documentation only++    -- Internal+    import Internal.Signal as Signal
+ src/FRP/Grapefruit/Signal/Continuous.hs view
@@ -0,0 +1,154 @@+{-|+    This module is about continuous signals.++    For a general introduction to signals, see the documentation of "FRP.Grapefruit.Signal".+-}+module FRP.Grapefruit.Signal.Continuous (++    -- * Continuous signal type+    CSignal,++    -- * Conversion+    fromSSignal,++    -- * Connectors+    producer++) where++    -- Control+    import Control.Applicative as Applicative+#if __GLASGOW_HASKELL__ >= 610+    import Control.Arrow       as Arrow+#else+    import Control.Arrow       as Arrow   hiding (pure)+#endif+    import Control.Compose     as Compose++    -- Data+    import Data.Unique as Unique++    -- Internal+    import           Internal.Capsule                   as Capsule+    import           Internal.CSeg                      as CSeg    hiding (producer)+    import qualified Internal.CSeg                      as CSeg+    import           Internal.Signal                    as Signal+    import           Internal.Signal.Discrete (DSignal)+    import qualified Internal.Signal.Discrete           as DSignal+    import           Internal.Signal.Segmented          as SSignal++    -- Internal+    import Internal.Circuit as Circuit++    -- * Continuous signal type+    {-|+        The type of continuous signals.++        A continuous signal denotes a mapping from times to values. You can think of @CSignal /era/+        /val/@ as being equivalent to @Time /era/ -> /val/@ where @Time /era/@ is the type of all+        times of the given era.++        Continuous signals are used to describe continuously changing values. They are also used for+        values changing at discrete times if there is no possibility of being notified about such+        changes. If there is a notification mechanism then segemented signals, provided by+        "FRP.Grapefruit.Signal.Segmented", should be used.+    -}+    data CSignal era val = CSignal (Capsule val) !(SSignal era (CSeg val))+    {-+        The strictness annotation ensures that reducing the CSignal reduces the SSignal, thereby+        triggering reading of continous sources the SSignal depends on.+    -}++    instance Functor (CSignal era) where++        fmap fun (CSignal initCap segs) = CSignal (fmap fun initCap) ((fmap . fmap) fun segs)++    instance Applicative (CSignal era) where++        pure val = CSignal (pure val) ((pure . pure) val)++        CSignal funInitCap funSegs <*> CSignal argInitCap argSegs = CSignal initCap' segs' where++            initCap' = funInitCap <*> argInitCap++            segs'    = liftA2 (<*>) funSegs argSegs++    instance Signal CSignal where++        osfSwitch signal@(SSignal init _) = CSignal (initCap init) segs' where++            segs' = osfSwitch (segsSignal signal)++        ssfSwitch (SSignal init upd) (CSignal initCap segs) = ssfSwitch sampler segs where++            sampler = polySSignal (fixInitCapForInit init initCap)+                                  (polyTimeIDApp (fixInitCapForUpd <$> upd) <#> segs)++    initCap :: CSignal era val -> Capsule val+    initCap (CSignal initCap _) = initCap++    segsSignal :: SSignal era (forall era'. CSignal era' val)+               -> SSignal era (forall era'. SSignal era' (CSeg val))+    segsSignal = fmap polySegs++    polySegs :: (forall era'. CSignal era' val) -> (forall era'. SSignal era' (CSeg val))+    polySegs signal = segs signal++    segs :: CSignal era' val -> SSignal era' (CSeg val)+    segs (CSignal _ segs) = segs++    polySSignal :: (forall era'. SSignal era' (CSeg val) -> SignalFun era' shape)+                -> DSignal era (forall era'. SSignal era' (CSeg val) -> SignalFun era' shape)+                -> SSignal era (forall era'. SSignal era' (CSeg val) -> SignalFun era' shape)+    polySSignal init upd = SSignal init upd++    fixInitCapForInit :: (forall era'. CSignal era' val -> signalFun era' shape)+                      -> Capsule val+                      -> (forall era'. SSignal era' (CSeg val) -> signalFun era' shape)+    fixInitCapForInit fun initCap segs = fun (CSignal initCap segs)++    fixInitCapForUpd :: (forall era'. CSignal era' val -> signalFun era' shape)+                     -> Unique+                     -> CSeg val+                     -> (forall era'. SSignal era' (CSeg val) -> signalFun era' shape)+    fixInitCapForUpd fun timeID initSeg segs = fun (CSignal (currentValCapsule timeID initSeg) segs)++    polyTimeIDApp :: DSignal era (Unique ->+                                  CSeg val ->+                                  forall era'. SSignal era' (CSeg val) -> SignalFun era' shape)+                  -> DSignal era (CSeg val ->+                                  forall era'. SSignal era' (CSeg val) -> SignalFun era' shape)+    polyTimeIDApp signal = DSignal.timeIDApp signal++    instance Samplee CSignal where++        dSample sampler (CSignal _ segs) = (DSignal.crackCapsules . DSignal.timeIDApp) $+                                           timeIDToCapsule <$> sampler <#> segs where++            timeIDToCapsule fun seg = fmap fun . flip currentValCapsule seg++        sSample (SSignal samplerInit samplerUpd) signal@(CSignal (Capsule init) _) = signal' where++            signal' = SSignal (samplerInit init) (samplerUpd <#> signal)++    -- * Conversion+    {-|+        Converts a segmented signal into a continous signal, dropping the information about update+        points.+    -}+    fromSSignal :: SSignal era val -> CSignal era val+    fromSSignal signal@(SSignal init _) = CSignal (pure init) (fmap pure signal)++    -- * Connectors+    {-|+        Converts a value read action into a continuous signal producer.++        The producer @producer /readVal/@ produces a continuous signal whose current value is+        determined by executing @/readVal/@.+    -}+    producer :: IO val -> Producer CSignal val+    producer readVal = Producer $+                       proc _ -> do+                           seg <- CSeg.producer readVal -< ()+                           startTimeID <- getStartTimeID -< ()+                           returnA -< CSignal (currentValCapsule startTimeID seg) (pure seg)
+ src/FRP/Grapefruit/Signal/Discrete.hs view
@@ -0,0 +1,52 @@+{-|+    This module is about discrete signals.++    For a general introduction to signals, see the documentation of "FRP.Grapefruit.Signal".+-}+module FRP.Grapefruit.Signal.Discrete (++    -- * Discrete signal type+    DSignal,++    -- * Empty signal+    empty,++    -- * Combination+    -- ** Union+    union,+    unionWith,+    transUnion,++    unions,+    unionsWith,++    -- ** Difference+    difference,+    differenceWith,++    -- ** Intersection+    intersection,+    intersectionWith,++    -- * Mapping and filtering+    map,+    filter,+    catMaybes,+    mapMaybe,++    -- * Stateful signals+    scan,+    scan1,+    stateful,++    -- * Connectors+    consumer,+    producer++) where++    -- Prelude+    import Prelude ()++    -- Internal+    import Internal.Signal.Discrete as DSignal
+ src/FRP/Grapefruit/Signal/Segmented.hs view
@@ -0,0 +1,27 @@+{-|+    This module is about segmented signals.++    For a general introduction to signals, see the documentation of "FRP.Grapefruit.Signal".+-}+module FRP.Grapefruit.Signal.Segmented (++    -- * Segmented signal type+    SSignal,++    -- * Introduction+    fromInitAndUpdate,++    -- * Accessors+    withInit,+    update,++    -- * Stateful signals+    scan,++    -- * Connectors+    consumer++) where++    -- Internal+    import Internal.Signal.Segmented as Segmented
+ src/Internal/CSeg.hs view
@@ -0,0 +1,65 @@+{-# OPTIONS_GHC -fno-cse #-}+module Internal.CSeg (++    CSeg,+    currentValCapsule,+    producer++) where++    -- Control+    import Control.Applicative     as Applicative+    import Control.Arrow           as Arrow+    import Control.Compose         as Compose+    import Control.Concurrent.MVar as MVar++    -- Data+    import Data.Unique as Unique++    -- System+    import System.IO.Unsafe as UnsafeIO++    -- Internal+    import Internal.Capsule as Capsule+    import Internal.Circuit as Circuit++    -- FRP.Grapefruit+    import FRP.Grapefruit.Circuit as Circuit++    newtype CSeg val = CSeg (((->) Unique :. Capsule) val) deriving (Functor, Applicative)++    currentValCapsule :: Unique -> CSeg val -> Capsule val+    currentValCapsule currentTimeID (CSeg capsuleGen) = unO capsuleGen currentTimeID++    producer :: IO val -> Circuit era () (CSeg val)+    producer readVal = proc _ -> do+                           maybeValVar <- act -< newMVar Nothing+                           addECFinalizer <- getECFinalizerAdd -< ()+                           returnA -< CSeg $+                                      O (unsafeCurrentValCapsule readVal maybeValVar addECFinalizer)++    {-# NOINLINE unsafeCurrentValCapsule #-}+    unsafeCurrentValCapsule :: IO val+                            -> MVar (Maybe val)+                            -> (IO () -> IO ())+                            -> Unique+                            -> Capsule val+    unsafeCurrentValCapsule readVal maybeValVar addECFinalizer timeID = unsafePerformIO $+                                                                        seq timeID $+                                                                        getCurrentValCapsule where++        getCurrentValCapsule = do+                                   maybeVal <- readMVar maybeValVar+                                   case maybeVal of+                                       Nothing            -> do+                                                                 val <- readVal+                                                                 putMVar maybeValVar (Just val)+                                                                 addECFinalizer resetMaybeValVar+                                                                 return (Applicative.pure val)+                                       justVal@(Just val) -> do+                                                                 putMVar maybeValVar justVal+                                                                 return (Applicative.pure val)++        resetMaybeValVar     = do+                                   readMVar maybeValVar+                                   putMVar maybeValVar Nothing
+ src/Internal/Capsule.hs view
@@ -0,0 +1,21 @@+module Internal.Capsule (++    Capsule (Capsule)++) where++    -- Control+    import Control.Applicative as Applicative++    -- Don’t use newtype since this would defeat the purpose of Capsule.+    data Capsule val = Capsule val++    instance Functor Capsule where++        fmap fun (Capsule val) = Capsule (fun val)++    instance Applicative Capsule where++        pure = Capsule++        Capsule fun <*> Capsule arg = Capsule (fun arg)
+ src/Internal/Circuit.hs view
@@ -0,0 +1,84 @@+module Internal.Circuit (++    Circuit (Circuit),+    CircuitArrow,+    getECFinalizerAdd,+    getECFinalization,+    getStartTimeID++) where++    -- Control+#if __GLASGOW_HASKELL__ >= 610+    import Control.Category                 as Category+#endif+    import Control.Arrow                    as Arrow+    import Control.Arrow.Operations         as ArrowOperations+    import Control.Arrow.Transformer        as ArrowTransformer+    import Control.Arrow.Transformer.Reader as ReaderArrow+    import Control.Arrow.Transformer.Writer as WriterArrow+    import Control.Concurrent.MVar          as MVar++    -- Data+    import Data.Unique as Unique++    -- FRP.Grapefruit+    import FRP.Grapefruit.Setup as Setup++    {-|+        A circuit describes a reactive system.++        The @era@ parameter denotes the time interval during which the circuit is in existence. It+        is completely analogous to the era parameters of signal types which are described in the+        documentation of "FRP.Grapefruit.Signal".++        Input and output of a circuit are typically signals, tuples of signals (with @()@ as the+        corner case) or records of signals as provided by the package grapefruit-records. The era+        parameters of these signals usually match the @era@ parameter of the circuit.++        A circuit consumes only one input value and produces only one output value. This happens+        when the circuit is constructed. So the temporal behavior does not come from turning+        multiple inputs into multiple outputs but from using signals as inputs and outputs.++        A circuit has the ability to interact with the outside world (that is, perform I/O).++        The 'ArrowApply' instance of @Circuit era@ is currently needed for implementing other parts+        of Grapefruit. However, it should not be taken for granted that it will remain in future+        versions. So it is better to not use it outside Grapefruit.+    -}+    newtype Circuit era i o = Circuit (CircuitArrow i o)+                            deriving (+#if __GLASGOW_HASKELL__ >= 610+                                         Category,+#endif+                                         Arrow,+                                         ArrowLoop,+                                         ArrowApply+                                     )++    type CircuitArrow = ReaderArrow Unique ECFinVarReaderArrow++    type ECFinVarReaderArrow = ReaderArrow (MVar (IO ())) SetupWriterArrow++    type SetupWriterArrow = WriterArrow Setup IOArrow++    type IOArrow = Kleisli IO++    -- “EC” stands for “event cycle”+    getECFinalizerAdd :: Circuit era () (IO () -> IO ())+    getECFinalizerAdd = Circuit $+                        lift $+                        readState >>> arr addFinalizer where++        addFinalizer finalizerVar finalizer = modifyMVar_ finalizerVar ((>> finalizer) >>> return)++    getECFinalization :: Circuit era () (IO ())+    getECFinalization = Circuit $+                        lift $+                        readState >>> arr (\finalizerVar -> do+                                                                finalizer <- takeMVar finalizerVar+                                                                putMVar finalizerVar (return ())+                                                                finalizer)++    getStartTimeID :: Circuit era () Unique+    getStartTimeID = Circuit $ readState
+ src/Internal/ListenerSet.hs view
@@ -0,0 +1,35 @@+module Internal.ListenerSet (++    ListenerSet,+    empty,+    add,+    notify++) where++    -- Data+    import           Data.Map (Map)+    import qualified Data.Map       as Map+    import           Data.IORef     as IORef++    newtype ListenerSet = ListenerSet (Map Int (IO ()))++    empty :: ListenerSet+    empty = ListenerSet Map.empty++    add :: IORef ListenerSet -> IO () -> IO (IO ())+    add setRef listener = do+                              ListenerSet currentMap <- readIORef setRef+                              let++                                  newKey | Map.null currentMap = minBound+                                         | otherwise           = succ (fst (Map.findMax currentMap))++                              writeIORef setRef+                                         (ListenerSet $ Map.insert newKey listener currentMap)+                              return $ modifyIORef setRef+                                                   (\(ListenerSet map) -> ListenerSet $+                                                                          Map.delete newKey map)++    notify :: ListenerSet -> IO ()+    notify (ListenerSet map) = sequence_ (Map.elems map)
+ src/Internal/Signal.hs view
@@ -0,0 +1,274 @@+module Internal.Signal (++    -- * Signals+    Signal (osfSwitch, ssfSwitch),++    -- * Switching+    switch,++    -- * Signal functions+    SignalFun (OSF, SSF),+    unOSF,+    unSSF,+    sfApp,+    (:->),++    -- * Signal shapes+    Of,++    -- * Sampling+    Sampler (sample, samplerMap),+    Samplee (dSample, sSample),+    (<#>),+    (#>),+    (<#),++    -- * Connectors+    Consumer (Consumer),+    consume,+    Producer (Producer),+    produce++) where++    -- Control+    import Control.Applicative as Applicative -- for documentation only+    import Control.Monad.ST    as ST          -- for documentation only+++    -- Internal+    import {-# SOURCE #-} Internal.Signal.Discrete  as DSignal+    import {-# SOURCE #-} Internal.Signal.Segmented as SSignal++    -- FRP.Grapefruit+    import FRP.Grapefruit.Circuit as Circuit++    -- Fixities+    infixl 4 <#>+    infixl 4 #>+    infixl 4 <#++    {-FIXME:+        This module as well as others have quite a lot of code for working around problems with+        impredicativity and higher-rank polymorphism. I hope that these problems go away with FPH,+        so at some day the code should be simplified accordingly.+    -}++    -- * Signals+    -- |The class of all signal types.+    class Signal signal where++        osfSwitch :: SSignal era (forall era'. signal era' val) ->+                     signal era val++        ssfSwitch :: SSignal era (forall era'. signal era' val -> SignalFun era' shape) ->+                     (signal era val -> SignalFun era shape)++    -- * Switching+    {-|+        This function generates a signal whose behavior switches between that of different other+        signals over time.++        Since the result type @'SignalFun' era shape@ is isomorphic to an n-ary function type, we+        can see @switch@ as a function which takes a first argument, called the function signal,+        and /n/ further arguments, called the argument signals, and yields a signal, called the+        result signal.++        The result signal is composed of different sections. There is one section for each segment+        of the function signal. Such a section is formed as follows: For each argument signal, the+        part which corresponds to the time intervall of the functions signal&#x2019;s segment is cut+        out of the argument signal. The value of the function signal is applied to the resulting /n/+        signal parts. The result of this application is the desired section of the result signal.++        The signal functions which are applied to the parts of the argument signals use an+        universally quantified era parameter. This ensures that the results of these functions do+        not depend on signals from the outside but only on the parts of the argument signals. This+        is important since operations on signals require that their argument and result signals are+        of the same era. The usage of universial quantification in the type of @switch@+        corresponds to the usage of rank 2 polymorphism in the type of 'runST'.+    -}+    switch :: SSignal era (forall era'. SignalFun era' shape) -> SignalFun era shape+    switch = internalSwitch++    -- Level of indirection so that explicit global foralls don’t get into the API docs.+    internalSwitch :: forall era shape.+                      SSignal era (forall era'. SignalFun era' shape) -> SignalFun era shape+    internalSwitch funSignal@(SSignal init _) = case init :: SignalFun () shape of+                                                    OSF _ -> OSF $+                                                             osfSwitch (fmap polyUnOSF funSignal)++                                                    SSF _ -> SSF $+                                                             ssfSwitch (fmap polyUnSSF funSignal)++    polyUnOSF :: (forall era. SignalFun era (signal `Of` val)) -> forall era. signal era val+    polyUnOSF osf = unOSF osf++    polyUnSSF :: (forall era. SignalFun era (signal `Of` val :-> shape))+              -> forall era. (signal era val -> SignalFun era shape)+    polyUnSSF ssf = unSSF ssf++    -- * Signal functions+    -- FIXME: Hyperlink to :-> and document the data constructors seperately as soon as this works.+    {-|+        A signal function is a function which maps a certain number of signals to one signal whereby+        all argument signals and the result signal have the same era.++        The @era@ parameter of @SignalFun@ denotes the era of all argument signals and the result+        signal. The @shape@ parameter is a phantom parameter which specifies the number of argument+        signals as well as the types of the argument signals and the result signal without their era+        parameters. It has the following form:++        @+        /signal_1/ &#x60;'Of'&#x60; /val_1/ :-> ... :-> /signal_n/ &#x60;'Of'&#x60; /val_n/ :-> /signal'/ &#x60;'Of'&#x60; /val'/+        @++        The data constructors 'OSF' and 'SSF' construct signal functions of zero and non-zero arity,+        respectively. (The @O@ stands for &#x201C;zero&#x201D; and the @S@ stands for+        &#x201C;successor&#x201D;.) A signal function is typically formed by an expression like++        @+        'SSF' $ &#x5C;/signal_1/ ->+        ...+        'SSF' $ &#x5C;/signal_n/ ->+        'OSF' $ /signal'/+        @++        where @/signal'/@ is an expression that might use @/signal_1/@ to @/signal_n/@. Signal+        functions are usually applied like this:++        @+        'unOSF' $ /signalFun/ &#x60;'sfApp'&#x60; /signal_1/ &#x60;'sfApp'&#x60; ... &#x60;'sfApp'&#x60; /signal_n/+        @+    -}+    data SignalFun era shape where++        OSF :: (Signal signal) =>+               signal era val -> SignalFun era (signal `Of` val)++        SSF :: (Signal signal) =>+               (signal era val -> SignalFun era shape) -> SignalFun era (signal `Of` val :-> shape)++    -- |Converts a nullary signal function into its corresponding signal.+    unOSF :: SignalFun era (signal `Of` val) -> signal era val+    unOSF (OSF signal) = signal++    -- |Converts a signal function of non-zero arity into a true function.+    unSSF :: SignalFun era (signal `Of` val :-> shape) -> (signal era val -> SignalFun era shape)+    unSSF (SSF fun) = fun++    infixl 4 `sfApp`+    {-|+        Applies a signal function to a signal.++        @sfApp@ is equivalent to 'unSSF'.+    -}+    sfApp :: SignalFun era (signal `Of` val :-> shape) -> signal era val -> SignalFun era shape+    sfApp = unSSF++    infixr 1 :->+    {-|+        The @:->@ operator is used to form signal function shapes for 'SignalFun'. The shape+        @/argShape/ :-> /resultShape/@ stands for functions which map signals of shape @/argShape/@+        to signal functions of shape @/resultShape/@.+    -}+    data argShape :-> resultShape++    -- * Signal shapes+    -- FIXME: Make :-> a hyperlink when this works.+    {-|+        @Of@ is used to form signal shapes. Signal shapes are used as phantom types and denote a+        signal type except its era parameter.++        A signal shape @/signal/ &#x60;Of&#x60; /val/@ stands for a signal of type @/signal/ /era/+        /val/@ where the era parameter is provided by an external source. Signal shapes are used as+        signal function shapes of nullary functions and as argument shapes for @:->@. In this case,+        the era parameter is the era parameter of 'SignalFun'. Signal shapes are also used in+        records as defined by the module @FRP.Grapefruit.Record@ of package grapefruit-records.+    -}+    data (signal :: * -> * -> *) `Of` val++    -- * Sampling+    {-|+        The class of all signals which can be seen as discrete sequences of values. Such signals can+        be used to sample signals of class 'Samplee'.+    -}+    class Sampler sampler where++        sample :: (Samplee samplee) =>+                  sampler era (val -> val') -> samplee era val -> sampler era val'++        -- for internal use only+        samplerMap :: (val -> val') -> (sampler era val -> sampler era val')++    -- Samplee could also be called “dense signal”.+    {-|+        The class of all signals which assign a value to each time of their era. Such signals can be+        sampled by signals of class 'Sampler'.+    -}+    class Samplee samplee where++        -- for internal use only+        dSample :: DSignal era (val -> val') -> samplee era val -> DSignal era val'++        -- for internal use only+        sSample :: SSignal era (val -> val') -> samplee era val -> SSignal era val'++    {-|+        Sampling of signals.++        A signal @/sampler/ &#x3C;#> /samplee/@ has a value at each time where @/sampler/@ has a+        value. The value of @/sampler/ &#x3C;#> /samplee/@ is formed by applying the value of+        @/sampler/@ to the value, @/samplee/@ has at this time.++        This function has similarities with '<*>'.+    -}+    (<#>) :: (Sampler sampler, Samplee samplee) =>+             sampler era (val -> val') -> samplee era val -> sampler era val'+    (<#>) = sample++    {-|+        Sampling of signals where the values of the sampler are ignored.++        The following equation holds:++        @+        /sampler/ &#x23;> /samplee/ = id '<$' /sampler/ '<#>' /samplee/+        @++        This function has similarities with '*>'.+    -}+    (#>) :: (Sampler sampler, Samplee samplee) =>+            sampler era dummy -> samplee era val -> sampler era val+    (#>) = (<#>) . samplerMap (const id)++    {-|+        Sampling of signals where the values of the samplee are ignored.++        The following equation holds:++        @+        /sampler/ &#x3C;&#x23; /samplee/ = const '<$>' /sampler/ '<#>' /samplee/+        @++        This function has similarities with '<*'.+    -}+    (<#) :: (Sampler sampler, Samplee samplee) =>+            sampler era val -> samplee era dummy -> sampler era val+    (<#) = (<#>) . samplerMap const++    -- * Connectors+    -- |A consumer says what to do with a given signal.+    newtype Consumer signal val = Consumer (forall era. Circuit era (signal era val) ())+                                  -- ^A consumer, represented by a circuit that consumes a signal.++    -- |Yields a circuit which consumes a signal.+    consume :: Consumer signal val -> Circuit era (signal era val) ()+    consume (Consumer circuit) = circuit++    -- |A producer says how to produce a certain signal.+    newtype Producer signal val = Producer (forall era. Circuit era () (signal era val))+                                  -- ^A producer, represented by a circuit that produces a signal.++    -- |Yields a circuit which produces a signal.+    produce :: Producer signal val -> Circuit era () (signal era val)+    produce (Producer circuit) = circuit
+ src/Internal/Signal/Discrete.hs view
@@ -0,0 +1,355 @@+module Internal.Signal.Discrete (++    -- * Discrete signal type+    DSignal (DSignal),++    -- * Empty signal+    empty,++    -- * Combination+    -- ** Union+    union,+    unionWith,+    transUnion,++    unions,+    unionsWith,++    -- ** Difference+    difference,+    differenceWith,++    -- ** Intersection+    intersection,+    intersectionWith,++    -- * Mapping and filtering+    map,+    filter,+    catMaybes,+    mapMaybe,++    -- * Stateful signals+    scan,+    scan1,+    stateful,++    -- * Time IDs and capsules+    timeIDApp,+    crackCapsules,++    -- * Connectors+    consumer,+    producer++) where++    -- Prelude+    import Prelude hiding (map, filter)++    -- Control+    import Control.Arrow as Arrow+    import Control.Monad as Monad++    -- Data+    import Data.Monoid    as Monoid+    import Data.Unique    as Unique+    import Data.Map       as Map    (Map) -- for documentation only++    -- Internal+    import                Internal.Capsule          as Capsule+    import                Internal.Vista (Vista)+    import qualified      Internal.Vista            as Vista+    import                Internal.Signal           as Signal+    import {-# SOURCE #-} Internal.Signal.Segmented as SSignal++    -- FRP.Grapefruit+    import FRP.Grapefruit.Setup   as Setup+    import FRP.Grapefruit.Circuit as Circuit++    -- * Discrete signal type+    {-|+        The type of discrete signals.++        A discrete signal is a sequence of values assigned to discrete times. A pair of a time and a+        corresponding value is called an occurrence. You can think of @DSignal /era/ /val/@ as being+        equivalent to @'Map' (Time /era/) /val/@ where @Time /era/@ is the type of all times of+        the given era. However, an occurence at the starting time of the era is not possible. In+        contrast to 'Map', a discrete signal may cover infinitely many values.++        Discrete signals can describe sequences of events. For example, the sequence of all key+        presses could be described by a discrete signal of characters. Discrete signals are also+        used in conjunction with sampling.++        The discrete signal instances of 'Functor' and 'Monoid' provide the following method+        definitions:++        @+        'fmap'    = 'map'+        'mempty'  = 'empty'+        'mappend' = 'union'+        'mconcat' = 'unions'+        @+    -}+    newtype DSignal era val = DSignal (Vista val)++    instance Functor (DSignal era) where++        fmap = map++    instance Monoid (DSignal era val) where++        mempty  = empty++        mappend = union++    instance Signal DSignal where++        osfSwitch (SSignal init upd) = DSignal vista' where++            vista' = Vista.baseSwitch (vista init) (vista (fmap polyVista upd))++        ssfSwitch (SSignal init upd) arg = signalFun' where++            signalFun'  = switch (SSignal.fromInitAndUpdate reducedInit reducedUpd)++            reducedInit = init (DSignal (vista arg))++            reducedUpd  = DSignal (polyReducedFunUpdate (vista vistaFunUpd) (vista arg))++            vistaFunUpd = vistaFunSignal upd++    instance Sampler DSignal where++        sample = dSample++        samplerMap = fmap++    polyReducedFunUpdate :: Vista (Vista val -> forall era'. SignalFun era' shape)+                         -> Vista val+                         -> Vista (forall era'. SignalFun era' shape)+    polyReducedFunUpdate funUpdVista argVista = Vista.reducedFunUpdate funUpdVista argVista++    vistaFunSignal :: DSignal era (forall era'. DSignal era' val -> SignalFun era' shape)+                   -> DSignal era (Vista val -> forall era'. SignalFun era' shape)+    vistaFunSignal = fmap (\dSignalFun vista -> dSignalFun (DSignal vista))++    vista :: DSignal era val -> Vista val+    vista (DSignal val) = val++    polyVista :: (forall era. DSignal era val) -> Vista val+    polyVista dSignal = vista dSignal++    -- * Empty signal+    -- |A signal with no occurrences.+    empty :: DSignal era val+    empty = DSignal Vista.empty++    -- * Combination+    -- ** Union+    {-|+        Constructs the left-biased union of two discrete signals.++        @union@ is equivalent to @'unionWith' const@.+    -}+    union :: DSignal era val -> DSignal era val -> DSignal era val+    union = unionWith const++    {-|+        Constructs the union of two discrete signals, combining simultaneously occuring values via+        a combining function.++        @unionWith@ is equivalent to @'transUnion' id id@.+    -}+    unionWith :: (val -> val -> val) -> (DSignal era val -> DSignal era val -> DSignal era val)+    unionWith = transUnion id id++    {-|+        Union with conversion and combination.++        At each time, a signal @/dSignal1/@ or a signal @/dSignal2/@ has an occurence, the signal++        @+        transUnion /conv1/ /conv2/ /comb/ /dSignal1/ /dSignal2/+        @++        has an occurence, too. The value of this occurence is formed as follows:++        [@/conv1/ /val1/@]+            if @/dSignal1/@ has an occurence of value @/val1/@ and @/dSignal2/@ has no occurence++        [@/conv2/ /val2/@]+            if @/dSignal2/@ has an occurence of value @/val2/@ and @/dSignal1/@ has no occurence++        [@/comb/ /val1/ /val2/@]+            if @/dSignal1/@ has an occurence of value @/val1/@ and @/dSignal2/@ has an occurence of+            value @/val2/@+    -}+    transUnion :: (val1 -> val')+               -> (val2 -> val')+               -> (val1 -> val2 -> val')+               -> (DSignal era val1 -> DSignal era val2 -> DSignal era val')+    transUnion conv1 conv2 comb (DSignal vista1) (DSignal vista2) = DSignal vista' where++        vista' = Vista.transUnion conv1 conv2 comb vista1 vista2++    {-|+        Repeated left-biased union.++        @unions@ is equivalent to @foldl 'union' 'empty'@ and @'unionsWith' const@.+    -}+    unions :: [DSignal era val] -> DSignal era val+    unions = foldl union empty++    {-|+        Repeated union with a combining function.++        @unionsWith /comb/@ is equivalent to @foldl ('unionWith' /comb/) 'empty'@.+    -}+    unionsWith :: (val -> val -> val) -> [DSignal era val] -> DSignal era val+    unionsWith comb = foldl (unionWith comb) empty++    -- ** Difference+    {-|+        Constructs the difference of two discrete signals.++        @difference@ is equivalent to @'differenceWith' (\\_ _ -> Nothing)@.+    -}+    difference :: DSignal era val1 -> DSignal era val2 -> DSignal era val1+    difference = differenceWith (const (const Nothing))++    {-|+        Constructs a kind of difference of two discrete signals where occurences may be modified+        instead of being dropped.++        At each time, a signal @/dSignal1/@ has an occurence of a value @/val1/@, the signal+        @differenceWith /comb/ /dSignal1/ /dSignal/@ has++        [an occurence of @/val1/@]+            if @/dSignal2/@ has no occurence++        [an occurence of @/val'/@]+            if @/dSignal2/@ has an occurence of a value @/val2/@ and @/comb/ /val1/ /val2/ = Just+            /val'/@++        [no occurence]+            if @/dSignal2/@ has an occurence of a value @/val2/@ and @/comb/ /val1/ /val2/ =+            Nothing@+    -}+    differenceWith :: (val1 -> val2 -> Maybe val1)+                   -> (DSignal era val1 -> DSignal era val2 -> DSignal era val1)+    differenceWith comb = (catMaybes .) . transUnion Just (const Nothing) comb++    -- ** Intersection+    {-|+        Constructs the left-biased intersection of two discrete signals.++        @intersection@ is equivalent to @'intersectionWith' const@.+    -}+    intersection :: DSignal era val1 -> DSignal era val2 -> DSignal era val1+    intersection = intersectionWith const++    {-|+        Constructs the intersection of two discrete signals, combining values via a combining+        function.+    -}+    intersectionWith :: (val1 -> val2 -> val')+                     -> (DSignal era val1 -> DSignal era val2 -> DSignal era val')+    intersectionWith comb = (catMaybes .) .+                            transUnion (const Nothing) (const Nothing) ((Just .) . comb)++    -- * Mapping and filtering+    {-|+        Converts each value occuring in a discrete signal by applying a function to it.+    -}+    map :: (val -> val') -> (DSignal era val -> DSignal era val')+    map fun = mapMaybe (Just . fun)++    {-|+        Drops all occurence of a discrete signal whose values do not fulfill a given predicate.+    -}+    filter :: (val -> Bool) -> (DSignal era val -> DSignal era val)+    filter prd = mapMaybe (\val -> if prd val then Just val else Nothing)++    {-|+        Converts all occurences with values of the form @Just /val/@ into occurences with value+        @/val/@ and drops all occurences with value @Nothing@.+    -}+    catMaybes :: DSignal era (Maybe val) -> DSignal era val+    catMaybes = mapMaybe id++    {-|+        The combination of 'map' and 'catMaybes'.++        @mapMaybe /fun/@ is equivalent to @'catMaybes' . 'map' /fun/@.+    -}+    mapMaybe :: (val -> Maybe val') -> (DSignal era val -> DSignal era val')+    mapMaybe fun (DSignal vista) = DSignal $ Vista.mapMaybe fun vista++    -- * Stateful signals+    {-|+        Accumulates the values of a discrete signal, starting with a given initial value.++        Applying @scan /init/ /fun/@ to a discrete signal replaces its occurence values @/val_1/@,+        @/val_2/@ and so on by the values @/init/ &#x60;/fun/&#x60; /val_1/@, @(/init/+        &#x60;/fun/&#x60; /val_1/) &#x60;/fun/&#x60; /val_2/@ and so on.+    -}+    scan :: accu -> (accu -> val -> accu) -> (DSignal era val -> DSignal era accu)+    scan initAccu trans = stateful initAccu .+                          fmap (\val currentAccu -> join (,) (trans currentAccu val))++    {-|+        Accumulates the values of a discrete signal, starting with the first occuring value.++        Applying @scan1 /init/ /fun/@ to a discrete signal replaces its occurence values @/val_1/@,+        @/val_2/@, @/val_3/@ and so on by the values @/val_1/@, @/val_1/ &#x60;/fun/&#x60; /val_2/@,+        @(/val_1/ &#x60;/fun/&#x60; /val_2/) &#x60;/fun/&#x60; /val_3/@ and so on.+    -}+    scan1 :: (val -> val -> val) -> (DSignal era val -> DSignal era val)+    scan1 trans = stateful Nothing . fmap statefulTrans where++        statefulTrans val currentAccu = let++                                            nextAccu = maybe val (flip trans val) currentAccu++                                        in (nextAccu,Just nextAccu)++    {-|+        Constructs a discrete signal by repeatedly applying state transformers.++        Applying @stateful /init/@ to a discrete signal replaces its occurence values @/trans_1/@,+        @/trans_2/@, @/trans_3/@ and so on by the values @fst . /trans_1/ $ /init/@, @fst .+        /trans_2/ $ snd . /trans_1/ $ /init/@, @fst . /trans_3/ $ snd . /trans_2/ $ snd . /trans_1/+        $ /init/@ and so on.+    -}+    stateful :: state -> DSignal era (state -> (val,state)) -> DSignal era val+    stateful initState (DSignal transVista) = DSignal $ Vista.stateful initState transVista++    -- * Time IDs and capsules+    timeIDApp :: DSignal era (Unique -> val) -> DSignal era val+    timeIDApp (DSignal vista) = DSignal $ Vista.timeIDApp vista++    crackCapsules :: DSignal era (Capsule val) -> DSignal era val+    crackCapsules (DSignal vista ) = DSignal $ Vista.crackCapsules vista++    -- * Connectors+    {-|+        Converts an event handler into a discrete signal consumer.++        If a discrete signal is consumed with such a consumer, the handler is called at each+        occurence with the occuring value as its argument.+    -}+    consumer :: (val -> IO ()) -> Consumer DSignal val+    consumer handler = Consumer $ arr dSignalVista >>> Vista.consumer handler where++        dSignalVista (DSignal vista) = vista++    {-|+        Converts an event handler registration into a discrete signal producer.++        Applying the argument of @producer@ to an event handler has to yield a setup which makes the+        handler be called with a certain value everytime the produced signal shall have an+        occurence of this value.+    -}+    producer :: ((val -> IO ()) -> Setup) -> Producer DSignal val+    producer reg = Producer $ Vista.producer reg >>> arr DSignal
+ src/Internal/Signal/Discrete.hs-boot view
@@ -0,0 +1,9 @@+module Internal.Signal.Discrete (++    -- * Discrete signal type+    DSignal++) where++    -- * Discrete signal type+    data DSignal era val
+ src/Internal/Signal/Segmented.hs view
@@ -0,0 +1,228 @@+module Internal.Signal.Segmented (++    -- * Segmented signal type+    SSignal (SSignal),++    -- * Introduction+    fromInitAndUpdate,++    -- * Accessors+    withInit,+    update,++    -- * Stateful signals+    scan,++    -- * Capsules+    crackCapsules,++    -- * Connectors+    consumer++) where++    -- Prelude+    import Prelude hiding (init)++    -- Control+    import Control.Applicative as Applicative+    import Control.Arrow       as Arrow++    -- Internal+    import           Internal.Capsule                   as Capsule+    import           Internal.Signal                    as Signal+    import           Internal.Signal.Discrete (DSignal)+    import qualified Internal.Signal.Discrete           as DSignal++    -- FRP.Grapefruit+    import FRP.Grapefruit.Setup   as Setup+    import FRP.Grapefruit.Circuit as Circuit++    -- * Segmented signal type+    {-|+        The type of segmented signals.++        A segmented signal maps times to values like a continuous signal. However, it also comprises+        a set of discrete times, called /update points/. The signal can only change its value at its+        update points. As a special case, the starting time of the era is always considered an+        update point. So a segmented signal is composed of constant segments which are either+        bounded by adjacent update points or left-bounded by a last update point and+        right-unbounded. Note that value updates already take effect at the update point so that the+        segments are left-closed.++        It follows that a segmented signal is completely determined by the update points and the+        values assigned to them. Therefore, a segmented signal can also be seen as a kind of+        discrete signal with occurences at the update points. The only difference to a discrete+        signal is that a segmented signal always has an occurence at the starting time of the era+        whereas a discrete signal never has one.++        The dual nature of segmented signals is reflected by the class instances of @SSignal@.+        @SSignal@ is an instance of 'Samplee' as well as of 'Sampler'. The first means that it can+        be sampled and therefore has a continuous aspect. The second means that it can be used to+        sample a signal and therefore has a discrete aspect.+    -}+    data SSignal era val = SSignal val (DSignal era val)+    {-+        Reducing the signal (matching against (SSignal _ _)) forces all continous sources, the+        signal depends on, to be read. Similar for reducing DSignal values (means reduction of the+        map) and continous sources. Note that in the latter case, the initial value is not+        necessarily reduced but initial values of other continous signals which the continous+        signal’s internal SSignal depends on.++        In the case of SSignal, continuous sources have to be read at the beginning. This can be+        illustrated by thinking of the initial value as an occurence at starting time.++        It is important that upon construction of an SSignal/CSignal via a function the SSignal and+        CSignal constructors of arguments have to be reduced during reduction of the result.+        Otherwise triggering of continuous source reads would not work properly.+    -}++    instance Functor (SSignal era) where++        fmap fun (SSignal init upd) = SSignal (fun init) (fmap fun upd)++    instance Applicative (SSignal era) where++        pure val = SSignal val DSignal.empty++        SSignal funInit funUpd <*> SSignal argInit argUpd = SSignal init' upd' where++            init' = funInit argInit++            upd'  = fmap (uncurry ($)) $+                    DSignal.scan (funInit,argInit) (flip ($)) $+                    DSignal.transUnion (first . const)+                                       (second . const)+                                       ((const .) . (,))+                                       funUpd+                                       argUpd++    instance Signal SSignal where++        osfSwitch signal@(SSignal init upd) = case init of+                                                  SSignal init' _ -> SSignal init' upd'+                                              where++            upd'  = initUpdate upd `DSignal.union` osfSwitch (updateSignal signal)++        ssfSwitch signal arg@(SSignal _ argUpd) = ssfSwitch (fixInit <$> signal <#> arg) argUpd++    initUpdate :: DSignal era (forall era'. SSignal era' val) -> DSignal era val+    initUpdate upd = DSignal.crackCapsules (fmap polyInitCapsule upd)++    polyInitCapsule :: (forall era'. SSignal era' val) -> Capsule val+    polyInitCapsule signal = initCapsule signal++    initCapsule :: SSignal era' val -> Capsule val+    initCapsule (SSignal init _) = Applicative.pure init++    updateSignal :: SSignal era (forall era'. SSignal era' val)+                 -> SSignal era (forall era'. DSignal era' val)+    updateSignal signal = crackCapsules (fmap polyUpdateCapsule signal)++    polyUpdateCapsule :: (forall era'. SSignal era' val)+                      -> Capsule (forall era'. DSignal era' val)+    polyUpdateCapsule signal = signal `seq` polyCapsule (polyUpdate signal)++    polyCapsule :: (forall era'. DSignal era' val) -> Capsule (forall era'. DSignal era' val)+    polyCapsule signal = Capsule signal++    polyUpdate :: (forall era'. SSignal era' val) -> (forall era'. DSignal era' val)+    polyUpdate signal = update signal++    fixInit :: (forall era'. SSignal era' val -> signalFun era' shape)+            -> val+            -> (forall era'. DSignal era' val -> signalFun era' shape)+    fixInit fun init upd = fun (SSignal init upd)++    instance Sampler SSignal where++        sample = sSample++        samplerMap = fmap++    instance Samplee SSignal where++        dSample funs (SSignal argInit argUpd) = dSignal' where++            dSignal' = DSignal.catMaybes $+                       DSignal.stateful argInit $+                       DSignal.transUnion (\fun currentArg -> (Just (fun currentArg),currentArg))+                                          (\nextArg _      -> (Nothing,nextArg))+                                          (\fun nextArg _  -> (Just (fun nextArg),nextArg))+                                          funs+                                          argUpd++        sSample (SSignal samplerInit samplerUpd) signal@(SSignal init _) = SSignal init' upd' where++            init' = samplerInit init++            upd'  = samplerUpd <#> signal++    -- * Introduction+    {-|+        Constructs a segmented signal from an initial value and a series of updates.++        A signal @fromInitAndUpdate /init/ /upd/@ has initially the value @/init/@. At each+        occurence in @/upd/@, it has an update point and changes its value to the value occuring+        in @/upd/@. If the segmented signal is interpreted as a kind of discrete signal,+        @fromInitAndUpdate@ just adds an initial occurence of @/init/@ to the signal @/upd/@.+    -}+    fromInitAndUpdate :: val -> DSignal era val -> SSignal era val+    fromInitAndUpdate val upd = SSignal val upd++    -- * Accessors+    -- FIXME: Is it safe to support arbitrary signal types here?+    {-|+        Applies the second argument to the initial value of the first argument.++        Using @withInit@, it is possible to create a signal which is dependent on the initial value+        of a segmented signal but it is not possible to extract the initial value itself. The reason+        for this restriction is that the initial value may depend on values of continuous signals+        and therefore its calculation might involve doing I/O to read external continuous sources.+    -}+    withInit :: (Signal signal) => SSignal era val -> (val -> signal era val') -> signal era val'+    withInit (SSignal init _) cont = cont init++    -- Should be safe w.r.t. continous source fetching.+    {-|+        Yields the sequence of updates of a segmented signal.++        If the segmented signal is interpreted as a discrete signal with an additional occurence at+        the start then @update@ just drops this occurence.+    -}+    update :: SSignal era val -> DSignal era val+    update (SSignal _ upd) = upd++    -- * Stateful signals+    {-|+        Accumulates the values of a discrete signal.++        Applying @scan /init/ /fun/@ to a discrete signal replaces its occurence values @/val_1/@,+        @/val_2/@ and so on by the values @/init/ &#x60;/fun/&#x60; /val_1/@, @(/init/+        &#x60;/fun/&#x60; /val_1/) &#x60;/fun/&#x60; /val_2/@ and so on and adds an occurence of+        the value @/init/@ at the beginning.+    -}+    scan :: accu -> (accu -> val-> accu) -> (DSignal era val -> SSignal era accu)+    scan init fun upd = fromInitAndUpdate init (DSignal.scan init fun upd)++    -- * Capsules+    crackCapsules :: SSignal era (Capsule val) -> SSignal era val+    crackCapsules (SSignal (Capsule init) capUpd) = SSignal init (DSignal.crackCapsules capUpd)++    -- * Connectors+    {-|+        Converts an event handler into a segmented signal consumer.++        If a segmented signal is consumed with such a consumer, the handler is called at the+        starting time of the era and at each update with the current value of the signal as its+        argument. If the segmented signal is seen as a discrete signal with an additional occurence+        at the start then @consumer@ behaves analogous to the 'DSignal.consumer' function of+        "FRP.Grapefruit.Signal.Discrete".+    -}+    consumer :: (val -> IO ()) -> Consumer SSignal val+    consumer handler = Consumer $+                       proc (SSignal init upd) -> do+                           putSetup                           -< setup $+                                                                 handler init >> return (return ())+                           consume (DSignal.consumer handler) -< upd
+ src/Internal/Signal/Segmented.hs-boot view
@@ -0,0 +1,20 @@+module Internal.Signal.Segmented (++    -- * Segmented signal type+    SSignal (SSignal),++    -- * Introduction+    fromInitAndUpdate++) where++    -- Internal+    import {-# SOURCE #-} Internal.Signal.Discrete as DSignal++    -- * Segmented signal type+    data SSignal era val = SSignal val (DSignal era val)++    instance Functor (SSignal era)++    -- * Introduction+    fromInitAndUpdate :: val -> DSignal era val -> SSignal era val
+ src/Internal/Vista.hs view
@@ -0,0 +1,285 @@+module Internal.Vista (++    Vista,+    empty,+    transUnion,+    stateful,+    mapMaybe,+    baseSwitch,+    reducedFunUpdate,+    timeIDApp,+    crackCapsules,+    consumer,+    producer++) where++    -- Prelude+    import Prelude hiding (filter)++    -- Control+    import Control.Arrow           as Arrow+    import Control.Monad           as Monad+    import Control.Concurrent.Chan as Chan++    -- Data+    import           Data.Function  as Function+    import           Data.Maybe     as Maybe hiding (mapMaybe)+    import           Data.Map (Map)+    import qualified Data.Map       as Map+    import           Data.IORef     as IORef+    import           Data.Unique    as Unique++    -- System+    import System.IO.Unsafe as UnsafeIO++    -- Internal+    import           Internal.ListenerSet (ListenerSet)+    import qualified Internal.ListenerSet               as ListenerSet+    import           Internal.Capsule                   as Capsule+    import           Internal.Circuit                   as Circuit++    -- FRP.Grapefruit+    import FRP.Grapefruit.Setup   as Setup+    import FRP.Grapefruit.Circuit as Circuit++    {- FIXME:++        This implementation is a bit inefficient because there is a complete re-registration after+        every event the sink listens to. We can make it more efficient by including two additional+        fields into Variant describing the difference between the old and the new set of discrete+        sources: one set covering the added sources and one covering the removed sources.++    -}++    newtype Vista val = Vista (VistaMap val)++    type VistaMap val = Map DSource (Variant val)++    data DSource = DSource Unique (IORef ListenerSet)++    instance Eq DSource where++        DSource id1 _ == DSource id2 _ = id1 == id2++    instance Ord DSource where++        compare (DSource id1 _) (DSource id2 _) = compare id1 id2++    data Variant val = Variant Unique (Maybe val) (Vista val)++    empty :: Vista val+    empty = Vista Map.empty++    mapTransUnion :: (Ord key)+                  => (val1 -> val')+                  -> (val2 -> val')+                  -> (val1 -> val2 -> val')+                  -> (Map key val1 -> Map key val2 -> Map key val')+    mapTransUnion conv1 conv2 comb map1 map2 = map' where++        map'            = convMap1 `Map.union` convMap2 `Map.union` intersectionMap++        convMap1        = Map.map conv1 (map1 `Map.difference` intersectionMap)++        convMap2        = Map.map conv2 (map2 `Map.difference` intersectionMap)++        intersectionMap = Map.intersectionWith comb map1 map2++    {-+        Maybe it’s better if unionWith isn’t implemented on top of transUnion. Consider the case+        that we merge many signals whose discrete source sets don’t overlap. transUnion applies id+        linearily many times to the values while a directly implemented unionWith wouldn’t do so.+    -}+    transUnion :: (val1 -> val')+               -> (val2 -> val')+               -> (val1 -> val2 -> val')+               -> (Vista val1 -> Vista val2 -> Vista val')+    transUnion conv1 conv2 comb vista1@(Vista map1) vista2@(Vista map2) = Vista map' where++        map'                                        = mapTransUnion variantConv1+                                                                    variantConv2+                                                                    variantComb+                                                                    map1+                                                                    map2++        variantConv1 (Variant timeID1 maybeVal1 nextVista1) = Variant timeID1+                                                                      (fmap conv1 maybeVal1)+                                                                      (this nextVista1 vista2)++        variantConv2 (Variant timeID2 maybeVal2 nextVista2) = Variant timeID2+                                                                      (fmap conv2 maybeVal2)+                                                                      (this vista1 nextVista2)++        variantComb (Variant timeID1 maybeVal1 nextVista1)+                    (Variant timeID2 maybeVal2 nextVista2)  = Variant timeID1+                                                                      (maybeComb maybeVal1+                                                                                 maybeVal2)+                                                                      (this nextVista1 nextVista2)++        maybeComb Nothing     Nothing                       = Nothing+        maybeComb Nothing     (Just val2)                   = Just (conv2 val2)+        maybeComb (Just val1) Nothing                       = Just (conv1 val1)+        maybeComb (Just val1) (Just val2)                   = Just (comb val1 val2)++        this                                                = transUnion conv1 conv2 comb++    stateful :: state -> Vista (state -> (val',state)) -> Vista val'+    stateful initState (Vista transMap) = Vista $ Map.map variantConv transMap where++        variantConv (Variant timeID Nothing      nextVista) = Variant timeID+                                                                      Nothing+                                                                      (stateful initState nextVista)+        variantConv (Variant timeID (Just trans) nextVista) = let++                                                                  (val',nextState) = trans initState++                                                              in Variant timeID+                                                                         (Just val')+                                                                         (stateful nextState+                                                                                   nextVista)++    mapMaybe :: (val -> Maybe val') -> (Vista val -> Vista val')+    mapMaybe fun (Vista map) = Vista (Map.map variantConv map) where++        variantConv (Variant timeID maybeVal nextVista) = Variant timeID+                                                                  (maybeVal >>= fun)+                                                                  (mapMaybe fun nextVista)++    baseSwitch :: Vista val -> Vista (Vista val) -> Vista val+    baseSwitch valVista@(Vista valMap) switchVista@(Vista switchMap) = Vista map' where++        map'                                    = mapTransUnion valConv+                                                                switchConv+                                                                comb+                                                                valMap+                                                                switchMap++        valConv    (Variant valTimeID+                            maybeVal+                            nextValVista)       = Variant valTimeID+                                                          maybeVal+                                                          (baseSwitch nextValVista switchVista)++        switchConv (Variant switchTimeID+                            Nothing+                            nextSwitchVista)    = Variant switchTimeID+                                                          Nothing+                                                          (baseSwitch valVista nextSwitchVista)+        switchConv (Variant switchTimeID+                            (Just nextValVista)+                            nextSwitchVista)    = Variant switchTimeID+                                                          Nothing+                                                          (baseSwitch nextValVista nextSwitchVista)++        comb       (Variant valTimeID+                            maybeVal+                            nextValVista)+                   (Variant switchTimeID+                            Nothing+                            nextSwitchVista)    = Variant valTimeID+                                                          maybeVal+                                                          (baseSwitch nextValVista nextSwitchVista)+        comb       (Variant valTimeID+                            maybeVal+                            _)+                   (Variant _+                            (Just nextValVista)+                            nextSwitchVista)    = Variant valTimeID+                                                          maybeVal+                                                          (baseSwitch nextValVista nextSwitchVista)++    reducedFunUpdate :: Vista (Vista val -> fun) -> Vista val -> Vista fun+    reducedFunUpdate funUpdVista@(Vista funUpdMap)+                     argVista@(Vista argMap)       = Vista $ reducedMap funUpdMap argMap where++        reducedMap                                       = mapTransUnion funUpdConv argConv comb++        funUpdConv (Variant funTimeID+                            maybeFunUpd+                            nextFunUpdVista) = Variant funTimeID+                                                       (fmap ($ argVista) maybeFunUpd)+                                                       (reducedFunUpdate nextFunUpdVista argVista)++        argConv    (Variant argTimeID+                            maybeArg+                            nextArgVista)    = Variant argTimeID+                                                       Nothing+                                                       (reducedFunUpdate funUpdVista nextArgVista)++        comb       (Variant funTimeID+                            maybeFunUpd+                            nextFunUpdVista)+                   (Variant argTimeID+                            _+                            nextArgVista)    = Variant funTimeID+                                                       (fmap ($ nextArgVista) maybeFunUpd)+                                                       (reducedFunUpdate nextFunUpdVista+                                                                         nextArgVista)++    timeIDApp :: Vista (Unique -> val) -> Vista val+    timeIDApp (Vista map) = Vista $ Map.map variantConv map where++        variantConv (Variant timeID maybeFun nextVista) = Variant timeID+                                                                  (fmap ($ timeID) maybeFun)+                                                                  (timeIDApp nextVista)++    -- Reducing the resulting Variant means reducing the capsule.+    crackCapsules :: Vista (Capsule val) -> Vista val+    crackCapsules (Vista map) = Vista $ Map.map variantConv map where++        variantConv (Variant timeID+                             Nothing+                             nextVista)           = Variant timeID+                                                            Nothing+                                                            (crackCapsules nextVista)+        variantConv (Variant timeID+                             (Just (Capsule val))+                             nextVista)           = Variant timeID+                                                            (Just val)+                                                            (crackCapsules nextVista)++    consumer :: (val -> IO ()) -> Circuit era (Vista val) ()+    consumer handler = proc vista -> putSetup -< setup $+                                                 do+                                                     unregRef <- newIORef undefined+                                                     setDSourceSet handler unregRef vista+                                                     return $ join (readIORef unregRef)++    setDSourceSet :: (val -> IO ()) -> IORef (IO ()) -> Vista val -> IO ()+    setDSourceSet handler unregRef (Vista map) = do+                                                     unreg <- mapM (uncurry sourceReg)+                                                                   (Map.assocs map)+                                                     writeIORef unregRef (sequence_ unreg) where++        sourceReg (DSource _ listenersRef) variant = ListenerSet.add listenersRef (handle variant)++        handle (Variant _ maybeVal nextVista)      = do+                                                         when (isJust maybeVal)+                                                              (handler (fromJust maybeVal))+                                                         join (readIORef unregRef)+                                                         setDSourceSet handler unregRef nextVista++    producer :: ((val -> IO ()) -> Setup) -> Circuit era () (Vista val)+    producer register = proc _ -> do+                            sourceID <- act -< newUnique+                            listenersRef <- act -< newIORef ListenerSet.empty+                            timeIDs <- act -< fix (unsafeInterleaveIO . liftM2 (:) newUnique)+                            chan <- act -< newChan+                            vals <- act -< getChanContents chan+                            ecFinalization <- getECFinalization -< ()+                            putSetup -< register $ \val -> do+                                                               writeChan chan val+                                                               listeners <- readIORef listenersRef+                                                               ListenerSet.notify listeners+                                                               ecFinalization+                            returnA -< sourceVista (DSource sourceID listenersRef) timeIDs vals++    sourceVista :: DSource -> [Unique] -> [val] -> Vista val+    sourceVista source timeIDs vals = Vista $+                                      Map.singleton source (sourceVariant source timeIDs vals)++    sourceVariant :: DSource -> [Unique] -> [val] -> Variant val+    sourceVariant source (timeID : nextTimeIDs) (val : nextVals) = variant where++        variant = Variant timeID (Just val) (sourceVista source nextTimeIDs nextVals)