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

module FRP.Reactivity.Hook (Resource(..), toBeh, 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 -> r{-resource-}, x -> x{-output-}) 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 :: (Resource r (Behavior Appearance)) => WndClass -> r -> Hook r (Event Message) Act t -> Hook r (Event Message) Act t
hCreate wndclass r hook = do
	parent <- window
	rf <- getResource
	f <- getFilter
	w <- lift $ create parent wndclass (\w -> toBeh w (rf r))
	tellReturn (return w)
	(x, y) <- lift $ runReaderT (runWriterT (unHook hook)) (w { event = f (event w) }, rf, 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

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

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

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

{-# 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, id, id)

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

toBeh :: (Resource r (Behavior Appearance)) => HWND -> r -> Behavior Appearance
toBeh = convert

-- | These are common ways of converting data to a behavior.
class Resource r s where
	convert :: HWND -> r -> s

instance Resource t t where
	convert _ = id

instance Resource (Event Appearance) (Behavior Appearance) where
	convert _ = stepper err

instance Resource (Event Appearance) (Appearance, Event (Appearance -> Appearance)) where
	convert _ e = (err, fmap const e)

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

instance Resource (Event (Appearance -> Appearance)) (Behavior Appearance) where
	convert w e = convert w (err :: Appearance, e)

instance Resource (String, Event (String -> String)) (Appearance, Event (Appearance -> Appearance)) where
	convert _ (s, e) = (Appearance (return ()) s (0, 0, 0, 0), fmap (\f a -> a { text = f (text a) }) e)

instance Resource (Event String) (String, Event (String -> String)) where
	convert _ e = (err, fmap const e)

instance Resource (Event String) (Appearance, Event (Appearance -> Appearance)) where
	convert _ e = (err, fmap (\x _ -> Appearance (return ()) x (0, 0, 0, 0)) e)

instance Resource (Event String) (Behavior Appearance) where
	convert _ e = stepper err (fmap (\s -> Appearance (return ()) s (0, 0, 0, 0)) e)

instance Resource Appearance (Behavior Appearance) where
	convert _ = pure

instance Resource Appearance (Event Appearance) where
	convert _ = pure

instance Resource Appearance (Appearance, Event (Appearance -> Appearance)) where
	convert _ a = (a, mempty)

instance Resource (Draw ()) Appearance where
	convert _ d = Appearance d "" (0, 0, 0, 0)

instance Resource (Draw ()) (Behavior Appearance) where
	convert _ d = pure (Appearance d "" (0, 0, 0, 0))

instance Resource (Draw ()) (Event Appearance) where
	convert _ d = pure (Appearance d "" (0, 0, 0, 0))

instance Resource (Draw ()) (Appearance, Event (Appearance -> Appearance)) where
	convert _ d = (Appearance d "" (0, 0, 0, 0), mempty)

instance Resource BMP Appearance where
	convert _ b = Appearance (mask 1 (0, 0) b) "" (0, 0, 0, 0)

instance Resource BMP (Behavior Appearance) where
	convert w = convert w . mask 1 (0, 0)

instance Resource BMP (Event Appearance) where
	convert _ b = pure (Appearance (mask 1 (0, 0) b) "" (0, 0, 0, 0))

instance Resource BMP (Appearance, Event (Appearance -> Appearance)) where
	convert _ b = (Appearance (mask 1 (0, 0) b) "" (0, 0, 0, 0), mempty)

instance Resource BMP (BMP, Event (BMP -> BMP)) where
	convert _ b = (b, mempty)

instance Resource String Appearance where
	convert _ s = Appearance (return ()) s (0, 0, 0, 0)

instance Resource String (Behavior Appearance) where
	convert _ s = pure (Appearance (return ()) s (0, 0, 0, 0))

instance Resource String (Event Appearance) where
	convert _ s = pure (Appearance (return ()) s (0, 0, 0, 0))

instance Resource String (Appearance, Event (Appearance -> Appearance)) where
	convert _ s = (Appearance (return ()) s (0, 0, 0, 0), mempty)

instance Resource String (String, Event (String -> String)) where
	convert _ s = (s, mempty)

instance (Resource t u) => Resource (HWND -> t) u where
	convert w x = convert w (x w)

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 = (>>)