Ticket #3964: SF.hs

{-# LANGUAGE Arrows #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ViewPatterns #-}
import Control.Arrow
import Data.Dynamic
import Data.Map (Map)
import Data.Unique
import System.Mem.Weak

type RunSF a = a Dynamic ()
data Any = forall a. Any a

data StaticEnviroment a = StaticEnviroment { _runSF :: RunSF a }
data Enviroment a = Enviroment { _payload :: Dynamic }
data State a = State { _dSignals :: Map Unique (Weak Any) }

-- | Signal transformer
data SF a b c =
   SF (StaticEnviroment a -> a (b, State a, Enviroment a) (c, State a, SF a b c))

data DSignal a b where
    DSignal :: Typeable c => (a c () -> a () d) -> (c -> b) -> Unique -> DSignal a b

data Event a = Event Unique a deriving Typeable

isOn :: ArrowChoice a => DSignal a c -> SF a b (Maybe c)
isOn (DSignal _ f u) = let sf = SF $! \_ -> proc (_, s, e) -> 
                             case fromDynamic (_payload e) of
                                 Just (Event ((== u) -> True) v) ->
                                     returnA -< (Just (f v), s, sf)
                                 Nothing -> returnA -< (Nothing, s, sf)
                       in sf