sebastiaanvisser/gist:9639321

## gistfile1.hs
-- | Echo: a small experimental library for functional reactive programming.

{-# LANGUAGE
    GADTs
  , GeneralizedNewtypeDeriving
  , TemplateHaskell
  , RecursiveDo
  , MagicHash
  , UnboxedTuples
  #-}
module Reactive.Echo
(
-- * Reactive variables.

  R
, new
, get
, set
, modify
, update
, effect

-- * Reactive event networks.

, E

-- * Primitive event combinators.

, use
, accum
, sift

-- * Useful derived combinators.

, predicate
, distinct
, history

-- * Linking and unlinking networks.

, link
, unlink
, var
)
where

import Control.Applicative hiding (optional)
import Control.Concurrent.STM
import Control.Monad (MonadPlus (..), when, join)
import Data.Foldable (sequence_, mapM_, forM_)
import Data.Label (fclabels)
import Data.Monoid
import Data.Traversable (mapM)
import GHC.Base
import GHC.Conc.Sync (TVar (..))
import Prelude hiding (init, sequence_, mapM, mapM_)

import qualified Data.Label as L

fclabels [d|

  data Box a = Box
    { reactors :: [(Int, STM [IO ()])]
    , effects  :: [(Int, a -> IO ())]
    , linked   :: [STM ()]
    , busy     :: Bool
    , value    :: a
    }

  |]

-- | A reactive variable contains a value that might change over time. A
-- reactive variable will always have a value and cannot be uninitialized.

newtype R a = R_ { unR :: TVar (Box a) }

-------------------------------------------------------------------------------

-- | Create a new reactive variable with an initial value. When the variable
-- gets garbage collected it will automatically unlink (if linked). So no
-- dangling variables will live in the reactive network.

new :: a -> IO (R a)
new a =
  do ref <- newTVarIO (Box [] [] [] False a)
     let v = R_ ref
     v <$ final ref (unlink v)
   where final (TVar r#) f = IO $ \s ->
           case mkWeak# r# () f s
             of (# s1, _ #) -> (# s1, () #)

-- | Snapshot the current value from a reactive variable.

get :: R a -> IO a
get r = L.get value <$> readTVarIO (unR r)

-- | Put a new value in a reactive variable.

set :: R a -> a -> IO ()
set r v = modify r (const v)

-- | Modify the value in a reactive variable.

modify :: R a -> (a -> a) -> IO ()
modify r f = update r (Just . f)

-- | Optionally update the value in a reactive variable.

update :: R a -> (a -> Maybe a) -> IO ()
update r f = atomically (dispatch r f) >>= sequence_

-------------------------------------------------------------------------------

-- | Dispatch a possible value change on a reactive variable. All listeners
-- will be notified and this way the event can propagate through the network.
-- The dispatch function set the busy flag to prevent needless oscillation.

dispatch :: R a -> (a -> Maybe a) -> STM [IO ()]
dispatch r f =

  do box <- readTVar (unR r)
     case (f (L.get value box), L.get busy box) of -- Too strict?
       (Just v, False) ->
         do -- With updated value.
            let withv = L.set value v box
            writeTVar (unR r) $! L.set busy True withv

            -- Dispatch the value to our listeners and collect a list of side
            -- effects to run afterwards.
            efx <- concat <$> mapM snd (L.get reactors box)
            writeTVar (unR r) $! L.set busy False withv

            -- Collect our own side effects.
            let ofx = (\m -> snd m v) <$> L.get effects box

            -- Return the total list of side effects.
            return (efx ++ ofx)
       _ -> return []

-- | Install a listener that will be notified when the reactive variable
-- triggers an event. The listener is a STM transaction that can return a list
-- of side effects that need to run after the transaction finishes. The
-- listener doesn't get the old or new value specified. It the values are need
-- the listener should snapshot the value itself.

listen :: R a -> STM [IO ()] -> STM (STM ())
listen r h =

  do -- Update list of reactors.
     i <- do box <- readTVar (unR r)
             let i = case L.get reactors box
                       of []       -> 0
                          (n, _):_ -> n + 1
             writeTVar (unR r) $!
               L.modify reactors ((i, h):) box
             return i

     -- Return cleanup function.
     return $
       do box <- readTVar (unR r)
          let del = filter ((/= i) . fst)
          writeTVar (unR r) $!
            L.modify reactors del box

-- | Install an IO handler that will be executed whenever the reactors variable
-- triggers an event. The handler will run after the event transaction
-- finishes.

effect :: Bool -> R a -> (a -> IO ()) -> IO (IO ())
effect initialize r f =

  do -- Update list of side effects.
     (n, i) <- atomically $
        do box <- readTVar (unR r)
           let i = case L.get effects box
                     of []       -> 0
                        (n, _):_ -> n + 1
           writeTVar (unR r) $!
               L.modify effects ((i, f):) box
           return (L.get value box, i)

     -- Call reactor now when requested.
     when initialize (f n)

     -- Return cleanup function.
     return $ atomically $
       do box <- readTVar (unR r)
          let ft = filter ((/= i) . fst)
          writeTVar (unR r) $!
            L.modify effects ft box

-------------------------------------------------------------------------------

-- | An event network is a way of transforming, combining and filtering events
-- from reactive variables. A value of type `E` is just a description of such a
-- network and won't have any effect until linking it to some output variable
-- (see `link`).

data E a where
  Boxed   :: R a                       -> E a
  Filter  :: E (Maybe a)               -> E a
  Pure    :: a                         -> E a
  Map     ::   (a -> b) -> E a         -> E b
  Apply   :: E (a -> b) -> E a         -> E b
  Join    :: E (E a)                   -> E a
  Empty   ::                              E a
  Combine :: E a -> E a                -> E a
  Accum   :: (b -> a -> a) -> a -> E b -> E a

instance Functor E where
  fmap = Map

instance Applicative E where
  pure  = Pure
  (<*>) = Apply

instance Monad E where
  return  = Pure
  a >>= b = Join (Map b a)

instance Alternative E where
  empty = Empty
  (<|>) = Combine

instance MonadPlus E where
  mzero = Empty
  mplus = Combine

instance Monoid a => Monoid (E a) where
  mempty  = pure mempty
  mappend = liftA2 mappend

-------------------------------------------------------------------------------

-- | Embed a reactive variable in an event network.

use :: R a -> E a
use = Boxed

-- | Accumulate a value by applying a function every time an event occurs.
-- Accumulation starts the moment the network is linked.

accum :: (a -> b -> b) -> b -> E a -> E b
accum = Accum

-- | Only pass on events that aren't `Nothing`.

sift :: E (Maybe a) -> E a
sift = Filter

-- | Filter events based on a value predicate.

predicate :: (a -> Bool) -> E a -> E a
predicate p = sift . fmap (\a -> if p a then Just a else Nothing)

-- | Accumulate historical values. A specified maximum number of items will be
-- collected to prevent space leaks.

history :: Int -> E a -> E [a]
history n e = drop 1 <$> accum (\a b -> take (n + 1) (a : b)) [] e

-- | Only pass on events that change the value when compared with the last
-- event.

distinct :: Eq a => E a -> E a
distinct = sift . fmap f . accum (\a b -> take 2 (a:b)) []
  where f (a:b:_) | a == b = Nothing
        f (a:_)            = Just a
        f []               = Nothing

-- | Unlink a reactive variable. The reactive variable will not be connected
-- anymore to an event network. This function is a no-op when not previously
-- linked.

unlink :: R a -> IO ()
unlink = atomically . unlinkR

-- | Link an event network to a reactive variable. From now on events triggered
-- in the event network (triggered by input variables created with `use`) will
-- propagate to the reactive variable. When the variable is already linked this
-- function is a no-op.

link :: R a -> E a -> IO ()
link ref e = atomically (linkR ref e) >>= sequence_

-- | Create a reactive value and link it to an event network. Note that we need
-- to specify a default value to use when event filtering prevents use from
-- proper initialization.

var :: a -> E a -> IO (R a)
var a e =
  do r <- new a
     r <$ link r e

-------------------------------------------------------------------------------

-- | Unlink a previously linked reactive variable. When the variable isn't
-- linked yet this function is a no-op.

unlinkR :: R t -> STM ()
unlinkR r =
  do box <- readTVar (unR r)
     writeTVar (unR r) $! L.set linked [] box
     sequence_ (L.get linked box)

-- | Link an event network to the reactive variable. When one of the input
-- variables for the network triggers and event the output variable will be
-- updated accordingly. When the variable is already linked this function is a
-- no-op. Because an initialization dispatch will take place this function
-- returns a list of side effects that must be run after the transaction
-- finishes.

linkR :: R a -> E a -> STM [IO ()]
linkR r e =
  do box <- readTVar (unR r)
     case L.get linked box of
       [] -> do rec let disp = snap >>= dispatch r . const
                    (snap, un) <- install e (return . Just) disp
                writeTVar (unR r) $! (L.set linked un box)
                disp
       _ -> return []

-- | Install an event network. Return a transaction that can be used to
-- snapshot the result value, together with a list of cleanup functions that
-- can be used to uninstall the entire network. As input we take accumulated
-- function that will transform the snapshot value into the right form and a
-- function to dispatch changes in the variables that depend on this network.

install :: E a -> (a -> STM (Maybe b)) -> STM [IO ()] -> STM (STM (Maybe b), [STM ()])
install ev acc disp =

  case ev of

    Boxed b     -> do let snap = acc =<< L.get value <$> readTVar (unR b)
                      un <- listen b disp
                      return (snap, [un])

    Filter e    -> do install e (liftA join . mapM acc) disp

    Pure  v     -> do return (acc v, [])

    Map f e     -> do install e (acc . f) disp

    Apply f a   -> do (fs, unf) <- install f (return . Just) disp
                      (as, una) <- install a
                        (\b -> fs >>= liftA join . mapM (\g -> acc (g b)))
                        disp
                      return (as, unf ++ una)

    Join o      -> do rec (snapo, uno) <- install o (return . Just) $
                            do uni
                               snapo >>=
                                 mapM_ (\j -> (writeTVar ref $!) . Just =<< install j acc disp)
                               disp
                          i <- snapo
                          ref <- newTVar Nothing
                          forM_ i (\j -> (writeTVar ref $!) . Just =<< install j acc disp)
                          let uni = readTVar ref >>= sequence_ . maybe [] snd
                      return ( join (maybe (return Nothing) fst <$> readTVar ref)
                             , [uni] ++ uno
                             )

    Empty       -> do return (return Nothing, [])

    Combine a b -> do sw <- newTVar True
                      (snapa, una) <- install a (return . Just) (writeTVar sw True  >> disp)
                      (snapb, unb) <- install b (return . Just) (writeTVar sw False >> disp)
                      return ( do v <- readTVar sw
                                  w <- if v then snapa else snapb
                                  liftA join (mapM acc w)
                             , una ++ unb
                             )

    Accum f d e -> do cache <- newTVar d
                      rec (snap, un) <- install e (return . Just) $
                            do o <- readTVar cache
                               snap >>= mapM_ (\n -> writeTVar cache $! f n o)
                               disp
                      snap >>= mapM_ (\n -> writeTVar cache $! f n d)
                      return ( acc =<< readTVar cache
                             , un
                             )
	-- \| Echo: a small experimental library for functional reactive programming.

	{-# LANGUAGE
	GADTs
	, GeneralizedNewtypeDeriving
	, TemplateHaskell
	, RecursiveDo
	, MagicHash
	, UnboxedTuples
	#-}
	module Reactive.Echo
	(
	-- * Reactive variables.

	R
	, new
	, get
	, set
	, modify
	, update
	, effect

	-- * Reactive event networks.

	, E

	-- * Primitive event combinators.

	, use
	, accum
	, sift

	-- * Useful derived combinators.

	, predicate
	, distinct
	, history

	-- * Linking and unlinking networks.

	, link
	, unlink
	, var
	)
	where

	import Control.Applicative hiding (optional)
	import Control.Concurrent.STM
	import Control.Monad (MonadPlus (..), when, join)
	import Data.Foldable (sequence_, mapM_, forM_)
	import Data.Label (fclabels)
	import Data.Monoid
	import Data.Traversable (mapM)
	import GHC.Base
	import GHC.Conc.Sync (TVar (..))
	import Prelude hiding (init, sequence_, mapM, mapM_)

	import qualified Data.Label as L

	fclabels [d\|

	data Box a = Box
	{ reactors :: [(Int, STM [IO ()])]
	, effects :: [(Int, a -> IO ())]
	, linked :: [STM ()]
	, busy :: Bool
	, value :: a
	}

	\|]

	-- \| A reactive variable contains a value that might change over time. A
	-- reactive variable will always have a value and cannot be uninitialized.

	newtype R a = R_ { unR :: TVar (Box a) }

	-------------------------------------------------------------------------------

	-- \| Create a new reactive variable with an initial value. When the variable
	-- gets garbage collected it will automatically unlink (if linked). So no
	-- dangling variables will live in the reactive network.

	new :: a -> IO (R a)
	new a =
	do ref <- newTVarIO (Box [] [] [] False a)
	let v = R_ ref
	v <$ final ref (unlink v)
	where final (TVar r#) f = IO $ \s ->
	case mkWeak# r# () f s
	of (# s1, _ #) -> (# s1, () #)

	-- \| Snapshot the current value from a reactive variable.

	get :: R a -> IO a
	get r = L.get value <$> readTVarIO (unR r)

	-- \| Put a new value in a reactive variable.

	set :: R a -> a -> IO ()
	set r v = modify r (const v)

	-- \| Modify the value in a reactive variable.

	modify :: R a -> (a -> a) -> IO ()
	modify r f = update r (Just . f)

	-- \| Optionally update the value in a reactive variable.

	update :: R a -> (a -> Maybe a) -> IO ()
	update r f = atomically (dispatch r f) >>= sequence_

	-------------------------------------------------------------------------------

	-- \| Dispatch a possible value change on a reactive variable. All listeners
	-- will be notified and this way the event can propagate through the network.
	-- The dispatch function set the busy flag to prevent needless oscillation.

	dispatch :: R a -> (a -> Maybe a) -> STM [IO ()]
	dispatch r f =

	do box <- readTVar (unR r)
	case (f (L.get value box), L.get busy box) of -- Too strict?
	(Just v, False) ->
	do -- With updated value.
	let withv = L.set value v box
	writeTVar (unR r) $! L.set busy True withv

	-- Dispatch the value to our listeners and collect a list of side
	-- effects to run afterwards.
	efx <- concat <$> mapM snd (L.get reactors box)
	writeTVar (unR r) $! L.set busy False withv

	-- Collect our own side effects.
	let ofx = (\m -> snd m v) <$> L.get effects box

	-- Return the total list of side effects.
	return (efx ++ ofx)
	_ -> return []

	-- \| Install a listener that will be notified when the reactive variable
	-- triggers an event. The listener is a STM transaction that can return a list
	-- of side effects that need to run after the transaction finishes. The
	-- listener doesn't get the old or new value specified. It the values are need
	-- the listener should snapshot the value itself.

	listen :: R a -> STM [IO ()] -> STM (STM ())
	listen r h =

	do -- Update list of reactors.
	i <- do box <- readTVar (unR r)
	let i = case L.get reactors box
	of [] -> 0
	(n, _):_ -> n + 1
	writeTVar (unR r) $!
	L.modify reactors ((i, h):) box
	return i

	-- Return cleanup function.
	return $
	do box <- readTVar (unR r)
	let del = filter ((/= i) . fst)
	writeTVar (unR r) $!
	L.modify reactors del box

	-- \| Install an IO handler that will be executed whenever the reactors variable
	-- triggers an event. The handler will run after the event transaction
	-- finishes.

	effect :: Bool -> R a -> (a -> IO ()) -> IO (IO ())
	effect initialize r f =

	do -- Update list of side effects.
	(n, i) <- atomically $
	do box <- readTVar (unR r)
	let i = case L.get effects box
	of [] -> 0
	(n, _):_ -> n + 1
	writeTVar (unR r) $!
	L.modify effects ((i, f):) box
	return (L.get value box, i)

	-- Call reactor now when requested.
	when initialize (f n)

	-- Return cleanup function.
	return $ atomically $
	do box <- readTVar (unR r)
	let ft = filter ((/= i) . fst)
	writeTVar (unR r) $!
	L.modify effects ft box

	-------------------------------------------------------------------------------

	-- \| An event network is a way of transforming, combining and filtering events
	-- from reactive variables. A value of type `E` is just a description of such a
	-- network and won't have any effect until linking it to some output variable
	-- (see `link`).

	data E a where
	Boxed :: R a -> E a
	Filter :: E (Maybe a) -> E a
	Pure :: a -> E a
	Map :: (a -> b) -> E a -> E b
	Apply :: E (a -> b) -> E a -> E b
	Join :: E (E a) -> E a
	Empty :: E a
	Combine :: E a -> E a -> E a
	Accum :: (b -> a -> a) -> a -> E b -> E a

	instance Functor E where
	fmap = Map

	instance Applicative E where
	pure = Pure
	(<*>) = Apply

	instance Monad E where
	return = Pure
	a >>= b = Join (Map b a)

	instance Alternative E where
	empty = Empty
	(<\|>) = Combine

	instance MonadPlus E where
	mzero = Empty
	mplus = Combine

	instance Monoid a => Monoid (E a) where
	mempty = pure mempty
	mappend = liftA2 mappend

	-------------------------------------------------------------------------------

	-- \| Embed a reactive variable in an event network.

	use :: R a -> E a
	use = Boxed

	-- \| Accumulate a value by applying a function every time an event occurs.
	-- Accumulation starts the moment the network is linked.

	accum :: (a -> b -> b) -> b -> E a -> E b
	accum = Accum

	-- \| Only pass on events that aren't `Nothing`.

	sift :: E (Maybe a) -> E a
	sift = Filter

	-- \| Filter events based on a value predicate.

	predicate :: (a -> Bool) -> E a -> E a
	predicate p = sift . fmap (\a -> if p a then Just a else Nothing)

	-- \| Accumulate historical values. A specified maximum number of items will be
	-- collected to prevent space leaks.

	history :: Int -> E a -> E [a]
	history n e = drop 1 <$> accum (\a b -> take (n + 1) (a : b)) [] e

	-- \| Only pass on events that change the value when compared with the last
	-- event.

	distinct :: Eq a => E a -> E a
	distinct = sift . fmap f . accum (\a b -> take 2 (a:b)) []
	where f (a:b:_) \| a == b = Nothing
	f (a:_) = Just a
	f [] = Nothing

	-- \| Unlink a reactive variable. The reactive variable will not be connected
	-- anymore to an event network. This function is a no-op when not previously
	-- linked.

	unlink :: R a -> IO ()
	unlink = atomically . unlinkR

	-- \| Link an event network to a reactive variable. From now on events triggered
	-- in the event network (triggered by input variables created with `use`) will
	-- propagate to the reactive variable. When the variable is already linked this
	-- function is a no-op.

	link :: R a -> E a -> IO ()
	link ref e = atomically (linkR ref e) >>= sequence_

	-- \| Create a reactive value and link it to an event network. Note that we need
	-- to specify a default value to use when event filtering prevents use from
	-- proper initialization.

	var :: a -> E a -> IO (R a)
	var a e =
	do r <- new a
	r <$ link r e

	-------------------------------------------------------------------------------

	-- \| Unlink a previously linked reactive variable. When the variable isn't
	-- linked yet this function is a no-op.

	unlinkR :: R t -> STM ()
	unlinkR r =
	do box <- readTVar (unR r)
	writeTVar (unR r) $! L.set linked [] box
	sequence_ (L.get linked box)

	-- \| Link an event network to the reactive variable. When one of the input
	-- variables for the network triggers and event the output variable will be
	-- updated accordingly. When the variable is already linked this function is a
	-- no-op. Because an initialization dispatch will take place this function
	-- returns a list of side effects that must be run after the transaction
	-- finishes.

	linkR :: R a -> E a -> STM [IO ()]
	linkR r e =
	do box <- readTVar (unR r)
	case L.get linked box of
	[] -> do rec let disp = snap >>= dispatch r . const
	(snap, un) <- install e (return . Just) disp
	writeTVar (unR r) $! (L.set linked un box)
	disp
	_ -> return []

	-- \| Install an event network. Return a transaction that can be used to
	-- snapshot the result value, together with a list of cleanup functions that
	-- can be used to uninstall the entire network. As input we take accumulated
	-- function that will transform the snapshot value into the right form and a
	-- function to dispatch changes in the variables that depend on this network.

	install :: E a -> (a -> STM (Maybe b)) -> STM [IO ()] -> STM (STM (Maybe b), [STM ()])
	install ev acc disp =

	case ev of

	Boxed b -> do let snap = acc =<< L.get value <$> readTVar (unR b)
	un <- listen b disp
	return (snap, [un])

	Filter e -> do install e (liftA join . mapM acc) disp

	Pure v -> do return (acc v, [])

	Map f e -> do install e (acc . f) disp

	Apply f a -> do (fs, unf) <- install f (return . Just) disp
	(as, una) <- install a
	(\b -> fs >>= liftA join . mapM (\g -> acc (g b)))
	disp
	return (as, unf ++ una)

	Join o -> do rec (snapo, uno) <- install o (return . Just) $
	do uni
	snapo >>=
	mapM_ (\j -> (writeTVar ref $!) . Just =<< install j acc disp)
	disp
	i <- snapo
	ref <- newTVar Nothing
	forM_ i (\j -> (writeTVar ref $!) . Just =<< install j acc disp)
	let uni = readTVar ref >>= sequence_ . maybe [] snd
	return ( join (maybe (return Nothing) fst <$> readTVar ref)
	, [uni] ++ uno
	)

	Empty -> do return (return Nothing, [])

	Combine a b -> do sw <- newTVar True
	(snapa, una) <- install a (return . Just) (writeTVar sw True >> disp)
	(snapb, unb) <- install b (return . Just) (writeTVar sw False >> disp)
	return ( do v <- readTVar sw
	w <- if v then snapa else snapb
	liftA join (mapM acc w)
	, una ++ unb
	)

	Accum f d e -> do cache <- newTVar d
	rec (snap, un) <- install e (return . Just) $
	do o <- readTVar cache
	snap >>= mapM_ (\n -> writeTVar cache $! f n o)
	disp
	snap >>= mapM_ (\n -> writeTVar cache $! f n d)
	return ( acc =<< readTVar cache
	, un
	)