module Graphics.UI.GLUT.Turtle.Console (
	Console,
	openConsole,
	consolePrompt,
	consoleOutput,
	consoleKeyboard,
	consoleCommand
) where

import Graphics.UI.GLUT.Turtle.GLUTools(
	KeyState(..), Modifiers,
	createWindow, printCommands, keyboardCallback, displayAction)
import Data.IORef(IORef, newIORef, readIORef, writeIORef)
import Data.IORef.Tools(atomicModifyIORef_)
import Control.Applicative((<$>))
import Control.Concurrent.STM(atomically)
import Control.Concurrent.STM.TChan(
	TChan, newTChan, readTChan, writeTChan, isEmptyTChan)

--------------------------------------------------------------------------------

data Console = Console{
	cPrompt :: IORef String,
	cCommand :: IORef String,
	cHistory :: IORef [String],
	cUpdate :: IORef Int,
	cResult :: TChan String
 }

openConsole :: String -> Int -> Int -> IO Console
openConsole name w h = do
	cwindow <- createWindow name w h
	cprompt <- newIORef ""
	ccommand <- newIORef ""
	chistory <- newIORef []
	cupdate <- newIORef 1
	cresult <- atomically newTChan
	let	console = Console{
			cPrompt = cprompt,
			cCommand = ccommand,
			cHistory = chistory,
			cUpdate = cupdate,
			cResult = cresult }
	keyboardCallback $ consoleKeyboard console
	displayAction cupdate $ do
		prmpt <- readIORef cprompt
		cmd <- readIORef ccommand
		hst <- readIORef chistory
		printCommands cwindow $ (prmpt ++ reverse cmd) : hst
	return console

consolePrompt :: Console -> String -> IO ()
consolePrompt = writeIORef . cPrompt

consoleOutput :: Console -> String -> IO ()
consoleOutput console str = do
	atomicModifyIORef_ (cUpdate console) succ
	atomicModifyIORef_ (cHistory console) (str :)

consoleKeyboard :: Console -> Char -> KeyState -> Modifiers -> IO ()
consoleKeyboard console '\r' Down _ = do
	atomicModifyIORef_ (cUpdate console) succ
	prmpt <- readIORef $ cPrompt console
	cmd <- readIORef $ cCommand console
	atomicModifyIORef_ (cHistory console) $ ((prmpt ++ reverse cmd) :)
	writeIORef (cCommand console) ""
	atomically $ writeTChan (cResult console) $ reverse cmd
consoleKeyboard console '\b' Down _ = do
	atomicModifyIORef_ (cUpdate console) succ
	atomicModifyIORef_ (cCommand console) $ drop 1
consoleKeyboard console chr Down _ = do
	atomicModifyIORef_ (cUpdate console) succ
	atomicModifyIORef_ (cCommand console) (chr :)
consoleKeyboard _ _ _ _ = return ()

consoleCommand :: Console -> IO (Maybe String)
consoleCommand console = atomically $ do
	emp <- isEmptyTChan $ cResult console
	if emp then return Nothing else Just <$> readTChan (cResult console)