IO.hs

-- |
-- Module:     FRP.NetWire.IO
-- Copyright:  (c) 2011 Ertugrul Soeylemez
-- License:    BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
--
-- Access the rest of the universe.

module FRP.NetWire.IO
    ( -- * IO Actions
      execute,
      executeEvery,
      executeOnce
    )
    where

import Control.Exception.Control
import Control.Monad
import Control.Monad.IO.Control
import FRP.NetWire.Tools
import FRP.NetWire.Wire


-- | Execute the IO action in the input signal at every instant.
--
-- Note: If the action throws an exception, then this wire inhibits the
-- signal.

execute :: MonadControlIO m => Wire m (m a) a
execute =
    mkGen $ \_ c -> liftM (, execute) (try c)


-- | Executes the IO action in the right input signal periodically
-- keeping its most recent result value.

executeEvery :: forall a m. MonadControlIO m => Wire m (Time, m a) a
executeEvery = executeEvery' True 0 (Left (inhibitEx "No result yet."))
    where
    executeEvery' :: Bool -> Time -> Output a -> Wire m (Time, m a) a
    executeEvery' firstRun t' mx' =
        mkGen $ \(wsDTime -> dt) (int, c) ->
            let t = t' + dt in
            if t >= int || firstRun
              then do
                  let nextT = fmod t int
                  mx <- nextT `seq` try c
                  case mx of
                    Left _  -> return (mx', executeEvery' False nextT mx')
                    Right _ -> return (mx, executeEvery' False nextT mx)
              else return (mx', executeEvery' False t mx')


-- | Executes the IO action in the input signal and inhibits, until it
-- succeeds without an exception.  Keeps the result forever.

executeOnce :: MonadControlIO m => Wire m (m a) a
executeOnce =
    mkGen $ \_ c -> do
        mx <- try c
        return (mx, either (const executeOnce) constant mx)