{-# LANGUAGE ExistentialQuantification, GeneralizedNewtypeDeriving #-}{-# OPTIONS_GHC -fno-warn-name-shadowing #-}{-|
This is the core module of Elerea, which contains the signal
implementation and the atomic constructors.
The basic idea is to create a dataflow network whose structure closely
resembles the user's definitions by turning each combinator into a
mutable variable (an 'IORef'). In other words, each signal is
represented by a variable. Such a variable contains information about
the operation to perform and (depending on the operation) references
to other signals. For instance, a pointwise function application
created by the '<*>' operator contains an 'SNA' node, which holds two
references: one to the function signal and another to the argument
signal.
In order to have a pure(-looking) applicative interface for the most
part, the library relies on 'unsafePerformIO' to create the references
of stateless signals, while stateful signals have to be obtained from
a special 'SignalMonad', which is just a wrapping of 'IO' that doesn't
allow any other action to be performed.
The execution of the network is explicitly marked as an IO operation.
The core library exposes a single function to animate the network
called 'superstep', which takes a signal and a time interval, and
mutates all the variables the signal depends on. It is supposed to be
called repeatedly in a loop that also takes care of user input.
To ensure consistency, a superstep has three phases: sampling, aging
and finalisation. Each signal reachable from the top-level signal
passed to 'superstep' is sampled at the current point of time
('sample'), and the sample is stored along with the old signal in its
reference. If the value of a signal is requested multiple times, the
sample is simply reused. After successfully sampling the top-level
signal, the network is traversed again to advance by the desired time
('advance'), and when that's completed, the finalisation process
throws away the intermediate samples and marks the aged signals as the
current ones, ready to be sampled again. If there is a dependency
loop, the system tries to use the 'sampleDelayed' function instead of
'sample' to get a useful value at the problematic spot instead of
entering an infinite loop. Evaluation is initiated by the
'signalValue' function (which is used in both the sampling and the
aging phase to calculate samples and retrieve the cached values if
they are requested again), aging is performed by 'age', while
finalisation is done by 'commit'. Since these functions are invoked
recursively on a data structure with existential types, their types
also need to be explicity quantified.
As a bonus, applicative nodes are automatically collapsed into lifted
functions of up to five arguments. This optimisation significantly
reduces the number of nodes in the network.
-}moduleFRP.Elerea.Legacy.InternalwhereimportControl.ApplicativeimportControl.MonadimportControl.Monad.FiximportData.IORefimportSystem.IO.Unsafe-- * Implementation-- ** Some type synonyms{-| Time is continuous. Nothing fancy. -}typeDTime=Double{-| Sinks are used when feeding input into peripheral-bound signals. -}typeSinka=a->IO()-- ** The data structures behind signals{-| A restricted monad to create stateful signals in. -}newtypeSignalMonada=SM{createSignal::IOa}deriving(Monad,Applicative,Functor,MonadFix){-| A printing function that can be used in the 'SignalMonad'.
Provided for debugging purposes. -}signalDebug::Showa=>a->SignalMonad()signalDebug=SM.print{-| A signal is conceptually a time-varying value. -}newtypeSignala=S(IORef(SignalTransa)){-| A node can have four states that distinguish various stages of
sampling and aging. -}dataSignalTransa-- | @Ready s@ is simply the signal @s@ that was not sampled yet=Ready(SignalNodea)-- | @Sampling s@ is signal @s@ after its current value was-- requested, but not yet delivered|Sampling(SignalNodea)-- | @Sampled x s@ is signal @s@ paired with its current value @x@|Sampleda(SignalNodea)-- | @Aged x s@ is the aged version of signal @s@ paired with its-- current value @x@|Ageda(SignalNodea){-| The possible structures of a node are defined by the 'SignalNode'
type. Note that the @SNFx@ nodes are only needed to optimise
applicatives, they can all be expressed in terms of @SNK@ and
@SNA@. -}dataSignalNodea-- | @SNK x@: constantly @x@=SNKa-- | @SNS x t@: stateful generator, where @x@ is current state and-- @t@ is the update function|SNSa(DTime->a->a)-- | @SNT s x t@: stateful transfer function, which also depends-- on an input signal @s@|forallt.SNT(Signalt)a(DTime->t->a->a)-- | @SNA sf sx@: pointwise function application|forallt.SNA(Signal(t->a))(Signalt)-- | @SNH ss r@: the higher-order signal @ss@ collapsed into a-- signal cached in reference @r@; @r@ is used during the aging-- phase|SNH(Signal(Signala))(IORef(Signala))-- | @SNM b sm@: signal generator that executes the monad carried-- by @sm@ whenever @b@ is true, and outputs the result (or-- undefined when @b@ is false)|SNM(SignalBool)(Signal(SignalMonada))-- | @SNE r@: opaque reference to connect peripherals|SNE(IORefa)-- | @SND s@: the @s@ signal delayed by one superstep|SNDa(Signala)-- | @SNKA s l@: equivalent to @s@ while aging signal @l@|forallt.SNKA(Signala)(Signalt)-- | @SNF1 f@: @fmap f@|forallt.SNF1(t->a)(Signalt)-- | @SNF2 f@: @liftA2 f@|forallt1t2.SNF2(t1->t2->a)(Signalt1)(Signalt2)-- | @SNF3 f@: @liftA3 f@|forallt1t2t3.SNF3(t1->t2->t3->a)(Signalt1)(Signalt2)(Signalt3)-- | @SNF4 f@: @liftA4 f@|forallt1t2t3t4.SNF4(t1->t2->t3->t4->a)(Signalt1)(Signalt2)(Signalt3)(Signalt4)-- | @SNF5 f@: @liftA5 f@|forallt1t2t3t4t5.SNF5(t1->t2->t3->t4->t5->a)(Signalt1)(Signalt2)(Signalt3)(Signalt4)(Signalt5){-| You can uncomment the verbose version of this function to see the
applicative optimisations in action. -}debugLog::String->IOa->IOa--debugLog s io = putStrLn s >> iodebugLog_io=ioinstanceFunctorSignalwherefmap=(<*>).pure{-| The 'Applicative' instance with run-time optimisation. The '<*>'
operator tries to move all the pure parts to its left side in order to
flatten the structure, hence cutting down on book-keeping costs. Since
applicatives are used with pure functions and lifted values most of
the time, one can gain a lot by merging these nodes. -}instanceApplicativeSignalwhere-- | A constant signalpure=makeSignalUnsafe.SNK-- | Point-wise application of a function and a data signal (like @ZipList@)-- --mf <*> mx = sampler (fmap (\f -> sampler (fmap (pure . f) mx)) mf)-- sf <*> sx = sampler (makeSignalUnsafe (SNF1 (\f -> sampler (makeSignalUnsafe (SNF1 (pure . f) sx))) sf))f@(Srf)<*>x@(Srx)=unsafePerformIO$do-- General fall-back casec<-newIORef(Ready(SNAfx))letopts=writeIORefc(Readys)-- Optimisations might go haywire in the presence of loops,-- so we need to prepare to meeting undefined references by-- wrapping reads into exception handlers.flipcatch(const(debugLog"no_fun"$return()))$doReadynf<-readIORefrfmerged<-flipcatch(const(debugLog"no_arg"$returnFalse))$do-- Merging constant branches from the two sidesReadynx<-readIORefrxcase(nf,nx)of(SNKg,SNKy)->debugLog"merge_00"$opt(SNK(gy))(SNKg,SNF1hy1)->debugLog"merge_01"$opt(SNF1(g.h)y1)(SNKg,SNF2hy1y2)->debugLog"merge_02"$opt(SNF2(\y1y2->g(hy1y2))y1y2)(SNKg,SNF3hy1y2y3)->debugLog"merge_03"$opt(SNF3(\y1y2y3->g(hy1y2y3))y1y2y3)(SNKg,SNF4hy1y2y3y4)->debugLog"merge_04"$opt(SNF4(\y1y2y3y4->g(hy1y2y3y4))y1y2y3y4)(SNKg,SNF5hy1y2y3y4y5)->debugLog"merge_05"$opt(SNF5(\y1y2y3y4y5->g(hy1y2y3y4y5))y1y2y3y4y5)(SNKg,_)->debugLog"lift_1x"$opt(SNF1gx)(SNF1gx1,SNKy)->debugLog"merge_10"$opt(SNF1(\x1->gx1y)x1)(SNF1gx1,SNF1hy1)->debugLog"merge_11"$opt(SNF2(\x1y1->gx1(hy1))x1y1)(SNF1gx1,SNF2hy1y2)->debugLog"merge_12"$opt(SNF3(\x1y1y2->gx1(hy1y2))x1y1y2)(SNF1gx1,SNF3hy1y2y3)->debugLog"merge_13"$opt(SNF4(\x1y1y2y3->gx1(hy1y2y3))x1y1y2y3)(SNF1gx1,SNF4hy1y2y3y4)->debugLog"merge_14"$opt(SNF5(\x1y1y2y3y4->gx1(hy1y2y3y4))x1y1y2y3y4)(SNF1gx1,_)->debugLog"lift_2x"$opt(SNF2gx1x)(SNF2gx1x2,SNKy)->debugLog"merge_20"$opt(SNF2(\x1x2->gx1x2y)x1x2)(SNF2gx1x2,SNF1hy1)->debugLog"merge_21"$opt(SNF3(\x1x2y1->gx1x2(hy1))x1x2y1)(SNF2gx1x2,SNF2hy1y2)->debugLog"merge_22"$opt(SNF4(\x1x2y1y2->gx1x2(hy1y2))x1x2y1y2)(SNF2gx1x2,SNF3hy1y2y3)->debugLog"merge_23"$opt(SNF5(\x1x2y1y2y3->gx1x2(hy1y2y3))x1x2y1y2y3)(SNF2gx1x2,_)->debugLog"lift_3x"$opt(SNF3gx1x2x)(SNF3gx1x2x3,SNKy)->debugLog"merge_30"$opt(SNF3(\x1x2x3->gx1x2x3y)x1x2x3)(SNF3gx1x2x3,SNF1hy1)->debugLog"merge_31"$opt(SNF4(\x1x2x3y1->gx1x2x3(hy1))x1x2x3y1)(SNF3gx1x2x3,SNF2hy1y2)->debugLog"merge_32"$opt(SNF5(\x1x2x3y1y2->gx1x2x3(hy1y2))x1x2x3y1y2)(SNF3gx1x2x3,_)->debugLog"lift_4x"$opt(SNF4gx1x2x3x)(SNF4gx1x2x3x4,SNKy)->debugLog"merge_40"$opt(SNF4(\x1x2x3x4->gx1x2x3x4y)x1x2x3x4)(SNF4gx1x2x3x4,SNF1hy1)->debugLog"merge_41"$opt(SNF5(\x1x2x3x4y1->gx1x2x3x4(hy1))x1x2x3x4y1)(SNF4gx1x2x3x4,_)->debugLog"lift_5x"$opt(SNF5gx1x2x3x4x)(SNF5gx1x2x3x4x5,SNKy)->debugLog"merge_50"$opt(SNF5(\x1x2x3x4x5->gx1x2x3x4x5y)x1x2x3x4x5)_->return()returnTrue-- Lifting into higher arity not knowing the argumentwhen(notmerged)$casenfofSNKg->debugLog"lift_1"$opt(SNF1gx)SNF1gx1->debugLog"lift_2"$opt(SNF2gx1x)SNF2gx1x2->debugLog"lift_3"$opt(SNF3gx1x2x)SNF3gx1x2x3->debugLog"lift_4"$opt(SNF4gx1x2x3x)SNF4gx1x2x3x4->debugLog"lift_5"$opt(SNF5gx1x2x3x4x)_->return()-- The final versionreturn(Sc){-| The @Show@ instance is only defined for the sake of 'Num'... -}instanceShow(Signala)whereshowsPrec__s="<SIGNAL>"++s{-| The equality test checks whether two signals are physically the same. -}instanceEq(Signala)whereSs1==Ss2=s1==s2{-| Error message for unimplemented instance functions. -}unimp::String->aunimp=error.("Signal: "++)instanceOrdt=>Ord(Signalt)wherecompare=unimp"compare"min=liftA2minmax=liftA2maxinstanceEnumt=>Enum(Signalt)wheresucc=fmapsuccpred=fmappredtoEnum=pure.toEnumfromEnum=unimp"fromEnum"enumFrom=unimp"enumFrom"enumFromThen=unimp"enumFromThen"enumFromTo=unimp"enumFromTo"enumFromThenTo=unimp"enumFromThenTo"instanceBoundedt=>Bounded(Signalt)whereminBound=pureminBoundmaxBound=puremaxBoundinstanceNumt=>Num(Signalt)where(+)=liftA2(+)(-)=liftA2(-)(*)=liftA2(*)signum=fmapsignumabs=fmapabsnegate=fmapnegatefromInteger=pure.fromIntegerinstanceRealt=>Real(Signalt)wheretoRational=unimp"toRational"instanceIntegralt=>Integral(Signalt)wherequot=liftA2quotrem=liftA2remdiv=liftA2divmod=liftA2modquotRemab=(fst<$>qrab,snd<$>qrab)whereqrab=quotRem<$>a<*>bdivModab=(fst<$>dmab,snd<$>dmab)wheredmab=divMod<$>a<*>btoInteger=unimp"toInteger"instanceFractionalt=>Fractional(Signalt)where(/)=liftA2(/)recip=fmaprecipfromRational=pure.fromRationalinstanceFloatingt=>Floating(Signalt)wherepi=purepiexp=fmapexpsqrt=fmapsqrtlog=fmaplog(**)=liftA2(**)logBase=liftA2logBasesin=fmapsintan=fmaptancos=fmapcosasin=fmapasinatan=fmapatanacos=fmapacossinh=fmapsinhtanh=fmaptanhcosh=fmapcoshasinh=fmapasinhatanh=fmapatanhacosh=fmapacosh-- ** Internal functions to run the network{-| Creating a reference within the 'SignalMonad'. Used for stateful
signals. -}makeSignal::SignalNodea->SignalMonad(Signala)makeSignalnode=SM$doref<-newIORef(Readynode)return(Sref){-| Creating a reference as a pure value. Used for stateless
signals. -}makeSignalUnsafe::SignalNodea->SignalamakeSignalUnsafe=S.unsafePerformIO.newIORef.Ready{-| Sampling the signal and all of its dependencies, at the same time.
We don't need the aged signal in the current superstep, only the
current value, so we sample before propagating the changes, which
might require the fresh sample because of recursive definitions. -}signalValue::foralla.Signala->DTime->IOasignalValue(Sr)dt=dot<-readIORefrcasetofReadys->dowriteIORefr(Samplings)-- TODO: advance can be evaluated in a separate-- thread, since we don't need its result right-- away, only in the next superstep.v<-samplesdt-- We memorise the sample to handle loops-- nicely. The undefined future signal cannot-- bite us, because we don't need it during the-- evaluation phase.writeIORefr(Sampledvs)returnvSamplings->do-- We started sampling this already, so there is-- a dependency cycle we have to resolve by-- adding a delay to stateful signals. Stateless-- signals should not form a loop, which is-- obvious...v<-sampleDelayedsdtwriteIORefr(Sampledvs)-- Since we are sampling it already, this node-- will be overwritten by the case above when-- the loop is closed.returnvSampledv_->returnvAgedv_->returnv{-| Aging the network of signals the given signal depends on. -}age::foralla.Signala->DTime->IO()age(Sr)dt=dot<-readIORefrcasetofSampledvs->dos'<-advancesvdtwriteIORefr(Agedvs')-- TODO: branching can be trivially parallelisedcases'ofSNTs__->agesdtSNAsfsx->agesfdt>>agesxdtSNHssr->agessdt>>readIORefr>>=\s->agesdtSNMbsm->agebdt>>agesmdtSND_s->agesdtSNKAsl->agesdt>>ageldtSNF1_s->agesdtSNF2_s1s2->ages1dt>>ages2dtSNF3_s1s2s3->ages1dt>>ages2dt>>ages3dtSNF4_s1s2s3s4->ages1dt>>ages2dt>>ages3dt>>ages4dtSNF5_s1s2s3s4s5->ages1dt>>ages2dt>>ages3dt>>ages4dt>>ages5dt_->return()Aged__->return()_->error"Inconsistent state: signal not sampled properly!"{-| Finalising aged signals for the next round. -}commit::foralla.Signala->IO()commit(Sr)=dot<-readIORefrcasetofAged_s->dowriteIORefr(Readys)-- TODO: branching can be trivially parallelisedcasesofSNTs__->commitsSNAsfsx->commitsf>>commitsxSNHssr->commitss>>readIORefr>>=\s->commitsSNMbsm->commitb>>commitsmSND_s->commitsSNKAsl->commits>>commitlSNF1_s->commitsSNF2_s1s2->commits1>>commits2SNF3_s1s2s3->commits1>>commits2>>commits3SNF4_s1s2s3s4->commits1>>commits2>>commits3>>commits4SNF5_s1s2s3s4s5->commits1>>commits2>>commits3>>commits4>>commits5_->return()Ready_->return()_->error"Inconsistent state: signal not aged properly!"{-| Aging the signal. Stateful signals have their state forced to
prevent building up big thunks. The other nodes are structurally
static. -}advance::SignalNodea->a->DTime->IO(SignalNodea)advance(SNSxf)_dt=x`seq`return(SNS(fdtx)f)advance(SNTs_f)v_=v`seq`return(SNTsvf)advance(SND_s)_dt=dox<-signalValuesdtreturn(SNDxs)advances__=returns{-| Sampling the signal at the current moment. This is where static
nodes propagate changes to those they depend on. Transfer functions
('SNT') work without delay, i.e. the effects of their input signals
can be observed in the same superstep. -}sample::SignalNodea->DTime->IOasample(SNKx)_=returnxsample(SNSx_)_=returnxsample(SNTsxf)dt=dot<-signalValuesdtreturn$!fdttxsample(SNAsfsx)dt=signalValuesfdt<*>signalValuesxdtsample(SNHssr)dt=dos<-signalValuessdtwriteIORefrssignalValuesdtsample(SNMbsm)dt=doc<-signalValuebdtSMm<-signalValuesmdtifcthenmelsereturnundefinedsample(SNEr)_=readIORefrsample(SNDv_)_=returnvsample(SNKAsl)dt=do_<-signalValueldtsignalValuesdtsample(SNF1fs)dt=f<$>signalValuesdtsample(SNF2fs1s2)dt=liftM2f(signalValues1dt)(signalValues2dt)sample(SNF3fs1s2s3)dt=liftM3f(signalValues1dt)(signalValues2dt)(signalValues3dt)sample(SNF4fs1s2s3s4)dt=liftM4f(signalValues1dt)(signalValues2dt)(signalValues3dt)(signalValues4dt)sample(SNF5fs1s2s3s4s5)dt=liftM5f(signalValues1dt)(signalValues2dt)(signalValues3dt)(signalValues4dt)(signalValues5dt){-| Sampling the signal with some kind of delay in order to resolve
dependency loops. Transfer functions simply return their previous
output (delays can be considered a special case, because they always
do that, so 'sampleDelayed' is never called with them), while other
types of signals are always handled by the 'sample' function, so it is
not possible to create a working stateful loop composed of solely
stateless combinators. -}sampleDelayed::SignalNodea->DTime->IOasampleDelayed(SNT_x_)_=returnxsampleDelayedsndt=samplesndt-- ** Userland combinators{-| Advancing the whole network that the given signal depends on by
the amount of time given in the second argument. -}superstep::Signala-- ^ the top-level signal->DTime-- ^ the amount of time to advance->IOa-- ^ the current value of the signalsuperstepworlddt=dosnapshot<-signalValueworlddtageworlddtcommitworldreturnsnapshot{-| A pure stateful signal. The initial state is the first output. -}stateful::a-- ^ initial state->(DTime->a->a)-- ^ state transformation->SignalMonad(Signala)statefulx0f=makeSignal(SNSx0f){-| A stateful transfer function. The current input affects the
current output, i.e. the initial state given in the first argument is
considered to appear before the first output, and can only be directly
observed by the `sampleDelayed` function. -}transfer::a-- ^ initial internal state->(DTime->t->a->a)-- ^ state updater function->Signalt-- ^ input signal->SignalMonad(Signala)transferx0fs=makeSignal(SNTsx0f){-| A continuous sampler that flattens a higher-order signal by
outputting its current snapshots. -}sampler::Signal(Signala)-- ^ signal to flatten->Signalasamplerss=makeSignalUnsafe(SNHss(unsafePerformIO(newIORefundefined))){-| A reactive signal that takes the value to output from a monad
carried by its input when a boolean control signal is true, otherwise
it outputs 'Nothing'. It is possible to create new signals in the
monad and also to print debug messages. -}generator::SignalBool-- ^ control (trigger) signal->Signal(SignalMonada)-- ^ a stream of monads to potentially run->Signal(Maybea)generatorbsm=toMaybe<$>b<*>makeSignalUnsafe(SNMbsm){-| A helper function to wrap any value in a 'Maybe' depending on a
boolean condition. -}toMaybe::Bool->a->MaybeatoMaybecv=ifcthenJustvelseNothing{-| A signal that can be directly fed through the sink function
returned. This can be used to attach the network to the outer
world. -}external::a-- ^ initial value->IO(Signala,Sinka)-- ^ the signal and an IO function to feed itexternalx0=doref<-newIORefx0snr<-newIORef(Ready(SNEref))return(Ssnr,writeIORefref){-| The `delay` transfer function emits the value of a signal from the
previous superstep, starting with the filler value given in the first
argument. It has to be a primitive, otherwise it could not be used to
prevent automatic delays. -}delay::a-- ^ initial output->Signala-- ^ the signal to delay->SignalMonad(Signala)delayx0s=makeSignal(SNDx0s){-| Dependency injection to allow aging signals whose output is not
necessarily needed to produce the current sample of the first
argument. It's equivalent to @(flip . liftA2 . flip) const@, as it
evaluates its second argument first. -}keepAlive::Signala-- ^ the actual output->Signalt-- ^ a signal guaranteed to age when this one is sampled->SignalakeepAlivesl=makeSignalUnsafe(SNKAsl)