Echo: A small FRP library.

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
                             )