{-# OPTIONS -ffi -fglasgow-exts #-}

module GameShell (
    EventHandler,
    EventHandlerObject,
    
    initialize,
    openGLContextCreated,
    openGLContextWillBeDestroyed,
    openGLContextStateInvalidated,
    openGLContextResized,
    display,
    mousePressed,
    mouseReleased,
    mouseMovedBy,
    mouseMovedTo,
    keyPressed,
    keyReleased,
    textInput,
    
    mouseUncapturedVisibleAbsolute,
    mouseUncapturedInvisibleAbsolute,
    mouseCapturedInvisibleAbsolute,
    mouseCapturedInvisibleRelative,
    getMouseMode,
    setMouseMode,
    fatalError,
    quit,
    
    start
) where

import Foreign
import CForeign

-- types -----------------------------------------------------------------------

class EventHandlerObject a where
    initialize                    ::                   a -> IO a
    openGLContextCreated          ::                   a -> IO a
    openGLContextWillBeDestroyed  ::                   a -> IO a
    openGLContextStateInvalidated ::                   a -> IO a
    openGLContextResized          :: Int -> Int ->     a -> IO a
    
    display                       :: Float ->           a ->IO a
    
    mousePressed                  :: Int ->            a -> IO a
    mouseReleased                 :: Int ->            a -> IO a
    mouseMovedBy                  :: Float -> Float -> a -> IO a
    mouseMovedTo                  :: Float -> Float -> a -> IO a
    
    keyPressed                    :: Int ->            a -> IO a
    keyReleased                   :: Int ->            a -> IO a
    textInput                     :: String ->         a -> IO a
    
    initialize h                    = return h
    openGLContextCreated h          = return h
    openGLContextWillBeDestroyed h  = return h
    openGLContextStateInvalidated h = return h
    openGLContextResized _ _ h      = return h
    display _ h                     = return h
    mousePressed _ h                = return h
    mouseReleased _ h               = return h
    mouseMovedBy _ _ h              = return h
    mouseMovedTo _ _ h              = return h
    keyPressed _ h                  = return h
    keyReleased _ h                 = return h
    textInput _ h                   = return h

data EventHandler = forall a. EventHandlerObject a => EventHandler a

wrapHandler f = f >>= return . EventHandler

instance EventHandlerObject EventHandler where
    initialize (EventHandler h) =
        wrapHandler (initialize h)
    openGLContextCreated (EventHandler h) =
        wrapHandler (openGLContextCreated h)
    openGLContextWillBeDestroyed (EventHandler h) =
        wrapHandler (openGLContextWillBeDestroyed h)
    openGLContextStateInvalidated (EventHandler h) =
        wrapHandler (openGLContextStateInvalidated h)
    openGLContextResized width height (EventHandler h) =
        wrapHandler (openGLContextResized width height h)
    display dt (EventHandler h) =
        wrapHandler (display dt h)
    mousePressed button (EventHandler h) =
        wrapHandler (mousePressed button h)
    mouseReleased button (EventHandler h) =
        wrapHandler (mouseReleased button h)
    mouseMovedBy dx dy (EventHandler h) =
        wrapHandler (mouseMovedBy dx dy h)
    mouseMovedTo x y (EventHandler h) =
        wrapHandler (mouseMovedTo x y h)
    keyPressed k (EventHandler h) =
        wrapHandler (keyPressed k h)
    keyReleased k (EventHandler h) =
        wrapHandler (keyReleased k h)
    textInput s (EventHandler h) =
        wrapHandler (textInput s h)

-- C exports -------------------------------------------------------------------

eventHandler f oldVoidPtr = do
    let oldPointer = castPtrToStablePtr oldVoidPtr
    h@(EventHandler _) <- deRefStablePtr oldPointer
    newH <- f h
    freeStablePtr oldPointer
    pointer <- newStablePtr newH
    return (castStablePtrToPtr pointer)

foreign export ccall eventInitialize :: Ptr () -> IO (Ptr ())
eventInitialize = eventHandler initialize

foreign export ccall eventOpenGLContextCreated :: Ptr () -> IO (Ptr ())
eventOpenGLContextCreated = eventHandler openGLContextCreated

foreign export ccall eventOpenGLContextWillBeDestroyed :: Ptr () -> IO (Ptr ())
eventOpenGLContextWillBeDestroyed = eventHandler openGLContextWillBeDestroyed

foreign export ccall eventOpenGLContextStateInvalidated :: Ptr () -> IO (Ptr ())
eventOpenGLContextStateInvalidated = eventHandler openGLContextStateInvalidated

foreign export ccall eventOpenGLContextResized :: Ptr () -> Int -> Int -> IO (Ptr ())
eventOpenGLContextResized p w h = eventHandler (openGLContextResized w h) p

foreign export ccall eventDisplay :: Ptr () -> Float -> IO (Ptr ())
eventDisplay p dt = eventHandler (display dt) p

foreign export ccall eventMousePressed :: Ptr () -> Int -> IO (Ptr ())
eventMousePressed p button = eventHandler (mousePressed button) p

foreign export ccall eventMouseReleased :: Ptr () -> Int -> IO (Ptr ())
eventMouseReleased p button = eventHandler (mouseReleased button) p

foreign export ccall eventMouseMovedBy :: Ptr () -> Float -> Float -> IO (Ptr ())
eventMouseMovedBy p dx dy = eventHandler (mouseMovedBy dx dy) p

foreign export ccall eventMouseMovedTo :: Ptr () -> Float -> Float -> IO (Ptr ())
eventMouseMovedTo p dx dy = eventHandler (mouseMovedTo dx dy) p

foreign export ccall eventKeyPressed :: Ptr () -> Int -> IO (Ptr ())
eventKeyPressed p k = eventHandler (keyPressed k) p

foreign export ccall eventKeyReleased :: Ptr () -> Int -> IO (Ptr ())
eventKeyReleased p k = eventHandler (keyReleased k) p

foreign export ccall eventTextInput :: Ptr () -> CString -> IO (Ptr ())
eventTextInput p t = do
    s <- peekCString t
    eventHandler (textInput s) p

-- C imports -------------------------------------------------------------------

mouseUncapturedVisibleAbsolute :: Int
mouseUncapturedVisibleAbsolute = 0x0

mouseUncapturedInvisibleAbsolute :: Int
mouseUncapturedInvisibleAbsolute = 0x2

mouseCapturedInvisibleAbsolute :: Int
mouseCapturedInvisibleAbsolute = 0x6

mouseCapturedInvisibleRelative :: Int
mouseCapturedInvisibleRelative = 0x7

foreign import ccall "GSCallbacks.h GSCallbackGetMouseMode" gscGetMouseMode ::
    IO CUInt
foreign import ccall "GSCallbacks.h GSCallbackSetMouseMode" gscSetMouseMode ::
    CUInt -> IO ()
foreign import ccall "GSCallbacks.h GSCallbackFatalError" gscFatalError ::
    CString -> IO ()
foreign import ccall "GSCallbacks.h GSCallbackQuit" gscQuit ::
    IO ()
foreign import ccall "GSHaskell.h GSHaskellStart" gshStart ::
    Ptr () -> IO ()

getMouseMode :: IO Int
getMouseMode = do
    mode <- gscGetMouseMode
    return (fromIntegral mode)

setMouseMode :: Int -> IO ()
setMouseMode mode = do
    gscSetMouseMode (fromIntegral mode)

fatalError :: String -> IO () -- can we indicate no-return?
fatalError message = do
    -- handle UTF-8!
    withCString message gscFatalError

quit :: IO ()
quit = gscQuit

start :: EventHandlerObject a => a -> IO ()
start h = do
    let handler = (EventHandler h)
    pointer <- newStablePtr handler
    gshStart (castStablePtrToPtr pointer)