module FRP.Grapefruit.Signal.Continuous (
CSignal,
fromSSignal,
producer
) where
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
import Data.Unique as Unique
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
import Internal.Circuit as Circuit
data CSignal era val = CSignal (Capsule val) !(SSignal era (CSeg val))
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)
fromSSignal :: SSignal era val -> CSignal era val
fromSSignal signal@(SSignal init _) = CSignal (pure init) (fmap pure signal)
producer :: IO val -> Producer CSignal val
producer readVal = Producer $
proc _ -> do
seg <- CSeg.producer readVal -< ()
startTimeID <- getStartTimeID -< ()
returnA -< CSignal (currentValCapsule startTimeID seg) (pure seg)