--
-- Experimenting with Haskell delegates using WinForms
--
-- Based on sample contributed by Bryn Keller for Hugs98.NET
--
module Forms where

import NET
import Control.Concurrent

type Control a = Object a
type Config a  = Control a -> IO ()
type Setter a b = b -> Config a

build :: IO ()
build = do
  frm <- mkCtrl "System.Windows.Forms.Form" [option setSize (200, 200)]
  btn <- frm # addCtrl "System.Windows.Forms.Button" 
                       [ option setText "Click Me"
   		       , option setSize     (50,50)
		       , option setLocation (75,75)
		       ]
  lab <- frm # addCtrl "System.Windows.Forms.Label" 
                       [ option setText "Clicks: 0"
		       , option setSize     (50,50)
		       , option setLocation (0,0)
		       ]
   -- start up an counting, updating thread.
  ch <- newChan
  forkIO (updateLabel lab 0 ch)
  event btn "Click" (\_ _ -> do
                        msgBox "Hello!" "Congratulations, you're back...in Haskell again!"
			writeChan ch True)
  frm # runForms 
  writeChan ch False

updateLabel :: Control a -> Int -> Chan Bool -> IO ()
updateLabel lab v ch = do
  x <- readChan ch
  case x of
    False -> return ()
    True  -> do
      lab # setText ("Clicks: " ++ show (v+1))
      updateLabel lab (v+1) ch

option :: (b -> Control a -> IO()) -> b -> Config a
option f val = f val

mkCtrl :: String -> [Config a] -> IO (Control a)
mkCtrl ctrlType options = do
  ctrl <- new ctrlType
  mapM_ (ctrl # ) options
  return ctrl

event :: Control a -> String -> (Object a -> Object b -> IO ()) -> IO()
event ctrl name func = do
  delegate <- newDelegator2_ "System.EventHandler" func
  ctrl # invoke_ ("add_" ++ name) delegate

setSize :: Setter a (Int, Int)
setSize (width, height) ctrl = do
  ctrl # invoke_ "set_Width" width
  ctrl # invoke_ "set_Height" height

setText :: Setter a String
setText text ctrl = ctrl # invoke_ "set_Text" text

setLocation :: Setter a (Int,  Int)
setLocation (x,y) ctrl = do
  ctrl # invoke_ "set_Left" x
  ctrl # invoke_ "set_Top" y

add :: Object a -> Object a -> IO ()
add collection thing = collection # invoke_ "Add" thing

addCtrl :: String -> [Config a] -> Control a -> IO (Control a)
addCtrl lab opts parent = do
  ch    <- mkCtrl lab opts
  ctrls <- getControls parent
  add ctrls ch
  return ch

getControls :: Control a -> IO (Object a)
getControls frm = frm # invoke "get_Controls" ()

runForms :: Control () -> IO ()
runForms frm = frm # invokeStatic_ "System.Windows.Forms.Application" "Run"