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

module FRP.Reactivity.Basic (start, ticks, nil, defaultFrame, Act(Action), liftE, liftE', liftS, allOccs, delayedFixA, fixA, corecA, ex, ex2, timeMeasure, nominalTimes, 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 FRP.Reactivity.Combinators
import System.Win32
import Graphics.Win32
import Graphics.Win32Extras
import System.IO
import System.Mem

start :: POSIXTime
start = startT defaultFrame

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

nil = Stream (const (return ())) (\_ _ -> 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
		let e' = getEvent stream
		return $ fmap (\(m, t) -> m >>= maybe (return ()) ((>>= \x -> addToEventWithTime stream x t) . unAction . f) >> return Nothing) (withTime ev)
			<> join e'
	{-# INLINE[0] (>>) #-}
	m >> m2 = m >>= const m2
	fail _ = Action $ return mempty

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

-- | Lift pure events.
liftE' :: Event t -> Act t
liftE' ev = liftE (fmap return 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, t) -> m >>= \x -> addToEventWithTime stream x t >> return Nothing) (withTime ev)

-- | Return all return values of the parameter 'a' in a single event. The single event is returned
--   immediately.
allOccs :: Act t -> Act (Event t)
allOccs a = do
	e' <- liftIO (chanSource defaultFrame)
	(nominalTimes a >>= \(x, t) -> liftIO (addToEventWithTime e' x t) >> mzero) <> return (getEvent e')

-- | Constructs a delayed fixpoint of the given signal function; actions influence
--   occurrences strictly later in the event stream.

--  Diagram:
--
--    o   o   o   o
--     \   \   \
--  (   \   \   \   )
--       V   V   V
--    o   o   o   o
--
--          ||
--          ||
--          \/
--    
--    o   o   o   o
delayedFixA :: (Event t -> Act t) -> Act t
delayedFixA f = do
	s <- liftIO $ chanSource defaultFrame
	e' <- liftIO $ unAction $ f $ getEvent s
	(m, t) <- liftE' $ withTime e'
	my <- liftIO m
	x <- maybe mzero return my
	liftIO $ addToEventWithTime s x t
	return x

corecA_ f x e = do
	((y, t), rest) <- liftE' (once (withRest e))
	(x', z, t2) <- liftIO $ f x y t
	Action $ liftM (cons (return (Just z)) t2) $ unAction $ corecA_ f x rest

-- | An effectful version of 'corec'.
{-# NOINLINE corecA #-}
corecA f x = corecA_ f x . withTime

-- | Constructs a looping fixpoint of the given signal function; actions influence
--   occurrences simultaneously or later in the event stream.

--   Diagram:
--
--    o   o   o   o
--    |   |   |   |
--  ( |   |   |   | )
--    V   V   V   V
--    o   o   o   o
--
--          ||
--          ||
--          \/
--    
--    o   o   o   o
fixA :: (Event t -> Act t) -> Act t
fixA f = do
	s <- liftIO $ chanSource defaultFrame
	mv <- liftIO newEmptyMVar
	liftIO $ unsafeInterleaveIO (takeMVar mv) >>= addToEvent s
	e' <- liftIO $ unAction $ f $ getEvent s
	m <- liftE' e'
	x <- liftIO m
	y <- maybe mzero return x
	liftIO $ putMVar mv y
	liftIO $ unsafeInterleaveIO (takeMVar mv) >>= addToEvent s
	return y

ex :: Act Double
ex = corecA (\x _ t -> print x >> return (succ x, succ x, t)) 0 (tick 1)

ex2 :: Act ()
ex2 = delayedFixA (\e -> return () <> liftE' (fmap (const ()) $ delayE 5 e)) >>= liftIO . print

-- A specialized version of the foregoing where only the first occurrence is fed in.
instance MonadFix Act where
	{-# INLINE mfix #-}
	mfix f = fixA (\e -> liftE' (once e) >>= f)

-- | This functional gives a measurement of the current time (as measured from the start
--   of execution). This measurement is subject to additional measurement error.
timeMeasure :: IO Time
timeMeasure = do
	t1 <- getPOSIXTime
	return (fromRational (toRational (t1 - startT defaultFrame)))

-- | Obtains the time at which the parameter action has scheduled each event occurrence.
nominalTimes :: Act t -> Act (t, Time)
nominalTimes (Action m) = Action (liftM (\e -> fmap (\(m, t) -> fmap (fmap $ \x -> (x, t)) m) $ withTime e) m)

{-# 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)
  #-}

-- | This is the only way to run a computation in the 'Act' monad.
--
--   Care and feeding:
--
--     * Programs work better when compiled, compiled with -threaded,
--       and run with +RTS -Nn (n = number of capabilities).
--
--     * UI operations are bound to the same thread as the message loop.
--
--     * 'run' uses global state; it cannot work on multiple threads.
{-# INLINE run #-}
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
	mv <- newEmptyMVar
	let e = fmap (putMVar mv . void) ev
	setupFrame defaultFrame e
	forkIO $ runFrame defaultFrame

	-- Pump messages
	allocaMessage $ \msg -> do
		whileM_
			(return True)
			(-- Dispatch an action
			do
			my <- tryTakeMVar mv
			maybe (return ()) id 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