UI.hs

{-# LANGUAGE Trustworthy, ScopedTypeVariables, DeriveDataTypeable #-}

module FRP.Reactivity.UI (Btn(..), MouseEv(..), Message(..), Appearance(..), WndClass, isMouse, isKey, isChange, isMove, onMouse, onKey, onMove, Window(..), hwnd, event, desktop, dim, shift, inside, intersectRect, regulate, suspendUpdate, unsuspendUpdate, create, position, texts, mousePos, module FRP.Reactivity.Basic) where

import Data.XSizeable
import FRP.Reactivity.Combinators
import FRP.Reactivity.Basic
import FRP.Reactivity.Draw
import Data.IORef
import Data.Typeable
import Data.Monoid
import Data.Int
import Data.Bits hiding (shift)
import Data.Array.MArray
import qualified Data.Map as M
import Data.Char
import Foreign.Storable
import Foreign.Ptr
import Foreign.C.Types
import System.IO.Unsafe
import Unsafe.Coerce
import Graphics.Win32 hiding (fillRect)
import System.Win32
import Graphics.Win32Extras
import Graphics.Subclass
import Control.Monad
import Control.Monad.Loops
import Control.Monad.Reader
import Control.Exception hiding (mask)
import Codec.BMP
import Prelude hiding (until)

import Data.Char

data Btn = L | R deriving (Eq, Show, Typeable)

data MouseEv = Down | Up | Dbl | Mv deriving (Eq, Show, Typeable)

data InternalMessage =
   IChange !String !HWND
 | IPush !HWND
 | IFocus !HWND
 | Destroy
 | Tick !HWND deriving (Eq, Show, Typeable)

data Message =
   Mouse !Btn !MouseEv !POINT
 | Key !Bool !VKey
 | Change !String
 | Push
 | Move !RECT
 | Close
 | Focus
 | Internal !InternalMessage deriving (Eq, Show, Typeable)

data Appearance = Appearance { draw :: !(Draw ()), text :: !String, rect :: !RECT } deriving Typeable

instance Show Appearance where
	showsPrec prec appr = showParen (prec == 11) $ ("Appearance _  "++)
		. showsPrec 11 (text appr)
		. (' ':)
		. showsPrec 11 (rect appr)

type WndClass = String

{-# INLINE isMouse #-}
isMouse (Mouse _ _ _) = True
isMouse _ = False

{-# INLINE isKey #-}
isKey (Key _ _) = True
isKey _ = False

{-# INLINE isChange #-}
isChange (Change _) = True
isChange _ = False

{-# INLINE isMove #-}
isMove (Move _) = True
isMove _ = False

{-# INLINE onMouse #-}
onMouse f ev = justE $ fmap (\m -> case m of Mouse b m p -> Just (f b m p); _ -> Nothing) ev

{-# INLINE onKey #-}
onKey f ev = justE $ fmap (\m -> case m of Key b n -> Just (f b n); _ -> Nothing) ev

{-# INLINE onMove #-}
onMove f ev = justE $ fmap (\m -> case m of Move rt -> Just (f rt); _ -> Nothing) ev

toWPARAM :: Ptr a -> WPARAM
toWPARAM = unsafeCoerce

toLPARAM :: Ptr a -> LPARAM
toLPARAM = unsafeCoerce

data Window = Window { hwnd :: !HWND, event :: Event Message } -- The type of windows.

-- | A window representing the desktop.
desktop = Window nullPtr mempty

-- | Dimensions of a rectangle.
dim (x1, y1, x2, y2) = (x2 - x1, y2 - y1)

-- | Shift a rectangle.
shift (x, y) (x1, y1, x2, y2) = (x1 + x, y1 + y, x2 + x, y2 + y)

-- | Membership test for rectangles.
inside (x1, y1, x2, y2) = inRange ((x1, y1), (x2, y2))

-- | Intersection of two rectangles.
intersectRect (x1, y1, x2, y2) (x1a, y1a, x2a, y2a) = (x1a `max` x1, y1a `max` y1, x2a `min` x2, y2a `min` y2)

{-# INLINE regulate #-}
-- | Under some circumstances, such as video playback, it can be undesirable to buffer
--   up many frames and play them back. In order to avoid time leaks, the program
--   can drop frames.
regulate :: Event t -> Act (Event t)
regulate e = liftM justE $ allOccs (corecA (\t1 x t -> do
	t1' <- getPOSIXTime
	if t < fromRational (toRational (t1 - start)) then
			return (t1', Just x, t)
		else
			return (t1, Nothing, t))
	0
	e)

{-# NOINLINE suspendedUpdateWindows #-}
suspendedUpdateWindows :: IORef (M.Map HWND ())
suspendedUpdateWindows = unsafePerformIO (newIORef M.empty)

-- | The "built-in suspending mechanism" prevents interference between the reactive behavior
--   of a window and user input to that window.
--   The behavior is as follows:
--     * When the user moves/drags a window, its position stops reflecting the position
--       in its reactive behavior.
--     * When the user enters text in a text box, its text stops reflecting the text
--       of the reactive behavior.
--     * When the user moves a scroll bar, its position stops reflecting that
--       of the reactive behavior.
--
--   'suspendUpdate' suspends the update of a window. Unlike the built-in mechanism
--   for suspending, this suspends drawing on the surface of the window as well.
suspendUpdate :: HWND -> IO ()
suspendUpdate hwnd = modifyIORef' suspendedUpdateWindows (M.insert hwnd ())

-- | Undoes any suspending of the window. This affects both 'suspendUpdate' and
--   the built-in suspending mechanism.
unsuspendUpdate :: HWND -> IO ()
unsuspendUpdate hwnd = modifyIORef' suspendedUpdateWindows (M.delete hwnd)

create :: Window -> WndClass -> Behavior Appearance -> Act Window
create (Window parent parentEv) cls beh = do
	ref <- liftIO $ newIORef $ Appearance (return ()) "" (0, 0, 0, 0)
	(wnd, ev) <- liftIO $ createWnd parent cls ref
	let ev' = return (Internal (Tick nullPtr)) <> if isFrame cls then
			ev
		else
			ev <> routeChildEvents wnd parentEv
	ev'' <- return (fmap (const Focus) (getEvent ticks) <> ev')
	let ups = updates cls beh ev''
	liftS nil $ fmap (\tup@((_, app), _) -> do -- Do updates
			writeIORef ref app
			update wnd cls tup)
		ups
	return (Window wnd ev') -- Return the event stream

{-# INLINE routeChildEvents #-}
routeChildEvents wnd = fmap (\msg -> case msg of
	Internal (IChange s hwnd) -> if wnd == hwnd then Change s else msg
	Internal (IPush hwnd) -> if wnd == hwnd then Push else msg
	Internal (IFocus hwnd) -> if wnd == hwnd then Focus else msg
	_ -> Internal (Tick nullPtr))

read' x = if all isDigit x then read x else unsafePerformIO (print x >> return 0)

isScrollBar cls = map toUpper cls `elem` ["SCROLLBAR", "HSCROLLBAR"]

update wnd cls ((msg, Appearance draw text (x, y, xx, yy)), suspend) = do
	mp <- readIORef suspendedUpdateWindows
	unless (M.member wnd mp) (catch (do
		let wid = xx - x
		let ht = yy - y
		-- Size the window
		(x1, y1, x2, y2) <- getWindowRect wnd
		unless (isMove msg) $ if isFrame cls then unless suspend $ do
				(_, _, clientWd, clientHt) <- getClientRect wnd
				unless (fromIntegral clientWd == wid && fromIntegral clientHt == ht) $
					setWindowPos wnd
						nullPtr
						(fromIntegral x1)
						(fromIntegral y1)
						(fromIntegral (x2 - x1 - clientWd) + fromIntegral wid)
						(fromIntegral (y2 - y1 - clientHt) + fromIntegral ht)
						sWP_NOZORDER
			else unless (x1 == fromIntegral x && y1 == fromIntegral y && x2 == fromIntegral xx && y2 == fromIntegral yy) $
				setWindowPos wnd
					nullPtr
					(fromIntegral x)
					(fromIntegral y)
					(fromIntegral wid)
					(fromIntegral ht)
					sWP_NOZORDER

		-- Set the text
		if isScrollBar cls then
			do
				let (mx, _:rest) = break (==',') text
				let (page, _:pos) = break (==',') rest
				old <- getScrollInfo wnd (fromIntegral sB_CTL)
				let mask = sIF_RANGE .|. sIF_POS .|. if suspend then 0 else sIF_POS
				let new = SCROLLINFO mask 0 (read' mx) (read' page) (read' pos) 0
				unless (old { fMask = mask } == new) $ void $ setScrollInfo wnd (fromIntegral sB_CTL) new
			else do
				prev <- getText wnd
				when (isFrame cls || not suspend && prev /= text) $ setWindowText wnd text

		-- Repaint the window
		invalidateRect (Just wnd) Nothing True
		updateWindow wnd)
		(\(_ :: IOError) -> return ()))

-- | The rectangle of a window from its message stream.
{-# INLINE position #-}
position ev = corec (\rt msg t -> let rt' = case msg of Move rt -> rt; _ -> rt in
	(rt', rt', t)) (0, 0, 0, 0) ev

{-# INLINE _texts #-}
_texts ev = corec (\s pr@(msg, _) t -> let s' = case msg of Change s -> s; _ -> s in
	(s', (pr, s'), t)) "" ev

-- | The text of a window from its message stream.
{-# INLINE texts #-}
texts ev = fmap snd $ _texts $ fmap (\msg -> (msg, Appearance (return ()) "" (0, 0, 1, 1))) ev

-- | The position of the mouse.
{-# INLINE mousePos #-}
mousePos ev = corec (\pt msg t -> let pt' = case msg of Mouse _ Mv pt -> pt; _ -> pt in
	(pt', pt', t)) (0, 0) ev

-- Rules out Change messages caused by behavior updates.
{-# INLINE behFree #-}
behFree ev = corec (\((prevMsg, _), b) (pr@(_, app), txt) t -> let pr' = (pr, text app == txt && (isChange prevMsg || b)) in
	(pr', pr', t))
	((Focus, undefined), True)
	$ _texts ev

{-# INLINE userChange #-}
userChange cls ev = if isFrame cls then
		filterE (\(msg, _) -> isMove msg) ev
	else
		fmap fst $ filterE (\((msg, _), b) -> isChange msg && b) (behFree ev)

{-# INLINE suspend #-}
suspend cls ev = flipFlop (userChange cls ev) mempty

-- Sample a behavior. This also takes care of suspending behaviors.
{-# INLINE updates #-}
updates :: WndClass -> Behavior Appearance -> Event Message -> Event ((Message, Appearance), Bool)
updates cls beh ev = snapshot samp (suspend cls samp) where
	ev' = ev `untilE` filterE (\m -> case m of Internal Destroy -> True; _ -> False) ev -- The event stream should not deliver messages after Destroy is delivered.
	samp = snapshot ev' beh

getText wnd = catch (getWindowText wnd) (\(_ :: IOError) -> return "")

drawButton wnd hdc app wid ht p bkclr clr = do
	hilite <- getSysColor cOLOR_BTNHIGHLIGHT
	shadow <- getSysColor cOLOR_BTNSHADOW
	grayed <- getSysColor cOLOR_GRAYTEXT
	state <- peekByteOff p 16
	let (upperLeft, lowerRight, pushDown) = if state .&. oDS_SELECTED /= 0 then (shadow, hilite, 2) else (hilite, shadow, 0)
	-- let (txtX, txtY) = extent txt
	-- let left = (wid - (drawX + 4 + txtX)) `div` 2 + pushDown
	let margin = 10
	runReaderT (unDraw (do
		fillRect upperLeft (0, 0, wid, 1)
		fillRect upperLeft (0, 0, 1, ht - 1)
		fillRect lowerRight (0, ht - 1, wid, ht)
		fillRect lowerRight (wid - 1, 1, wid, ht)
		fillRect bkclr (1, 1, wid - 1, ht - 1)
		FRP.Reactivity.Draw.textOut (text app) (margin + 32, margin) defFont
		mask 1 (1, 1) (fst $ onNewBitmap (wid - 2, ht - 2) (draw app))))
		((wid, ht), p, Nothing)
	drawBitmap wnd hdc (fromIntegral wid) (fromIntegral ht) 0 0 p
	-- let txt = Text (0, 0) (snd $ isEnabled $ text wnd) 12 "Tahoma" bkclr (if state .&. oDS_DISABLED /= 0 then grayed else clr)
	{-when (state .&. oDS_FOCUS /= 0) $ do
		drawFocusRect dc (2, 2, wid - 2, ht - 2)
		return ()-}

createWnd parent cls ref = do
	-- Make event fed by the window
	Stream sink ev <- chanSource defaultFrame
	bmp :: SA Int32 CChar <- newArray_ (0, -1)
	let handler proc wnd msg wParam lParam = do
		may <- mapMessage (if isFrame cls then nullPtr else parent) wnd msg wParam lParam

		maybe
			(do
			app <- readIORef ref
			(_, _, wid, ht) <- getClientRect wnd
			let sz = 4 * wid * ht
			resize (0, sz - 1) bmp
			(_, p) <- getPtr bmp
			runReaderT (unDraw (fillRect defBackground (0, 0, wid, ht) >> draw app)) ((wid, ht), p, Nothing)
			if msg == wM_PAINT && isFrame cls then
				allocaPAINTSTRUCT $ \ps -> do
					hdc <- beginPaint wnd ps
					drawBitmap wnd hdc (fromIntegral wid) (fromIntegral ht) 0 0 p
					endPaint wnd ps
				else if msg == wM_DRAWITEM then do
					let drawStruct = unsafeCoerce lParam
					(wnd, hdc) <- catch (liftM2 (,) (peekByteOff drawStruct 20) (peekByteOff drawStruct 24)) (\(_ :: IOException) -> return (nullPtr, nullPtr))
					if map toUpper cls == "BUTTON" then do
						void $ drawButton wnd hdc app wid ht p (rgb 255 255 255) 0
						else void $ do
						drawBitmap wnd hdc (fromIntegral wid) (fromIntegral ht) 0 0 p
						drawText hdc (text app) (0, 0, wid, ht) (dT_VCENTER .|. dT_SINGLELINE)
				else when (msg == wM_CTLCOLORSTATIC) $ void $ setBkMode (unsafeCoerce wParam) tRANSPARENT)
			(\x -> do
				print x
				sink x
				case x of
					Mouse _ Up pt -> when (map toUpper cls == "BUTTON") $ do
						rt <- getClientRect wnd
						when (inside rt pt) (sink Push)
					_ -> return ())
			may

		-- Take care of mouse capture
		if msg `elem` [wM_LBUTTONDOWN, wM_RBUTTONDOWN] then
				void $ setCapture wnd
			else when (msg `elem` [wM_LBUTTONUP, wM_RBUTTONUP]) $ void releaseCapture

		-- An application can't be expected to respond to WM_ENDSESSION immediately,
		-- therefore it holes up in an event loop here, waiting for approval
		-- from the app to close.
		when (msg == wM_ENDSESSION) $ allocaMessage $ \msg ->
			untilM_
				(return ())
				(do
					getMessage msg Nothing
					translateMessage msg
					dispatchMessage msg
					hwnd <- peekByteOff msg 0
					msgN <- peekByteOff msg 4
					return $ hwnd == wnd && msgN == wM_DESTROY)

		if msg == wM_CLOSE || msg == wM_DRAWITEM then
			return 0
			else
			proc wnd msg wParam lParam

	-- Create the window
	hdl <- getModuleHandle Nothing
	let name = mkClassName (if isScrollBar cls then "SCROLLBAR" else cls)
	wnd <- createWindow name "" (wS_CLIPCHILDREN .|. wS_VISIBLE .|. case map toUpper cls of
		"FRAME" -> wS_OVERLAPPEDWINDOW
		"STATIC" -> wS_CHILDWINDOW .|. sS_OWNERDRAW
		"BUTTON" -> wS_CHILDWINDOW .|. bS_OWNERDRAW
		"EDIT" -> wS_CHILDWINDOW .|. eS_AUTOHSCROLL
		"SCROLLBAR" -> wS_CHILDWINDOW .|. sBS_VERT
		"HSCROLLBAR" -> wS_CHILDWINDOW .|. sBS_HORZ
		_ -> wS_CHILDWINDOW) (Just 0) (Just 0) (Just 0) (Just 0) (Just parent) Nothing hdl (handler (defWindowProc . Just))
	updateWindow wnd

	if isFrame cls then void $ sendMessage wnd wM_ACTIVATE 0 0
		else void $ do
		-- Set the font
		font <- createFont 16 0 0 0 fW_NORMAL False False False dEFAULT_CHARSET 0 0 dEFAULT_QUALITY fF_DONTCARE "Tahoma"
		sendMessage wnd wM_SETFONT (toWPARAM font) 0

		subclassProc wnd handler

		-- Send a create message to the parent on this control's behalf
		postMessage parent wM_APP (toWPARAM wnd) 0

	return (wnd, ev)

isFrame cls = cls == "Frame"

mapMessage parent hwnd msg wParam lParam = if msg `elem` [wM_LBUTTONUP, wM_LBUTTONDOWN, wM_RBUTTONUP, wM_RBUTTONDOWN, wM_LBUTTONDBLCLK, wM_RBUTTONDBLCLK, wM_MOUSEMOVE] then
		return $ Just $ Mouse
			(if msg `elem` [wM_LBUTTONDOWN, wM_LBUTTONUP, wM_LBUTTONDBLCLK] then L else R)
			(if msg `elem` [wM_LBUTTONDOWN, wM_RBUTTONDOWN] then
				Down
			else if msg `elem` [wM_LBUTTONDBLCLK, wM_RBUTTONDBLCLK] then
				Dbl
			else if msg == wM_MOUSEMOVE then
				Mv
			else
				Up)
			(fromIntegral (fromIntegral (loWord lParam) :: Int16) :: Int32, hiWord lParam)
	else if msg `elem` [wM_KEYDOWN, wM_KEYUP] then
		return $ Just $ Key (msg == wM_KEYDOWN) wParam
	else if msg == wM_COMMAND && hiWord wParam `elem` [eN_UPDATE, cBN_EDITUPDATE, cBN_SELENDOK] then
		liftM (\s -> Just $ Internal $ IChange s (unsafeCoerce lParam)) $ getText $ unsafeCoerce lParam
	else if msg == wM_COMMAND && hiWord wParam == bN_CLICKED then
		return $ Just $ Internal $ IPush (unsafeCoerce lParam)
	else if msg `elem` [wM_HSCROLL, wM_VSCROLL] then do
		si <- getScrollInfo (unsafeCoerce lParam) (fromIntegral sB_CTL)
		let newY = if loWord wParam == sB_LINEDOWN then
				nPos si + 50
			else if loWord wParam == sB_LINEUP then
				nPos si - 50
			else if loWord wParam == sB_PAGEDOWN then
				nPos si + fromIntegral (nPage si)
			else if loWord wParam == sB_PAGEUP then
				nPos si - fromIntegral (nPage si)
			else if loWord wParam == sB_THUMBTRACK then
				maxBound
			else if loWord wParam == sB_THUMBPOSITION then
				nTrackPos si
			else
				nPos si
		if newY == maxBound then
			return Nothing
			else do
				setScrollInfo (unsafeCoerce lParam) (fromIntegral sB_CTL) (si { nPos = newY })
				return $ Just $ Internal $ IChange (show $ max 0 (min newY (nMax si - fromIntegral (nPage si)))) (unsafeCoerce lParam)
	else if msg == wM_WINDOWPOSCHANGED then do
		liftM (Just . Move) $ if parent == nullPtr then
				getClientRect hwnd
			else do
				rt <- getWindowRect hwnd
				(cx, cy) <- clientToScreen parent (0, 0)
				return (shift (-cx, -cy) rt)
	else if msg == wM_ACTIVATE && wParam == 1 then
		return $ Just Focus
	else if msg == wM_SETFOCUS then
		return $ Just $ Internal $ IFocus (unsafeCoerce wParam)
	else if msg == wM_APP then
		return $ Just $ Internal $ Tick (unsafeCoerce wParam)
	else if msg `elem` [wM_CLOSE, wM_ENDSESSION] then
		return $ Just Close
	else if msg == wM_DESTROY then
		return $ Just $ Internal Destroy
	else
		return Nothing