Hook.hs

{-# LANGUAGE Unsafe, GeneralizedNewtypeDeriving, DeriveFunctor, FlexibleInstances, Rank2Types, FunctionalDependencies, OverlappingInstances, UndecidableInstances #-}

module FRP.Reactivity.Hook (Resource(..), Hook,
-- | * Versions of UI functions that can be modified by hooks.
hCreate, hCreate',
-- | * Hook readers
getFilter, window, getResource, tellReturn, getReturns, getReturns1,
-- | * Running
ty, runHook) where

import Foreign.Ptr
import Control.Applicative
import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.Trans
import Control.Monad
import Data.Monoid
import FRP.Reactivity.Combinators
import FRP.Reactivity.UI
import FRP.Reactivity.Draw
import Codec.BMP
import Graphics.Win32

newtype Hook r x m t = Hook { unHook :: WriterT (Event Window) (ReaderT (Window, r, x -> x) m) t } deriving (Monad, MonadPlus, MonadFix, Functor, Applicative, Alternative, MonadIO)

instance MonadTrans (Hook r x) where
	lift = Hook . lift . lift

instance (MonadPlus m) => Monoid (Hook r x m t) where
	mempty = mzero
	mappend = mplus

-- | Versions of UI functions that can be modified by hooks.
{-# INLINE hCreate #-}
hCreate :: (Monoid r, Resource r) => WndClass -> r -> Hook r (Event Message) Act t -> Hook r (Event Message) Act t
hCreate wndclass r hook = do
	parent <- window
	r2 <- getResource
	f <- getFilter
	w <- lift $ create parent wndclass (toBeh (r2 <> r))
	tellReturn (return w)
	(x, y) <- lift $ runReaderT (runWriterT (unHook hook)) (w { event = f (event w) }, r2, f)
	tellReturn y
	return x

{-# INLINE hCreate' #-}
hCreate' wndclass r = hCreate wndclass r window

-- | Filters are hooks modifying the event stream the caller sees.
{-# INLINE getFilter #-}
getFilter :: (Monad m) => Hook r x m (x -> x)
getFilter = Hook $ liftM (\(_, _, f) -> f) $ lift ask

-- | Resources are a way of augmenting the behaviors used by subsequent controls.
{-# INLINE getResource #-}
getResource :: (Monad m) => Hook r x m r
getResource = Hook $ liftM (\(_, r, _) -> r) $ lift ask

{-# INLINE tellReturn #-}
tellReturn r = Hook $ tell r

{-# INLINE getReturns #-}
getReturns :: (Monoid r, Monad m) => r -> (x -> x) -> Hook r x m t -> Hook r x m (t, Event Window)
getReturns r f h = do
	w <- window
	r2 <- getResource
	f2 <- getFilter
	lift $ runReaderT (runWriterT (unHook h)) (w, r <> r2, f . f2)

{-# INLINE getReturns1 #-}
getReturns1 r f h = do
	w <- window
	lift $ runReaderT (runWriterT (unHook h)) (w, r, f)

-- | 'window' gives the identity of the parent window.
{-# INLINE window #-}
window :: (Monad m) => Hook r x m Window
window = Hook $ liftM (\(w, _, _) -> w) $ lift ask

-- | Functional that fixes the usual type parameters.
{-# INLINE ty #-}
ty :: Hook (Behavior Appearance) (Event Message) Act t -> Hook (Behavior Appearance) (Event Message) Act t
ty = id

-- | Runs a procedure in the Hook monad transformer.
{-# INLINE runHook #-}
runHook ~(Hook h) = runReaderT (runWriterT h) (desktop, mempty, id)

err = error "FRP.Hook.toBeh: no start value"

-- | These are common ways of converting data to a behavior.
class Resource r where
	toBeh :: r -> Behavior Appearance

instance Resource (Behavior Appearance) where
	toBeh = id

instance Resource (Event Appearance) where
	toBeh = stepper err

instance Resource (Appearance, Event (Appearance -> Appearance)) where
	toBeh (x, e) = stepper x $ corec (\x f t -> (f x, f x, t)) x e

instance Resource Appearance where
	toBeh = pure

instance Resource (Draw ()) where
	toBeh d = pure (Appearance d "" (0, 0, 0, 0))

instance Resource BMP where
	toBeh = toBeh . mask 1 (0, 0)

instance Resource String where
	toBeh s = pure (Appearance (return ()) s (0, 0, 0, 0))

instance Monoid BMP where
	mempty = newBitmap (0, 0)
	mappend b b2 = fst $ onNewBitmap (wid `max` wid2, ht + ht2) $ do
		mask 1 (0, 0) b
		mask 1 (0, ht) b2 where
		(wid, ht) = askDims' b
		(wid2, ht2) = askDims' b2

instance Monoid Appearance where
	mempty = Appearance (return ()) "" (0, 0, 0, 0)
	mappend a a2 = Appearance (draw a >> draw a2)
		(text a ++ text a2)
		(x1 `max` x3, y1 `max` y3, x2 `max` x4, y2 `max` y4) where
		(x1, y1, x2, y2) = rect a
		(x3, y3, x4, y4) = rect a2

instance Monoid (Draw ()) where
	mempty = return ()
	mappend = (>>)