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-frp.cabal b/grapefruit-frp.cabal new file mode 100644 --- /dev/null +++ b/grapefruit-frp.cabal @@ -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 + . + . + 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 diff --git a/src/FRP/Grapefruit/Circuit.hs b/src/FRP/Grapefruit/Circuit.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Grapefruit/Circuit.hs @@ -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 diff --git a/src/FRP/Grapefruit/Setup.hs b/src/FRP/Grapefruit/Setup.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Grapefruit/Setup.hs @@ -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) diff --git a/src/FRP/Grapefruit/Signal.hs b/src/FRP/Grapefruit/Signal.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Grapefruit/Signal.hs @@ -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 diff --git a/src/FRP/Grapefruit/Signal/Continuous.hs b/src/FRP/Grapefruit/Signal/Continuous.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Grapefruit/Signal/Continuous.hs @@ -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) diff --git a/src/FRP/Grapefruit/Signal/Discrete.hs b/src/FRP/Grapefruit/Signal/Discrete.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Grapefruit/Signal/Discrete.hs @@ -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 diff --git a/src/FRP/Grapefruit/Signal/Segmented.hs b/src/FRP/Grapefruit/Signal/Segmented.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Grapefruit/Signal/Segmented.hs @@ -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 diff --git a/src/Internal/CSeg.hs b/src/Internal/CSeg.hs new file mode 100644 --- /dev/null +++ b/src/Internal/CSeg.hs @@ -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 diff --git a/src/Internal/Capsule.hs b/src/Internal/Capsule.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Capsule.hs @@ -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) diff --git a/src/Internal/Circuit.hs b/src/Internal/Circuit.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Circuit.hs @@ -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 diff --git a/src/Internal/ListenerSet.hs b/src/Internal/ListenerSet.hs new file mode 100644 --- /dev/null +++ b/src/Internal/ListenerSet.hs @@ -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) diff --git a/src/Internal/Signal.hs b/src/Internal/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Signal.hs @@ -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’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/ `'Of'` /val_1/ :-> ... :-> /signal_n/ `'Of'` /val_n/ :-> /signal'/ `'Of'` /val'/ + @ + + The data constructors 'OSF' and 'SSF' construct signal functions of zero and non-zero arity, + respectively. (The @O@ stands for “zero” and the @S@ stands for + “successor”.) A signal function is typically formed by an expression like + + @ + 'SSF' $ \/signal_1/ -> + ... + 'SSF' $ \/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/ `'sfApp'` /signal_1/ `'sfApp'` ... `'sfApp'` /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/ `Of` /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/ <#> /samplee/@ has a value at each time where @/sampler/@ has a + value. The value of @/sampler/ <#> /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/ #> /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/ <# /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 diff --git a/src/Internal/Signal/Discrete.hs b/src/Internal/Signal/Discrete.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Signal/Discrete.hs @@ -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/ `/fun/` /val_1/@, @(/init/ + `/fun/` /val_1/) `/fun/` /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/ `/fun/` /val_2/@, + @(/val_1/ `/fun/` /val_2/) `/fun/` /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 diff --git a/src/Internal/Signal/Discrete.hs-boot b/src/Internal/Signal/Discrete.hs-boot new file mode 100644 --- /dev/null +++ b/src/Internal/Signal/Discrete.hs-boot @@ -0,0 +1,9 @@ +module Internal.Signal.Discrete ( + + -- * Discrete signal type + DSignal + +) where + + -- * Discrete signal type + data DSignal era val diff --git a/src/Internal/Signal/Segmented.hs b/src/Internal/Signal/Segmented.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Signal/Segmented.hs @@ -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/ `/fun/` /val_1/@, @(/init/ + `/fun/` /val_1/) `/fun/` /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 diff --git a/src/Internal/Signal/Segmented.hs-boot b/src/Internal/Signal/Segmented.hs-boot new file mode 100644 --- /dev/null +++ b/src/Internal/Signal/Segmented.hs-boot @@ -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 diff --git a/src/Internal/Vista.hs b/src/Internal/Vista.hs new file mode 100644 --- /dev/null +++ b/src/Internal/Vista.hs @@ -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)