Basic.hs

{-# LANGUAGE Trustworthy, DeriveDataTypeable, GeneralizedNewtypeDeriving, DeriveFunctor, ScopedTypeVariables, ForeignFunctionInterface #-}

module FRP.Reactivity.Basic (start, ticks, nil, defaultFrame, Act(Action), liftE, liftS, allOccs, corecA, run) where

import Control.Monad.Loops
import Control.Monad.IO.Class
import Control.Monad.Fix
import Control.Monad.Reader
import Control.Monad
import Control.Applicative
import Control.CUtils.FChan
import Control.Concurrent hiding (newChan)
import Control.Exception
import Control.Comonad
import Data.IORef
import Data.Monoid hiding (Any)
import Data.Typeable (Typeable)
import Data.Bits
import Data.Time.Clock.POSIX
import System.IO.Unsafe
import System.Mem
import FRP.Reactivity.Combinators
import System.Win32
import Graphics.Win32
import Graphics.Win32Extras

start :: POSIXTime
start = startT defaultFrame

{-# NOINLINE ticks #-}
ticks :: Stream ()
ticks = unsafePerformIO (chanSource defaultFrame)

nil = Stream (const (return ())) mzero

{-# NOINLINE defaultFrame #-}
defaultFrame = unsafePerformIO (makeFrame mzero)

-- | The Act type, comprising an initial I/O action and a sequence of scheduled actions.
newtype Act a = Action { unAction :: IO (Event (IO (Maybe a))) } deriving (Typeable, Functor)

instance Applicative Act where
	pure = return
	(<*>) = ap

-- The monad for Act continues with the actions expressed in 'f', for every tick in 'm'.
instance Monad Act where
	return = liftIO . return
	Action m >>= f = Action $ do
		ev <- m
		stream <- chanSource defaultFrame
		return $ fmap (\m -> m >>= maybe (return ()) ((>>= addToEvent stream) . unAction . f) >> return Nothing) ev
			<> join (getEvent stream)
	fail _ = Action $ return mempty

-- The Act monad has fixpoints.
instance MonadFix Act where
	mfix f = Action $ do
		mv <- newEmptyMVar
		x <- unsafeInterleaveIO $ readMVar mv
		ev <- unAction (f x)
		return $ fmap (\m -> m >>=
			maybe (return Nothing) (\x -> tryPutMVar mv x >> return (Just x))) ev

instance Monoid (Act a) where
	mempty = Action $ return mempty
	mappend m m2 = Action $ do
		ev <- unAction m
		ev2 <- unAction m2
		return (ev <> ev2)

instance Alternative Act where
	empty = mempty
	(<|>) = mappend

instance MonadPlus Act where
	mzero = mempty
	mplus = mappend

instance MonadIO Act where
	liftIO m = Action $ liftM (return . return . Just) m

-- | A basic event lifter -- continues at all event occurrences.
liftE :: Event (IO t) -> Act t
liftE ev = Action $ return $ fmap (fmap Just) ev

-- | A variant of 'liftE' which publishes occurrences under 'stream', and only continues once, immediately.
liftS :: Stream t -> Event (IO t) -> Act ()
liftS stream ev = Action $ return $ return (return (Just ())) <> fmap (\m -> m >>= addToEvent stream >> return Nothing) ev

-- | Return all return values of the parameter 'a' in a single event.
--
--   (The occurrences receive new timestamps, which may differ from the old.)
allOccs :: Act t -> Act (Event t)
allOccs a = do
	e' <- liftIO (chanSource defaultFrame)
	(a >>= liftIO . addToEvent e' >> mzero) <> return (getEvent e')

corecA' :: (t -> u -> Time -> IO (t, v, Time)) -> t -> Event (u, Time) -> Act v
corecA' f x e = do
	((y, t), rest) <- liftE (fmap return (once (withRest e)))
	(x, z, t) <- liftIO (f x y t)
	liftE (cons (return z) t mzero) <> corecA' f x rest

-- | An I/O version of 'corec'
corecA f x = corecA' f x . withTime

run :: Act a -> IO ()
run action = do
	-- Register window class
	hdl <- getModuleHandle Nothing
	cursor <- loadCursor Nothing iDC_ARROW
	null <- getStockBrush nULL_BRUSH
	let name = mkClassName "Frame"
	registerClass (0, hdl, Nothing, Just cursor, Just null, Nothing, name)

	-- Build and run the event stream
	ev <- unAction action
	(f, chn) <- newChan
	setupFrame defaultFrame (fmap f (withTime ev))
	forkIO (runFrame defaultFrame)

	-- Pump messages
	allocaMessage $ \msg -> do
	let m = do
		-- Process all messages in the queue.
		whileM_
			(liftM (/=0) $ c_PeekMessage msg nullPtr 0 0 pM_REMOVE)
			$ do
			translateMessage msg
			dispatchMessage msg

		-- Wait until either a message is received or the timeout elapses.
		res <- msgWaitForMultipleObjects [] True 200 qS_ALLEVENTS

		when (res == wAIT_TIMEOUT) $ addToEvent ticks ()

	foldM_ (\chn _ ->
		-- Process all available messages
		tryTakeChan chn >>= maybe
			(m >> return chn)
			(\((m, _), rest) -> m >> return rest)
		-- and repeat.
		)
		chn
		(repeat ())