module Main where

import Data.Bits
import qualified Data.Map as M
import System.IO
import Control.Monad.State
import Foreign.C
import Graphics.X11.Xlib
import Graphics.X11.Xlib.Extras
import Graphics.X11.Types
import Foreign.Marshal.Alloc

data Client = Client {
	window :: Window,
	titlebar :: Window,
	cGc :: GC,
	cHeight :: Int,
	cWidth :: Int
} deriving (Show)

data WmState = WmState {
	display :: Display,
	root :: Window,
	width :: Int,
	height :: Int,
	font :: FontStruct,
	clients :: M.Map Window Client
} deriving (Show)

type X = StateT WmState IO

cwx = 0x1
cwy = 0x2
cwwidth = 0x4
cwheight = 0x8

io = liftIO

eventMask = substructureRedirectMask .|. substructureNotifyMask

disableEvents :: X ()
disableEvents = get >>= (\s -> (io (grabServer (display s))) >>
    io (selectInput (display s) (root s) 0))

reenableEvents :: X ()
reenableEvents = get >>= (\s -> (io (selectInput (display s) (root s)
    eventMask)) >> io (ungrabServer (display s)))

makeTitlebar :: Window -> X (Window, GC)
makeTitlebar w = do
	s <- get
	wa <- io $ getWindowAttributes (display s) w
	io $ putStrLn $ "wa width " ++ show (wa_width wa) ++ " height " ++ show (wa_height wa)
	--t <- io $ createSimpleWindow (display s) (root s) 0 0 10 10 2 0 0xffffffff -- (fromIntegral (length $ M.elems $ clients s) * 99)
	ptr <- io $ mallocBytes 4
	t <- io $ createWindow (display s) (root s) 0 0 10 10 2 0 copyFromParent (defaultVisual (display s) 0) 0 ptr
	io $ free ptr
	io $ setWindowBackgroundPixmap (display s) t 1
	io $ reparentWindow (display s) w t 0 10
	io $ selectInput (display s) t eventMask
	io $ putStrLn $ "mapping win " ++ show w
	gc <- io $ createGC (display s) t
	io $ setFont (display s) gc (fontFromFontStruct $ font s)
	io $ setBackground (display s) gc 0
	io $ setForeground (display s) gc 5
	io $ mapWindow (display s) w
	io $ mapWindow (display s) t
	return (t, gc)

configureClient c i x y wt ht = do
	s <- get
	io $ configureWindow (display s) (titlebar c)
	    (cwx .|. cwy .|. cwwidth .|. cwheight) wc
	io $ configureWindow (display s) (window c)
	    (cwx .|. cwy .|. cwwidth .|. cwheight) wc'
	io $ setForeground (display s) (cGc c) 0
	io $ fillRectangle (display s) (titlebar c) (cGc c) 0 0 (fromIntegral wt) 10
	io $ setForeground (display s) (cGc c) 0xffffffff
	io $ drawString (display s) (titlebar c) (cGc c) 50 8 "wooo"
	io $ flushGC (display s) (cGc c)
	io $ putStrLn $ "Drawing " ++ show i ++ " at " ++ show x ++ " " ++ show y ++ " width " ++ show wt ++ " height " ++ show ht
		where
			wc = WindowChanges { wc_x = x, wc_y = y, wc_width = wt,
				wc_height = ht, wc_border_width = 0,
				wc_sibling = 0, wc_stack_mode = 0
			}
			wc' = wc { wc_x = 0, wc_y = 10, wc_height = ht - 10 }

destroyWin :: Window -> X ()
destroyWin win = do
	s <- get
	case M.lookup win (clients s) of
		Just c -> do
			put (s { clients = M.delete win $ clients s })
			io $ destroyWindow (display s) $ titlebar c
			io $ putStrLn "got unmap of know window"
		Nothing -> io $ putStrLn "got unmap of unknown window"

reorganize :: X ()
reorganize = do
	s <- get
	io $ putStrLn $ "reorg " ++ show (length $ M.elems $ clients s) ++ " windows"
	mapM_ (\(i, c) -> configureClient c i (x s i) (y s i) (wt s i)
	    (ht s i)) (zip [0..] $ M.elems $ clients s)
		where 
			x s i = fromIntegral $ i * (width s) `div`
			    (length $ M.keys $ clients s) -- XXX
			y s i = 0
			wt s i = fromIntegral $ (width s) `div`
			    (length $ M.keys $ clients s) -- XXX
			ht s i = fromIntegral $ height s

handle :: Event -> X ()
handle (MapRequestEvent { ev_window = win }) = do
	s <- get
	(t, gc) <- makeTitlebar win
	put (s { clients = M.insert win (Client win t gc 0 0) (clients s) })
	io $ putStrLn "got map"
	reorganize

handle (UnmapEvent { ev_window = win }) = destroyWin win >> reorganize
handle (DestroyWindowEvent { ev_window = win }) = destroyWin win >> reorganize

handle e@(ConfigureRequestEvent { }) = do
	s <- get
	io $ configureWindow (display s) (ev_window e) (ev_value_mask e) $ wc
		where wc = WindowChanges {
			wc_x = ev_x e,
			wc_y = ev_y e,
			wc_width = ev_width e,
			wc_height = ev_height e,
			wc_border_width = ev_border_width e,
			wc_sibling = ev_above e,
			wc_stack_mode = fromIntegral $ ev_detail e
		}

handle e = io $ putStrLn $ "got event " ++ show e

mainLoop :: XEventPtr -> X ()
mainLoop e = do
	s <- get
	io (nextEvent (display s) e) >> io (getEvent e) >>= handle >>
	    mainLoop e

main :: IO ()
main = do
	display <- openDisplay ""
	let screen = defaultScreen display
	    width = displayWidth display screen
	    height = displayHeight display screen
	root <- rootWindow display screen
        putStrLn $ show width ++ "x" ++ show height
	selectInput display root eventMask
	font <- loadQueryFont display "-*-courier-*-r-*-*-12-*-*-*-*-*-*-*"
	allocaXEvent $ \e ->
		evalStateT (mainLoop e)
		    (WmState display root (fromIntegral width)
		    (fromIntegral height) font M.empty)