{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE MultiParamTypeClasses    #-}

module Graphics.UI.GLFW
  ( -- *   Initialization and termination
    initialize
  , terminate

    -- *   Video mode information
  , getVideoMode
  , getVideoModes
    --
  , VideoMode(..)

    -- *   OpenGL context
  , OpenGLProfile(..)
    -- **  Information
  , openGLContextIsForwardCompatible
  , openGLContextIsDebugContext
  , openGLProfile

    -- *   Windows
    -- **  Management
  , openWindow
  , closeWindow
  , setWindowTitle
  , setWindowDimensions
  , setWindowPosition
  , iconifyWindow
  , restoreWindow
  , swapBuffers
  , setWindowBufferSwapInterval
    --
  , DisplayMode(..)
  , DisplayOptions(..)
  , defaultDisplayOptions
    -- **  Information
  , windowIsOpen
  , windowIsActive
  , windowIsIconified
  , windowIsResizable
  , windowIsHardwareAccelerated
  , windowSupportsStereoRendering
  , getWindowRefreshRate
  , getWindowDimensions
  , getWindowValue
  , setWindowCloseCallback
  , setWindowSizeCallback
  , setWindowRefreshCallback
    --
  , WindowValue(..)
  , WindowCloseCallback
  , WindowSizeCallback
  , WindowRefreshCallback

    -- *   Input
  , pollEvents
  , waitEvents
  , enableAutoPoll
  , disableAutoPoll
    -- **  Keyboard
  , keyIsPressed
  , setCharCallback
  , setKeyCallback
    --
  , Key(..)
  , CharCallback
  , KeyCallback
    -- **  Mouse
  , mouseButtonIsPressed
  , getMousePosition
  , getMouseWheel
  , setMousePosition
  , setMouseWheel
  , setMouseButtonCallback
  , setMousePositionCallback
  , setMouseWheelCallback
  , enableMouseCursor
  , disableMouseCursor
    --
  , MouseButton(..)
  , MouseButtonCallback
  , MousePositionCallback
  , MouseWheelCallback
    -- **  Joystick
  , joystickIsPresent
  , getJoystickPosition
  , getNumJoystickAxes
  , getNumJoystickButtons
  , joystickButtonsArePressed
    --
  , Joystick(..)

    -- *   Time
  , getTime
  , setTime
  , resetTime
  , sleep

    -- *   Version information
  , getGlfwVersion
  , getGlVersion
  ) where

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

import Control.Monad         (when)
import Data.Char             (chr, ord)
import Data.IORef            (IORef, atomicModifyIORef, newIORef)
import Data.Maybe            (fromJust, isJust)
import Data.Version          (Version(..))
import Foreign.C.String      (CString, withCString)
import Foreign.C.Types       (CDouble, CFloat, CInt, CUChar)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Array (allocaArray, peekArray)
import Foreign.Ptr           (FunPtr, Ptr, freeHaskellFunPtr)
import Foreign.Storable      (Storable(..))
import System.IO.Unsafe      (unsafePerformIO)

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

#include <GL/glfw.h>

foreign import ccall glfwInit                     :: IO CInt
foreign import ccall glfwTerminate                :: IO ()
foreign import ccall glfwGetVersion               :: Ptr CInt -> Ptr CInt -> Ptr CInt -> IO ()

foreign import ccall glfwOpenWindow               :: CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> CInt -> IO CInt
foreign import ccall glfwOpenWindowHint           :: CInt -> CInt -> IO ()
foreign import ccall glfwCloseWindow              :: IO ()
foreign import ccall glfwSetWindowCloseCallback   :: FunPtr GlfwWindowCloseCallback -> IO ()
foreign import ccall glfwSetWindowTitle           :: CString -> IO ()
foreign import ccall glfwSetWindowSize            :: CInt -> CInt -> IO ()
foreign import ccall glfwSetWindowPos             :: CInt -> CInt -> IO ()
foreign import ccall glfwGetWindowSize            :: Ptr CInt -> Ptr CInt -> IO ()
foreign import ccall glfwSetWindowSizeCallback    :: FunPtr GlfwWindowSizeCallback -> IO ()
foreign import ccall glfwIconifyWindow            :: IO ()
foreign import ccall glfwRestoreWindow            :: IO ()
foreign import ccall glfwGetWindowParam           :: CInt -> IO CInt
foreign import ccall glfwSwapBuffers              :: IO ()
foreign import ccall glfwSwapInterval             :: CInt -> IO ()
foreign import ccall glfwSetWindowRefreshCallback :: FunPtr GlfwWindowRefreshCallback -> IO ()

foreign import ccall glfwGetVideoModes            :: Ptr VideoMode -> CInt -> IO CInt
foreign import ccall glfwGetDesktopMode           :: Ptr VideoMode -> IO ()

foreign import ccall glfwPollEvents               :: IO ()
foreign import ccall glfwWaitEvents               :: IO ()
foreign import ccall glfwGetKey                   :: CInt -> IO CInt
foreign import ccall glfwGetMouseButton           :: CInt -> IO CInt
foreign import ccall glfwGetMousePos              :: Ptr CInt -> Ptr CInt -> IO ()
foreign import ccall glfwSetMousePos              :: CInt -> CInt -> IO ()
foreign import ccall glfwGetMouseWheel            :: IO CInt
foreign import ccall glfwSetMouseWheel            :: CInt -> IO ()
foreign import ccall glfwSetKeyCallback           :: FunPtr GlfwKeyCallback -> IO ()
foreign import ccall glfwSetCharCallback          :: FunPtr GlfwCharCallback -> IO ()
foreign import ccall glfwSetMouseButtonCallback   :: FunPtr GlfwMouseButtonCallback -> IO ()
foreign import ccall glfwSetMousePosCallback      :: FunPtr GlfwMousePositionCallback -> IO ()
foreign import ccall glfwSetMouseWheelCallback    :: FunPtr GlfwMouseWheelCallback -> IO ()
foreign import ccall glfwGetJoystickParam         :: CInt -> CInt -> IO CInt
foreign import ccall glfwGetJoystickPos           :: CInt -> Ptr CFloat -> CInt -> IO CInt
foreign import ccall glfwGetJoystickButtons       :: CInt -> Ptr CUChar -> CInt -> IO CInt

foreign import ccall glfwGetTime                  :: IO CDouble
foreign import ccall glfwSetTime                  :: CDouble -> IO ()
foreign import ccall glfwSleep                    :: CDouble -> IO ()

foreign import ccall glfwGetGLVersion             :: Ptr CInt -> Ptr CInt -> Ptr CInt -> IO ()

foreign import ccall glfwEnable                   :: CInt -> IO ()
foreign import ccall glfwDisable                  :: CInt -> IO ()

type GlfwCharCallback          = CInt -> CInt -> IO ()
type GlfwKeyCallback           = CInt -> CInt -> IO ()
type GlfwMouseButtonCallback   = CInt -> CInt -> IO ()
type GlfwMousePositionCallback = CInt -> CInt -> IO ()
type GlfwMouseWheelCallback    = CInt         -> IO ()
type GlfwWindowCloseCallback   =                 IO CInt
type GlfwWindowRefreshCallback =                 IO ()
type GlfwWindowSizeCallback    = CInt -> CInt -> IO ()

type CharCallback          = Char -> Bool        -> IO ()
type KeyCallback           = Key -> Bool         -> IO ()
type MouseButtonCallback   = MouseButton -> Bool -> IO ()
type MousePositionCallback = Int -> Int          -> IO ()
type MouseWheelCallback    = Int                 -> IO ()
type WindowCloseCallback   =                        IO Bool
type WindowRefreshCallback =                        IO ()
type WindowSizeCallback    = Int -> Int          -> IO ()

foreign import ccall "wrapper" wrapCharCallback          :: GlfwCharCallback          -> IO (FunPtr GlfwCharCallback)
foreign import ccall "wrapper" wrapKeyCallback           :: GlfwKeyCallback           -> IO (FunPtr GlfwKeyCallback)
foreign import ccall "wrapper" wrapMouseButtonCallback   :: GlfwMouseButtonCallback   -> IO (FunPtr GlfwMouseButtonCallback)
foreign import ccall "wrapper" wrapMousePositionCallback :: GlfwMousePositionCallback -> IO (FunPtr GlfwMousePositionCallback)
foreign import ccall "wrapper" wrapMouseWheelCallback    :: GlfwMouseWheelCallback    -> IO (FunPtr GlfwMouseWheelCallback)
foreign import ccall "wrapper" wrapWindowCloseCallback   :: GlfwWindowCloseCallback   -> IO (FunPtr GlfwWindowCloseCallback)
foreign import ccall "wrapper" wrapWindowRefreshCallback :: GlfwWindowRefreshCallback -> IO (FunPtr GlfwWindowRefreshCallback)
foreign import ccall "wrapper" wrapWindowSizeCallback    :: GlfwWindowSizeCallback    -> IO (FunPtr GlfwWindowSizeCallback)

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- Initialization and termination

initialize :: IO Bool
initialize =
    fromC `fmap` glfwInit

terminate :: IO ()
terminate =
    glfwTerminate

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- Video mode information

getVideoMode :: IO VideoMode
getVideoMode =
    alloca $ \ptr -> do
        glfwGetDesktopMode ptr
        peek ptr

getVideoModes :: IO [VideoMode]
getVideoModes =
    allocaArray m $ \ptr -> do
        n <- glfwGetVideoModes ptr (toC m)
        peekArray (fromC n) ptr
  where
    m = 256

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

data VideoMode = VideoMode
  { videoMode_width        :: Int
  , videoMode_height       :: Int
  , videoMode_numRedBits   :: Int
  , videoMode_numGreenBits :: Int
  , videoMode_numBlueBits  :: Int
  } deriving (Eq, Ord, Read, Show)

instance Storable VideoMode where
  sizeOf    _ = (#const sizeof(GLFWvidmode))
  alignment _ = alignment (undefined :: CInt)

  peek ptr = do
      w <- (#peek GLFWvidmode, Width)     ptr :: IO CInt
      h <- (#peek GLFWvidmode, Height)    ptr :: IO CInt
      r <- (#peek GLFWvidmode, RedBits)   ptr :: IO CInt
      g <- (#peek GLFWvidmode, GreenBits) ptr :: IO CInt
      b <- (#peek GLFWvidmode, BlueBits)  ptr :: IO CInt
      return VideoMode
        { videoMode_width        = fromC w
        , videoMode_height       = fromC h
        , videoMode_numRedBits   = fromC r
        , videoMode_numGreenBits = fromC g
        , videoMode_numBlueBits  = fromC b
        }

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- OpenGL context

data OpenGLProfile
  = DefaultProfile
  | CoreProfile
  | CompatibilityProfile
  deriving (Eq, Ord, Bounded, Enum, Read, Show)

instance C OpenGLProfile CInt where
  toC op = case op of
      DefaultProfile       -> 0
      CoreProfile          -> #const GLFW_OPENGL_CORE_PROFILE
      CompatibilityProfile -> #const GLFW_OPENGL_COMPAT_PROFILE
  fromC i = case i of
      (#const GLFW_OPENGL_CORE_PROFILE)   -> CoreProfile
      (#const GLFW_OPENGL_COMPAT_PROFILE) -> CompatibilityProfile
      (0)                                 -> DefaultProfile
      _                                   -> makeFromCError "OpenGLProfile" i

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- OpenGL information

openGLContextIsForwardCompatible :: IO Bool
openGLContextIsForwardCompatible =
    fromC `fmap` glfwGetWindowParam (#const GLFW_OPENGL_FORWARD_COMPAT)

openGLContextIsDebugContext :: IO Bool
openGLContextIsDebugContext =
    fromC `fmap` glfwGetWindowParam (#const GLFW_OPENGL_DEBUG_CONTEXT)

openGLProfile :: IO OpenGLProfile
openGLProfile =
    fromC `fmap` glfwGetWindowParam (#const GLFW_OPENGL_PROFILE)

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- Window management

openWindow :: DisplayOptions -> IO Bool
openWindow displayOptions = do
    let DisplayOptions
          { displayOptions_width                   = _displayOptions_width
          , displayOptions_height                  = _displayOptions_height
          , displayOptions_numRedBits              = _displayOptions_numRedBits
          , displayOptions_numGreenBits            = _displayOptions_numGreenBits
          , displayOptions_numBlueBits             = _displayOptions_numBlueBits
          , displayOptions_numAlphaBits            = _displayOptions_numAlphaBits
          , displayOptions_numDepthBits            = _displayOptions_numDepthBits
          , displayOptions_numStencilBits          = _displayOptions_numStencilBits
          , displayOptions_displayMode             = _displayOptions_displayMode
          , displayOptions_refreshRate             = _displayOptions_refreshRate
          , displayOptions_accumNumRedBits         = _displayOptions_accumNumRedBits
          , displayOptions_accumNumGreenBits       = _displayOptions_accumNumGreenBits
          , displayOptions_accumNumBlueBits        = _displayOptions_accumNumBlueBits
          , displayOptions_accumNumAlphaBits       = _displayOptions_accumNumAlphaBits
          , displayOptions_numAuxiliaryBuffers     = _displayOptions_numAuxiliaryBuffers
          , displayOptions_numFsaaSamples          = _displayOptions_numFsaaSamples
          , displayOptions_windowIsResizable       = _displayOptions_windowIsResizable
          , displayOptions_stereoRendering         = _displayOptions_stereoRendering
          , displayOptions_openGLVersion           = _displayOptions_openGLVersion
          , displayOptions_openGLForwardCompatible = _displayOptions_openGLForwardCompatible
          , displayOptions_openGLDebugContext      = _displayOptions_openGLDebugContext
          , displayOptions_openGLProfile           = _displayOptions_openGLProfile
          } = displayOptions

    -- Add hints.
    when (isJust _displayOptions_refreshRate)              $ glfwOpenWindowHint (#const GLFW_REFRESH_RATE)     (toC (fromJust _displayOptions_refreshRate))
    when (isJust _displayOptions_accumNumRedBits)          $ glfwOpenWindowHint (#const GLFW_ACCUM_RED_BITS)   (toC (fromJust _displayOptions_accumNumRedBits))
    when (isJust _displayOptions_accumNumGreenBits)        $ glfwOpenWindowHint (#const GLFW_ACCUM_GREEN_BITS) (toC (fromJust _displayOptions_accumNumGreenBits))
    when (isJust _displayOptions_accumNumBlueBits)         $ glfwOpenWindowHint (#const GLFW_ACCUM_BLUE_BITS)  (toC (fromJust _displayOptions_accumNumBlueBits))
    when (isJust _displayOptions_accumNumAlphaBits)        $ glfwOpenWindowHint (#const GLFW_ACCUM_ALPHA_BITS) (toC (fromJust _displayOptions_accumNumAlphaBits))
    when (isJust _displayOptions_numAuxiliaryBuffers)      $ glfwOpenWindowHint (#const GLFW_AUX_BUFFERS)      (toC (fromJust _displayOptions_numAuxiliaryBuffers))
    when (isJust _displayOptions_numFsaaSamples)           $ glfwOpenWindowHint (#const GLFW_FSAA_SAMPLES)     (toC (fromJust _displayOptions_numFsaaSamples))

    glfwOpenWindowHint (#const GLFW_WINDOW_NO_RESIZE)      (toC (not _displayOptions_windowIsResizable))
    glfwOpenWindowHint (#const GLFW_STEREO)                (toC      _displayOptions_stereoRendering)
    glfwOpenWindowHint (#const GLFW_OPENGL_VERSION_MAJOR)  (toC (fst _displayOptions_openGLVersion))
    glfwOpenWindowHint (#const GLFW_OPENGL_VERSION_MINOR)  (toC (snd _displayOptions_openGLVersion))
    glfwOpenWindowHint (#const GLFW_OPENGL_FORWARD_COMPAT) (toC _displayOptions_openGLForwardCompatible)
    glfwOpenWindowHint (#const GLFW_OPENGL_DEBUG_CONTEXT)  (toC _displayOptions_openGLDebugContext)
    glfwOpenWindowHint (#const GLFW_OPENGL_PROFILE)        (toC _displayOptions_openGLProfile)

    -- Open the window.
    fromC `fmap` glfwOpenWindow
      (toC _displayOptions_width)
      (toC _displayOptions_height)
      (toC _displayOptions_numRedBits)
      (toC _displayOptions_numGreenBits)
      (toC _displayOptions_numBlueBits)
      (toC _displayOptions_numAlphaBits)
      (toC _displayOptions_numDepthBits)
      (toC _displayOptions_numStencilBits)
      (toC _displayOptions_displayMode)

closeWindow :: IO ()
closeWindow =
    glfwCloseWindow

setWindowTitle :: String -> IO ()
setWindowTitle t =
    withCString t glfwSetWindowTitle

setWindowDimensions :: Int -> Int -> IO ()
setWindowDimensions w h =
    glfwSetWindowSize (toC w) (toC h)

setWindowPosition :: Int -> Int -> IO ()
setWindowPosition w h =
    glfwSetWindowPos (toC w) (toC h)

iconifyWindow :: IO ()
iconifyWindow =
    glfwIconifyWindow

restoreWindow :: IO ()
restoreWindow =
    glfwRestoreWindow

swapBuffers :: IO ()
swapBuffers =
    glfwSwapBuffers

setWindowBufferSwapInterval :: Int -> IO ()
setWindowBufferSwapInterval =
    glfwSwapInterval . toC

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

data DisplayMode
  = Window
  | Fullscreen
  deriving (Eq, Ord, Bounded, Enum, Read, Show)

instance C DisplayMode CInt where
  toC dm = case dm of
      Window     -> #const GLFW_WINDOW
      Fullscreen -> #const GLFW_FULLSCREEN

  fromC i = case i of
      (#const GLFW_WINDOW    ) -> Window
      (#const GLFW_FULLSCREEN) -> Fullscreen
      _                        -> makeFromCError "DisplayMode" i

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

data DisplayOptions = DisplayOptions
  { displayOptions_width                   :: Int
  , displayOptions_height                  :: Int
  , displayOptions_numRedBits              :: Int
  , displayOptions_numGreenBits            :: Int
  , displayOptions_numBlueBits             :: Int
  , displayOptions_numAlphaBits            :: Int
  , displayOptions_numDepthBits            :: Int
  , displayOptions_numStencilBits          :: Int
  , displayOptions_displayMode             :: DisplayMode
  , displayOptions_refreshRate             :: Maybe Int
  , displayOptions_accumNumRedBits         :: Maybe Int
  , displayOptions_accumNumGreenBits       :: Maybe Int
  , displayOptions_accumNumBlueBits        :: Maybe Int
  , displayOptions_accumNumAlphaBits       :: Maybe Int
  , displayOptions_numAuxiliaryBuffers     :: Maybe Int
  , displayOptions_numFsaaSamples          :: Maybe Int
  , displayOptions_windowIsResizable       :: Bool
  , displayOptions_stereoRendering         :: Bool
  , displayOptions_openGLVersion           :: (Int, Int)
  , displayOptions_openGLForwardCompatible :: Bool
  , displayOptions_openGLDebugContext      :: Bool
  , displayOptions_openGLProfile           :: OpenGLProfile

  } deriving (Eq, Ord, Read, Show)

defaultDisplayOptions :: DisplayOptions
defaultDisplayOptions =
    DisplayOptions
      { displayOptions_width                   = 0
      , displayOptions_height                  = 0
      , displayOptions_numRedBits              = 0
      , displayOptions_numGreenBits            = 0
      , displayOptions_numBlueBits             = 0
      , displayOptions_numAlphaBits            = 0
      , displayOptions_numDepthBits            = 0
      , displayOptions_numStencilBits          = 0
      , displayOptions_displayMode             = Window
      , displayOptions_refreshRate             = Nothing
      , displayOptions_accumNumRedBits         = Nothing
      , displayOptions_accumNumGreenBits       = Nothing
      , displayOptions_accumNumBlueBits        = Nothing
      , displayOptions_accumNumAlphaBits       = Nothing
      , displayOptions_numAuxiliaryBuffers     = Nothing
      , displayOptions_numFsaaSamples          = Nothing
      , displayOptions_windowIsResizable       = True
      , displayOptions_stereoRendering         = False
      , displayOptions_openGLVersion           = (1,1)
      , displayOptions_openGLForwardCompatible = False
      , displayOptions_openGLDebugContext      = False
      , displayOptions_openGLProfile           = DefaultProfile
      }

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- Window information

windowIsOpen :: IO Bool
windowIsOpen =
    fromC `fmap` glfwGetWindowParam (#const GLFW_OPENED)

windowIsActive :: IO Bool
windowIsActive =
    fromC `fmap` glfwGetWindowParam (#const GLFW_ACTIVE)

windowIsIconified :: IO Bool
windowIsIconified =
    fromC `fmap` glfwGetWindowParam (#const GLFW_ICONIFIED)

windowIsResizable :: IO Bool
windowIsResizable =
    (not . fromC) `fmap` glfwGetWindowParam (#const GLFW_WINDOW_NO_RESIZE)

windowIsHardwareAccelerated :: IO Bool
windowIsHardwareAccelerated =
    fromC `fmap` glfwGetWindowParam (#const GLFW_ACCELERATED)

windowSupportsStereoRendering :: IO Bool
windowSupportsStereoRendering =
    fromC `fmap` glfwGetWindowParam (#const GLFW_STEREO)

getWindowRefreshRate :: IO Int
getWindowRefreshRate =
    fromC `fmap` glfwGetWindowParam (#const GLFW_REFRESH_RATE)

getWindowDimensions :: IO (Int, Int)
getWindowDimensions =
    alloca $ \wp ->
    alloca $ \hp -> do
        glfwGetWindowSize wp hp
        w <- peek wp
        h <- peek hp
        return (fromC w, fromC h)

getWindowValue :: WindowValue -> IO Int
getWindowValue wn =
    fromC `fmap` glfwGetWindowParam (toC wn)

setWindowCloseCallback :: WindowCloseCallback -> IO ()
setWindowCloseCallback cb = do
    ccb <- wrapWindowCloseCallback (toC `fmap` cb)
    glfwSetWindowCloseCallback ccb
    storeCallback windowCloseCallback ccb

setWindowSizeCallback :: WindowSizeCallback -> IO ()
setWindowSizeCallback cb = do
    ccb <- wrapWindowSizeCallback (\w h -> cb (fromC w) (fromC h))
    glfwSetWindowSizeCallback ccb
    storeCallback windowSizeCallback ccb

setWindowRefreshCallback :: WindowRefreshCallback -> IO ()
setWindowRefreshCallback cb = do
    ccb <- wrapWindowRefreshCallback cb
    glfwSetWindowRefreshCallback ccb
    storeCallback windowRefreshCallback ccb

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

data WindowValue
  = NumRedBits
  | NumGreenBits
  | NumBlueBits
  | NumAlphaBits
  | NumDepthBits
  | NumStencilBits
  | NumAccumRedBits
  | NumAccumGreenBits
  | NumAccumBlueBits
  | NumAccumAlphaBits
  | NumAuxBuffers
  | NumFsaaSamples
  deriving (Eq, Ord, Bounded, Enum, Read, Show)

instance C WindowValue CInt where
  toC wn = case wn of
      NumRedBits        -> #const GLFW_RED_BITS
      NumGreenBits      -> #const GLFW_GREEN_BITS
      NumBlueBits       -> #const GLFW_BLUE_BITS
      NumAlphaBits      -> #const GLFW_ALPHA_BITS
      NumDepthBits      -> #const GLFW_DEPTH_BITS
      NumStencilBits    -> #const GLFW_STENCIL_BITS
      NumAccumRedBits   -> #const GLFW_ACCUM_RED_BITS
      NumAccumGreenBits -> #const GLFW_ACCUM_GREEN_BITS
      NumAccumBlueBits  -> #const GLFW_ACCUM_BLUE_BITS
      NumAccumAlphaBits -> #const GLFW_ACCUM_ALPHA_BITS
      NumAuxBuffers     -> #const GLFW_AUX_BUFFERS
      NumFsaaSamples    -> #const GLFW_FSAA_SAMPLES

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- Input

pollEvents :: IO ()
pollEvents =
    glfwPollEvents

waitEvents :: IO ()
waitEvents =
    glfwWaitEvents


-- Make 'swapBuffers' implicitly call 'pollEvents' (Default)
enableAutoPoll :: IO ()
enableAutoPoll = glfwEnable (#const GLFW_AUTO_POLL_EVENTS)

-- Disable 'swapBuffers' implicitly calling 'pollEvents'
disableAutoPoll :: IO ()
disableAutoPoll = glfwDisable (#const GLFW_AUTO_POLL_EVENTS)

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- Keyboard

keyIsPressed :: Key -> IO Bool
keyIsPressed k =
    fromC `fmap` glfwGetKey (toC k)

setCharCallback :: CharCallback -> IO ()
setCharCallback cb = do
    ccb <- wrapCharCallback (\c b -> cb (fromC c) (fromC b))
    glfwSetCharCallback ccb
    storeCallback charCallback ccb

setKeyCallback :: KeyCallback -> IO ()
setKeyCallback cb = do
    ccb <- wrapKeyCallback (\k b -> cb (fromC k) (fromC b))
    glfwSetKeyCallback ccb
    storeCallback keyCallback ccb

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

data Key
  = CharKey Char
  | KeyUnknown
  | KeySpace
  | KeySpecial
  | KeyEsc
  | KeyF1
  | KeyF2
  | KeyF3
  | KeyF4
  | KeyF5
  | KeyF6
  | KeyF7
  | KeyF8
  | KeyF9
  | KeyF10
  | KeyF11
  | KeyF12
  | KeyF13
  | KeyF14
  | KeyF15
  | KeyF16
  | KeyF17
  | KeyF18
  | KeyF19
  | KeyF20
  | KeyF21
  | KeyF22
  | KeyF23
  | KeyF24
  | KeyF25
  | KeyUp
  | KeyDown
  | KeyLeft
  | KeyRight
  | KeyLeftShift
  | KeyRightShift
  | KeyLeftCtrl
  | KeyRightCtrl
  | KeyLeftAlt
  | KeyRightAlt
  | KeyTab
  | KeyEnter
  | KeyBackspace
  | KeyInsert
  | KeyDel
  | KeyPageup
  | KeyPagedown
  | KeyHome
  | KeyEnd
  | KeyPad0
  | KeyPad1
  | KeyPad2
  | KeyPad3
  | KeyPad4
  | KeyPad5
  | KeyPad6
  | KeyPad7
  | KeyPad8
  | KeyPad9
  | KeyPadDivide
  | KeyPadMultiply
  | KeyPadSubtract
  | KeyPadAdd
  | KeyPadDecimal
  | KeyPadEqual
  | KeyPadEnter
  deriving (Eq, Ord, Read, Show)

instance C Key CInt where
  toC k = case k of
      CharKey c      -> fromIntegral (ord c)
      KeyUnknown     -> #const GLFW_KEY_UNKNOWN
      KeySpace       -> #const GLFW_KEY_SPACE
      KeySpecial     -> #const GLFW_KEY_SPECIAL
      KeyEsc         -> #const GLFW_KEY_ESC
      KeyF1          -> #const GLFW_KEY_F1
      KeyF2          -> #const GLFW_KEY_F2
      KeyF3          -> #const GLFW_KEY_F3
      KeyF4          -> #const GLFW_KEY_F4
      KeyF5          -> #const GLFW_KEY_F5
      KeyF6          -> #const GLFW_KEY_F6
      KeyF7          -> #const GLFW_KEY_F7
      KeyF8          -> #const GLFW_KEY_F8
      KeyF9          -> #const GLFW_KEY_F9
      KeyF10         -> #const GLFW_KEY_F10
      KeyF11         -> #const GLFW_KEY_F11
      KeyF12         -> #const GLFW_KEY_F12
      KeyF13         -> #const GLFW_KEY_F13
      KeyF14         -> #const GLFW_KEY_F14
      KeyF15         -> #const GLFW_KEY_F15
      KeyF16         -> #const GLFW_KEY_F16
      KeyF17         -> #const GLFW_KEY_F17
      KeyF18         -> #const GLFW_KEY_F18
      KeyF19         -> #const GLFW_KEY_F19
      KeyF20         -> #const GLFW_KEY_F20
      KeyF21         -> #const GLFW_KEY_F21
      KeyF22         -> #const GLFW_KEY_F22
      KeyF23         -> #const GLFW_KEY_F23
      KeyF24         -> #const GLFW_KEY_F24
      KeyF25         -> #const GLFW_KEY_F25
      KeyUp          -> #const GLFW_KEY_UP
      KeyDown        -> #const GLFW_KEY_DOWN
      KeyLeft        -> #const GLFW_KEY_LEFT
      KeyRight       -> #const GLFW_KEY_RIGHT
      KeyLeftShift   -> #const GLFW_KEY_LSHIFT
      KeyRightShift  -> #const GLFW_KEY_RSHIFT
      KeyLeftCtrl    -> #const GLFW_KEY_LCTRL
      KeyRightCtrl   -> #const GLFW_KEY_RCTRL
      KeyLeftAlt     -> #const GLFW_KEY_LALT
      KeyRightAlt    -> #const GLFW_KEY_RALT
      KeyTab         -> #const GLFW_KEY_TAB
      KeyEnter       -> #const GLFW_KEY_ENTER
      KeyBackspace   -> #const GLFW_KEY_BACKSPACE
      KeyInsert      -> #const GLFW_KEY_INSERT
      KeyDel         -> #const GLFW_KEY_DEL
      KeyPageup      -> #const GLFW_KEY_PAGEUP
      KeyPagedown    -> #const GLFW_KEY_PAGEDOWN
      KeyHome        -> #const GLFW_KEY_HOME
      KeyEnd         -> #const GLFW_KEY_END
      KeyPad0        -> #const GLFW_KEY_KP_0
      KeyPad1        -> #const GLFW_KEY_KP_1
      KeyPad2        -> #const GLFW_KEY_KP_2
      KeyPad3        -> #const GLFW_KEY_KP_3
      KeyPad4        -> #const GLFW_KEY_KP_4
      KeyPad5        -> #const GLFW_KEY_KP_5
      KeyPad6        -> #const GLFW_KEY_KP_6
      KeyPad7        -> #const GLFW_KEY_KP_7
      KeyPad8        -> #const GLFW_KEY_KP_8
      KeyPad9        -> #const GLFW_KEY_KP_9
      KeyPadDivide   -> #const GLFW_KEY_KP_DIVIDE
      KeyPadMultiply -> #const GLFW_KEY_KP_MULTIPLY
      KeyPadSubtract -> #const GLFW_KEY_KP_SUBTRACT
      KeyPadAdd      -> #const GLFW_KEY_KP_ADD
      KeyPadDecimal  -> #const GLFW_KEY_KP_DECIMAL
      KeyPadEqual    -> #const GLFW_KEY_KP_EQUAL
      KeyPadEnter    -> #const GLFW_KEY_KP_ENTER

  fromC i =
      if i < #const GLFW_KEY_SPECIAL
        then CharKey (chr (fromIntegral i))
        else case i of
               (#const GLFW_KEY_UNKNOWN    ) -> KeyUnknown
               (#const GLFW_KEY_SPACE      ) -> KeySpace
               (#const GLFW_KEY_SPECIAL    ) -> KeySpecial
               (#const GLFW_KEY_ESC        ) -> KeyEsc
               (#const GLFW_KEY_F1         ) -> KeyF1
               (#const GLFW_KEY_F2         ) -> KeyF2
               (#const GLFW_KEY_F3         ) -> KeyF3
               (#const GLFW_KEY_F4         ) -> KeyF4
               (#const GLFW_KEY_F5         ) -> KeyF5
               (#const GLFW_KEY_F6         ) -> KeyF6
               (#const GLFW_KEY_F7         ) -> KeyF7
               (#const GLFW_KEY_F8         ) -> KeyF8
               (#const GLFW_KEY_F9         ) -> KeyF9
               (#const GLFW_KEY_F10        ) -> KeyF10
               (#const GLFW_KEY_F11        ) -> KeyF11
               (#const GLFW_KEY_F12        ) -> KeyF12
               (#const GLFW_KEY_F13        ) -> KeyF13
               (#const GLFW_KEY_F14        ) -> KeyF14
               (#const GLFW_KEY_F15        ) -> KeyF15
               (#const GLFW_KEY_F16        ) -> KeyF16
               (#const GLFW_KEY_F17        ) -> KeyF17
               (#const GLFW_KEY_F18        ) -> KeyF18
               (#const GLFW_KEY_F19        ) -> KeyF19
               (#const GLFW_KEY_F20        ) -> KeyF20
               (#const GLFW_KEY_F21        ) -> KeyF21
               (#const GLFW_KEY_F22        ) -> KeyF22
               (#const GLFW_KEY_F23        ) -> KeyF23
               (#const GLFW_KEY_F24        ) -> KeyF24
               (#const GLFW_KEY_F25        ) -> KeyF25
               (#const GLFW_KEY_UP         ) -> KeyUp
               (#const GLFW_KEY_DOWN       ) -> KeyDown
               (#const GLFW_KEY_LEFT       ) -> KeyLeft
               (#const GLFW_KEY_RIGHT      ) -> KeyRight
               (#const GLFW_KEY_LSHIFT     ) -> KeyLeftShift
               (#const GLFW_KEY_RSHIFT     ) -> KeyRightShift
               (#const GLFW_KEY_LCTRL      ) -> KeyLeftCtrl
               (#const GLFW_KEY_RCTRL      ) -> KeyRightCtrl
               (#const GLFW_KEY_LALT       ) -> KeyLeftAlt
               (#const GLFW_KEY_RALT       ) -> KeyRightAlt
               (#const GLFW_KEY_TAB        ) -> KeyTab
               (#const GLFW_KEY_ENTER      ) -> KeyEnter
               (#const GLFW_KEY_BACKSPACE  ) -> KeyBackspace
               (#const GLFW_KEY_INSERT     ) -> KeyInsert
               (#const GLFW_KEY_DEL        ) -> KeyDel
               (#const GLFW_KEY_PAGEUP     ) -> KeyPageup
               (#const GLFW_KEY_PAGEDOWN   ) -> KeyPagedown
               (#const GLFW_KEY_HOME       ) -> KeyHome
               (#const GLFW_KEY_END        ) -> KeyEnd
               (#const GLFW_KEY_KP_0       ) -> KeyPad0
               (#const GLFW_KEY_KP_1       ) -> KeyPad1
               (#const GLFW_KEY_KP_2       ) -> KeyPad2
               (#const GLFW_KEY_KP_3       ) -> KeyPad3
               (#const GLFW_KEY_KP_4       ) -> KeyPad4
               (#const GLFW_KEY_KP_5       ) -> KeyPad5
               (#const GLFW_KEY_KP_6       ) -> KeyPad6
               (#const GLFW_KEY_KP_7       ) -> KeyPad7
               (#const GLFW_KEY_KP_8       ) -> KeyPad8
               (#const GLFW_KEY_KP_9       ) -> KeyPad9
               (#const GLFW_KEY_KP_DIVIDE  ) -> KeyPadDivide
               (#const GLFW_KEY_KP_MULTIPLY) -> KeyPadMultiply
               (#const GLFW_KEY_KP_SUBTRACT) -> KeyPadSubtract
               (#const GLFW_KEY_KP_ADD     ) -> KeyPadAdd
               (#const GLFW_KEY_KP_DECIMAL ) -> KeyPadDecimal
               (#const GLFW_KEY_KP_EQUAL   ) -> KeyPadEqual
               (#const GLFW_KEY_KP_ENTER   ) -> KeyPadEnter
               _                             -> KeyUnknown

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- Mouse

mouseButtonIsPressed :: MouseButton -> IO Bool
mouseButtonIsPressed mb =
    fromC `fmap` glfwGetMouseButton (toC mb)

getMousePosition :: IO (Int, Int)
getMousePosition =
    alloca $ \px ->
    alloca $ \py -> do
        glfwGetMousePos px py
        x <- peek px
        y <- peek py
        return (fromC x, fromC y)

getMouseWheel :: IO Int
getMouseWheel =
    fromC `fmap` glfwGetMouseWheel

setMousePosition :: Int -> Int -> IO ()
setMousePosition x y =
    glfwSetMousePos (toC x) (toC y)

setMouseWheel :: Int -> IO ()
setMouseWheel =
    glfwSetMouseWheel . toC

setMouseButtonCallback :: MouseButtonCallback -> IO ()
setMouseButtonCallback cb = do
    ccb <- wrapMouseButtonCallback (\b p -> cb (fromC b) (fromC p))
    glfwSetMouseButtonCallback ccb
    storeCallback mouseButtonCallback ccb

setMousePositionCallback :: MousePositionCallback -> IO ()
setMousePositionCallback cb = do
    ccb <- wrapMousePositionCallback (\x y -> cb (fromC x) (fromC y))
    glfwSetMousePosCallback ccb
    storeCallback mousePositionCallback ccb

setMouseWheelCallback :: MouseWheelCallback -> IO ()
setMouseWheelCallback cb = do
    ccb <- wrapMouseWheelCallback (cb . fromC)
    glfwSetMouseWheelCallback ccb
    storeCallback mouseWheelCallback ccb

-- |Make the mouse cursor visible.
enableMouseCursor :: IO ()
enableMouseCursor = glfwEnable (#const GLFW_MOUSE_CURSOR)

-- |Make the mouse cursor invisible.
disableMouseCursor :: IO ()
disableMouseCursor = glfwDisable (#const GLFW_MOUSE_CURSOR)

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

data MouseButton
  = MouseButton0 | MouseButton1 | MouseButton2 | MouseButton3
  | MouseButton4 | MouseButton5 | MouseButton6 | MouseButton7
  deriving (Bounded, Enum, Eq, Ord, Read, Show)

instance C MouseButton CInt where
  toC mb = case mb of
      MouseButton0 -> #const GLFW_MOUSE_BUTTON_1
      MouseButton1 -> #const GLFW_MOUSE_BUTTON_2
      MouseButton2 -> #const GLFW_MOUSE_BUTTON_3
      MouseButton3 -> #const GLFW_MOUSE_BUTTON_4
      MouseButton4 -> #const GLFW_MOUSE_BUTTON_5
      MouseButton5 -> #const GLFW_MOUSE_BUTTON_6
      MouseButton6 -> #const GLFW_MOUSE_BUTTON_7
      MouseButton7 -> #const GLFW_MOUSE_BUTTON_8

  fromC i = case i of
      (#const GLFW_MOUSE_BUTTON_1) -> MouseButton0
      (#const GLFW_MOUSE_BUTTON_2) -> MouseButton1
      (#const GLFW_MOUSE_BUTTON_3) -> MouseButton2
      (#const GLFW_MOUSE_BUTTON_4) -> MouseButton3
      (#const GLFW_MOUSE_BUTTON_5) -> MouseButton4
      (#const GLFW_MOUSE_BUTTON_6) -> MouseButton5
      (#const GLFW_MOUSE_BUTTON_7) -> MouseButton6
      (#const GLFW_MOUSE_BUTTON_8) -> MouseButton7
      _                            -> makeFromCError "MouseButton" i

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- Joystick

joystickIsPresent :: Joystick -> IO Bool
joystickIsPresent j =
    fromC `fmap` glfwGetJoystickParam (toC j) (#const GLFW_PRESENT)

getNumJoystickAxes :: Joystick -> IO Int
getNumJoystickAxes j =
    fromC `fmap` glfwGetJoystickParam (toC j) (#const GLFW_AXES)

getNumJoystickButtons :: Joystick -> IO Int
getNumJoystickButtons j =
    fromC `fmap` glfwGetJoystickParam (toC j) (#const GLFW_BUTTONS)

getJoystickPosition :: Joystick -> Int -> IO [Float]
getJoystickPosition j m =
    if m < 1
      then return []
      else allocaArray m $ \ptr -> do
               n <- fromC `fmap` glfwGetJoystickPos (toC j) ptr (toC m)
               a <- peekArray n ptr
               return $ map fromC a

joystickButtonsArePressed :: Joystick -> Int -> IO [Bool]
joystickButtonsArePressed j m =
    if m < 1
      then return []
      else allocaArray m $ \ptr -> do
               n <- fromC `fmap` glfwGetJoystickButtons (toC j) ptr (toC m)
               a <- peekArray n ptr :: IO [CUChar]
               return $ map ((glfwPress ==) . fromIntegral) a

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

data Joystick
  = Joystick0  | Joystick1  | Joystick2  | Joystick3
  | Joystick4  | Joystick5  | Joystick6  | Joystick7
  | Joystick8  | Joystick9  | Joystick10 | Joystick11
  | Joystick12 | Joystick13 | Joystick14 | Joystick15
  deriving (Bounded, Enum, Eq, Ord, Read, Show)

instance C Joystick CInt where
  toC j = case j of
      Joystick0  -> #const GLFW_JOYSTICK_1
      Joystick1  -> #const GLFW_JOYSTICK_2
      Joystick2  -> #const GLFW_JOYSTICK_3
      Joystick3  -> #const GLFW_JOYSTICK_4
      Joystick4  -> #const GLFW_JOYSTICK_5
      Joystick5  -> #const GLFW_JOYSTICK_6
      Joystick6  -> #const GLFW_JOYSTICK_7
      Joystick7  -> #const GLFW_JOYSTICK_8
      Joystick8  -> #const GLFW_JOYSTICK_9
      Joystick9  -> #const GLFW_JOYSTICK_10
      Joystick10 -> #const GLFW_JOYSTICK_11
      Joystick11 -> #const GLFW_JOYSTICK_12
      Joystick12 -> #const GLFW_JOYSTICK_13
      Joystick13 -> #const GLFW_JOYSTICK_14
      Joystick14 -> #const GLFW_JOYSTICK_15
      Joystick15 -> #const GLFW_JOYSTICK_16

  fromC i = case i of
      (#const GLFW_JOYSTICK_1 ) -> Joystick0
      (#const GLFW_JOYSTICK_2 ) -> Joystick1
      (#const GLFW_JOYSTICK_3 ) -> Joystick2
      (#const GLFW_JOYSTICK_4 ) -> Joystick3
      (#const GLFW_JOYSTICK_5 ) -> Joystick4
      (#const GLFW_JOYSTICK_6 ) -> Joystick5
      (#const GLFW_JOYSTICK_7 ) -> Joystick6
      (#const GLFW_JOYSTICK_8 ) -> Joystick7
      (#const GLFW_JOYSTICK_9 ) -> Joystick8
      (#const GLFW_JOYSTICK_10) -> Joystick9
      (#const GLFW_JOYSTICK_11) -> Joystick10
      (#const GLFW_JOYSTICK_12) -> Joystick11
      (#const GLFW_JOYSTICK_13) -> Joystick12
      (#const GLFW_JOYSTICK_14) -> Joystick13
      (#const GLFW_JOYSTICK_15) -> Joystick14
      (#const GLFW_JOYSTICK_16) -> Joystick15
      _                         -> makeFromCError "Joystick" i

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- Time

getTime :: IO Double
getTime =
    realToFrac `fmap` glfwGetTime

setTime :: Double -> IO ()
setTime =
    glfwSetTime . realToFrac

resetTime :: IO ()
resetTime =
    setTime (0 :: Double)

sleep :: Double -> IO ()
sleep =
    glfwSleep . realToFrac

-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --
-- Version information

getGlfwVersion :: IO Version
getGlfwVersion =
    alloca $ \p0 ->
    alloca $ \p1 ->
    alloca $ \p2 -> do
        glfwGetVersion p0 p1 p2
        v0 <- fromC `fmap` peek p0
        v1 <- fromC `fmap` peek p1
        v2 <- fromC `fmap` peek p2
        return $ Version [v0, v1, v2] []

getGlVersion :: IO Version
getGlVersion =
    alloca $ \p0 ->
    alloca $ \p1 ->
    alloca $ \p2 -> do
        glfwGetGLVersion p0 p1 p2
        v0 <- fromC `fmap` peek p0
        v1 <- fromC `fmap` peek p1
        v2 <- fromC `fmap` peek p2
        return $ Version [v0, v1, v2] []

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

glfwPress :: CInt
glfwPress = #const GLFW_PRESS

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

class C h c where
  toC   :: h -> c
  fromC :: c -> h

  toC   = undefined
  fromC = undefined

makeFromCError :: (Show c) => String -> c -> a
makeFromCError s c = error (s ++ " fromC: no match for " ++ show c)

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

instance C Bool CInt where
  toC False = #const GL_FALSE
  toC True  = #const GL_TRUE

  fromC (#const GL_FALSE) = False
  fromC (#const GL_TRUE)  = True
  fromC i                 = makeFromCError "Bool" i

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

instance C Char CInt where
  toC   = fromIntegral . ord
  fromC = chr . fromIntegral

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

instance C Float CFloat where
  toC   = realToFrac
  fromC = realToFrac

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

instance C Int CInt where
  toC   = fromIntegral
  fromC = fromIntegral

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

charCallback          :: IORef (Maybe (FunPtr GlfwCharCallback))
keyCallback           :: IORef (Maybe (FunPtr GlfwKeyCallback))
mouseButtonCallback   :: IORef (Maybe (FunPtr GlfwMouseButtonCallback))
mousePositionCallback :: IORef (Maybe (FunPtr GlfwMousePositionCallback))
mouseWheelCallback    :: IORef (Maybe (FunPtr GlfwMouseWheelCallback))
windowCloseCallback   :: IORef (Maybe (FunPtr GlfwWindowCloseCallback))
windowRefreshCallback :: IORef (Maybe (FunPtr GlfwWindowRefreshCallback))
windowSizeCallback    :: IORef (Maybe (FunPtr GlfwWindowSizeCallback))

charCallback          = unsafePerformIO (newIORef Nothing)
{-# NOINLINE charCallback #-}
keyCallback           = unsafePerformIO (newIORef Nothing)
{-# NOINLINE keyCallback #-}
mouseButtonCallback   = unsafePerformIO (newIORef Nothing)
{-# NOINLINE mouseButtonCallback #-}
mousePositionCallback = unsafePerformIO (newIORef Nothing)
{-# NOINLINE mousePositionCallback #-}
mouseWheelCallback    = unsafePerformIO (newIORef Nothing)
{-# NOINLINE mouseWheelCallback #-}
windowCloseCallback   = unsafePerformIO (newIORef Nothing)
{-# NOINLINE windowCloseCallback #-}
windowRefreshCallback = unsafePerformIO (newIORef Nothing)
{-# NOINLINE windowRefreshCallback #-}
windowSizeCallback    = unsafePerformIO (newIORef Nothing)
{-# NOINLINE windowSizeCallback #-}

storeCallback :: IORef (Maybe (FunPtr a)) -> FunPtr a -> IO ()
storeCallback ior cb =
    atomicModifyIORef ior (\mcb -> (Just cb, mcb)) >>= maybe (return ()) freeHaskellFunPtr