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.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 Data.Maybe
import System.IO.Unsafe
import System.Mem
import FRP.Reactivity.Combinators
import System.Win32
import Graphics.Win32
import Graphics.Win32Extras
import System.IO

start :: POSIXTime
start = startT defaultFrame

{-# NOINLINE ticks #-}
ticks :: Stream Time
ticks = Stream (const (return ())) (tick 0.1)

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
	{-# INLINE return #-}
	return = liftIO . return
	{-# INLINE (>>=) #-}
	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)
	{-# INLINE[0] (>>) #-}
	m >> m2 = m >>= const m2
	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

{-# RULES
"liftIO/liftIO" forall m m2. liftIO m >> liftIO m2 = liftIO (m >> m2)
"liftE/liftIO" forall e m. liftE e >> liftIO m = liftE (fmap (>> m) e)
  #-}

run :: Act a -> IO b
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
	chn <- liftM Channel $ newIORef Nothing
	end <- newIORef chn
	ref <- newIORef chn
	setupFrame defaultFrame (fmap (chanWrite end) ev)
	thd <- forkIO (catch (runFrame defaultFrame) (\(ex :: SomeException) -> hPutStrLn stderr "Reactivity.Basic.run: Thread killed"))

	-- Pump messages
	allocaMessage $ \msg -> do
		whileM_
			(return True)
			(-- Dispatch an action
			do
			Channel ref' <- readIORef ref
			my <- readIORef ref'
			maybe (return ()) (\(m, chn') -> m >> writeIORef ref chn') my

			-- Process all messages in the queue.
			whileM_
				(liftM (/=0) $ c_PeekMessage msg nullPtr 0 0 pM_REMOVE)
				$ do
				translateMessage msg
				dispatchMessage msg

			when (isNothing my) yield
			-- and repeat.
			)

	return undefined